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 286, Fri May 21 07:47:16 1999 UTC revision 297, Thu May 27 08:29:19 1999 UTC
# Line 25  Line 25 
25                       structure Lex = CMLex                       structure Lex = CMLex
26                       structure LrParser = LrParser)                       structure LrParser = LrParser)
27    
     (* The error function must look for the source using the GroupReg  
      * group register because the source must not be hard-wired into it  
      * (via closure creation).  The reason for this is that the error  
      * function will get cached in SmlInfo.info but the source will change  
      * when one re-runs the analysis. *)  
   
28      fun parse primconf group = let      fun parse primconf group = let
29    
30          val groupreg = GroupReg.new ()          val groupreg = GroupReg.new ()
31          val fnpolicy = FilenamePolicy.default          val fnpolicy = FilenamePolicy.default
32          val params = { groupreg = groupreg,          val params = { groupreg = groupreg,
33                         fnpolicy = fnpolicy,                         fnpolicy = fnpolicy,
34                         primconf = primconf }                         primconf = primconf,
35                           keep_going = false }
36    
37          fun parse' (group, groupstack) = let          val gc = ref AbsPathMap.empty   (* the "group cache" *)
38    
39              val currentDir = AbsPath.dir group          fun mparse (group, groupstack) =
40              val context = AbsPath.relativeContext (AbsPath.dir group)              case AbsPathMap.find (!gc, group) of
41              val filename = AbsPath.name group                  SOME g => g
42              val _ = Say.vsay (concat ["[scanning ", filename, "]\n"])                | NONE => let
43              val stream = TextIO.openIn filename                      val g = parse' (group, groupstack)
             val errcons =  
                 { linewidth = !P.linewidth, flush = P.flush, consumer = P.say }  
             val source = S.newSource (filename, 1, stream, false, errcons)  
             val sourceMap = #sourceMap source  
             val _ = GroupReg.register groupreg (group, source)  
             fun error' region m b = let  
                 val src = GroupReg.lookup groupreg group  
44              in              in
45                  EM.error src region EM.COMPLAIN m b                      gc := AbsPathMap.insert (!gc, group, g);
46                        g
47              end              end
             fun error region m = error' region m EM.nullErrorBody  
   
             (* 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 (p1, p2) p =  
                 (case parse' (p, (group, (source, p1, p2)) :: groupstack) of  
                      NONE => (#anyErrors source := true;  
                               CMSemant.emptyGroup group)  
                    | SOME res => res)  
                      handle exn as IO.Io _ =>  
                          (error (p1, p2) (General.exnMessage exn);  
                           CMSemant.emptyGroup group)  
   
             fun doMember (p, p1, p2, c, e) =  
                 CMSemant.member (params, recParse (p1, p2))  
                                 { sourcepath = p,  
                                   group = group,  
                                   class = c,  
                                   error = e }  
48    
49            and parse' (group, groupstack) = let
50              (* checking for cycles among groups and printing them nicely *)              (* checking for cycles among groups and printing them nicely *)
             val _ = let  
51                  fun findCycle ([], _) = []                  fun findCycle ([], _) = []
52                    | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =                    | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =
53                      if AbsPath.compare (g, group) = EQUAL then rev (h :: cyc)                      if AbsPath.compare (g, group) = EQUAL then rev (h :: cyc)
# Line 105  Line 72 
72                      EM.error s (p1, p2) EM.COMPLAIN                      EM.error s (p1, p2) EM.COMPLAIN
73                               ("group hierarchy forms a cycle with " ^                               ("group hierarchy forms a cycle with " ^
74                                AbsPath.spec group)                                AbsPath.spec group)
75                           pphist;                             pphist
                     raise LrParser.ParseError  
76                  end                  end
77    
78                (* normal processing -- used when there is no cycle to report *)
79                fun normal_processing () = let
80                    val currentDir = AbsPath.dir group
81                    val context = AbsPath.relativeContext (AbsPath.dir group)
82                    val filename = AbsPath.name group
83                    val _ = Say.vsay (concat ["[scanning ", filename, "]\n"])
84                    val stream = TextIO.openIn filename
85                    val errcons = { linewidth = !P.linewidth,
86                                    flush = P.flush,
87                                    consumer = P.say }
88                    val source = S.newSource (filename, 1, stream, false, errcons)
89                    val sourceMap = #sourceMap source
90                    val _ = GroupReg.register groupreg (group, source)
91    
92                    (* We can hard-wire the source into this
93                     * error function because the function is only for
94                     * immediate use and doesn't get stored into persistent
95                     * data structures. *)
96                    fun error r m =
97                        EM.error source r EM.COMPLAIN m EM.nullErrorBody
98    
99                    (* recParse returns a group (not an option).
100                     * This function is used to parse aliases and sub-groups.
101                     * Errors are propagated by explicitly setting the
102                     * "anyErrors" flag of the parent group. *)
103                    fun recParse (p1, p2) p = let
104                        val groupstack' = (group, (source, p1, p2)) :: groupstack
105              in              in
106                  case findCycle (groupstack, []) of                      case mparse (p, groupstack') of
107                      [] => ()                          NONE => (#anyErrors source := true;
108                    | h :: t => report (h, t)                                   CMSemant.emptyGroup group)
109                          | SOME res => res
110              end              end
111                    handle exn as IO.Io _ =>
112                        (error (p1, p2) (General.exnMessage exn);
113                         CMSemant.emptyGroup group)
114    
115                    fun doMember (p, p1, p2, c) =
116                        CMSemant.member (params, recParse (p1, p2))
117                                        { sourcepath = p, class = c,
118                                          group = (group, (p1, p2)) }
119    
120              val lexarg = let              val lexarg = let
121                  (* local state *)                  (* local state *)
122                  val depth = ref 0                  val depth = ref 0
123                  val curstring = ref []                  val curstring = ref []
124                  val startpos = ref 0                  val startpos = ref 0
125                  val instring = ref NONE                      val instring = ref false
126                  (* handling comments *)                  (* handling comments *)
127                  fun enterC () = depth := !depth + 1                  fun enterC () = depth := !depth + 1
128                  fun leaveC () = let val d = !depth - 1 in depth := d; d = 0 end                      fun leaveC () = let
129                            val d = !depth - 1
130                        in
131                            depth := d;
132                            d = 0
133                        end
134                  (* handling strings *)                  (* handling strings *)
135                  fun newS (pos, kind) =                      fun newS pos =
136                      (instring := SOME kind;                          (instring := true; curstring := []; startpos := pos)
                      curstring := [];  
                      startpos := pos)  
137                  fun addS c = curstring := c :: !curstring                  fun addS c = curstring := c :: !curstring
138                  fun addSC (s, offs) =                  fun addSC (s, offs) =
139                      addS (chr (ord (String.sub (s, 2)) - offs))                      addS (chr (ord (String.sub (s, 2)) - offs))
# Line 141  Line 147 
147                                ("illegal decimal char spec: " ^ ns)                                ("illegal decimal char spec: " ^ ns)
148                  end                  end
149                  fun getS (pos, tok) =                  fun getS (pos, tok) =
150                      (instring := NONE;                          (instring := false;
151                       tok (implode (rev (!curstring)), !startpos, pos))                       tok (implode (rev (!curstring)), !startpos, pos))
152                  (* handling EOF *)                  (* handling EOF *)
153                  fun handleEof () = let                  fun handleEof () = let
154                      val pos = SM.lastChange sourceMap                      val pos = SM.lastChange sourceMap
155                  in                  in
156                      if !depth > 0 then                      if !depth > 0 then
                         error (pos, pos) "unexpected end of input in comment"  
                     else if isSome (!instring) then  
157                          error (pos, pos)                          error (pos, pos)
158                              ("unexpected end of input in " ^ valOf (!instring))                                    "unexpected end of input in comment"
159                            else if !instring then
160                                error (pos, pos)
161                                      "unexpected end of input in string"
162                      else ();                      else ();
163                      pos                      pos
164                  end                  end
# Line 177  Line 184 
184              val (parseResult, _) =              val (parseResult, _) =
185                  CMParse.parse (lookAhead, tokenStream,                  CMParse.parse (lookAhead, tokenStream,
186                                 fn (s,p1,p2) => error (p1, p2) s,                                 fn (s,p1,p2) => error (p1, p2) s,
187                                 (group, context, error', error, recParse,                                     (group, context, error, recParse,
188                                  doMember))                                      doMember, params))
189          in          in
190              TextIO.closeIn stream;              TextIO.closeIn stream;
191              if !(#anyErrors source) then NONE              if !(#anyErrors source) then NONE
# Line 186  Line 193 
193          end          end
194          handle LrParser.ParseError => NONE          handle LrParser.ParseError => NONE
195      in      in
196          parse' (group, [])              case findCycle (groupstack, []) of
197                    h :: t => (report (h, t); NONE)
198                  | [] => normal_processing ()
199            end
200    
201        in
202            mparse (group, [])
203      end      end
204  end  end

Legend:
Removed from v.286  
changed lines
  Added in v.297

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