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/branches/blume-private-devel/src/cm/smlfile/smlinfo.sml
ViewVC logotype

Diff of /sml/branches/blume-private-devel/src/cm/smlfile/smlinfo.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1634, Tue Sep 28 15:53:10 2004 UTC revision 1635, Tue Sep 28 17:12:31 2004 UTC
# Line 25  Line 25 
25            explicit_core_sym: Symbol.symbol option,            explicit_core_sym: Symbol.symbol option,
26            extra_compenv: StaticEnv.staticEnv option }            extra_compenv: StaticEnv.staticEnv option }
27    
28        type controller =
29             { save'restore : unit -> unit -> unit,
30               set : unit -> unit }
31    
32      type info_args =      type info_args =
33          { sourcepath: SrcPath.file,          { sourcepath: SrcPath.file,
34            group: SrcPath.file * region,            group: SrcPath.file * region,
35            sh_spec: Sharing.request,            sh_spec: Sharing.request,
36            setup: string option * string option,            setup: string option * string option,
37            locl: bool }            locl: bool,
38              controllers: controller list }
39    
40      val eq : info * info -> bool        (* compares sourcepaths *)      val eq : info * info -> bool        (* compares sourcepaths *)
41      val compare : info * info -> order  (* compares sourcepaths *)      val compare : info * info -> order  (* compares sourcepaths *)
# Line 69  Line 74 
74      val attribs : info -> attribs      val attribs : info -> attribs
75      val lastseen : info -> TStamp.t      val lastseen : info -> TStamp.t
76      val setup : info -> string option * string option      val setup : info -> string option * string option
77        val controllers : info -> controller list
78      val is_local : info -> bool      val is_local : info -> bool
79      val setguid : info * string -> unit      val setguid : info * string -> unit
80      val guid : info -> string      val guid : info -> string
# Line 117  Line 123 
123                       explicit_core_sym: Symbol.symbol option,                       explicit_core_sym: Symbol.symbol option,
124                       extra_compenv: StaticEnv.staticEnv option }                       extra_compenv: StaticEnv.staticEnv option }
125    
126        type controller =
127             { save'restore : unit -> unit -> unit,
128               set : unit -> unit }
129    
130      type info_args = { sourcepath: SrcPath.file,      type info_args = { sourcepath: SrcPath.file,
131                         group: SrcPath.file * region,                         group: SrcPath.file * region,
132                         sh_spec: Sharing.request,                         sh_spec: Sharing.request,
133                         setup: string option * string option,                         setup: string option * string option,
134                         locl: bool }                         locl: bool,
135                           controllers: controller list }
136    
137      type generation = unit ref      type generation = unit ref
138    
# Line 145  Line 156 
156                    sh_spec: Sharing.request,                    sh_spec: Sharing.request,
157                    attribs: attribs,                    attribs: attribs,
158                    setup: string option * string option,                    setup: string option * string option,
159                    locl:  bool }                    locl:  bool,
160                      controllers: controller list }
161    
162      type ord_key = info      type ord_key = info
163    
# Line 165  Line 177 
177          sh_mode := m          sh_mode := m
178      fun attribs (INFO { attribs = a, ... }) = a      fun attribs (INFO { attribs = a, ... }) = a
179      fun setup (INFO { setup = s, ... }) = s      fun setup (INFO { setup = s, ... }) = s
180        fun controllers (INFO { controllers = c, ... }) = c
181      fun is_local (INFO { locl, ... }) = locl      fun is_local (INFO { locl, ... }) = locl
182    
183      fun gerror (gp: GeneralParams.info) = GroupReg.error (#groupreg gp)      fun gerror (gp: GeneralParams.info) = GroupReg.error (#groupreg gp)
# Line 225  Line 238 
238      end      end
239    
240      fun info' attribs (gp: GeneralParams.info) arg = let      fun info' attribs (gp: GeneralParams.info) arg = let
241          val { sourcepath, group = gr as (group, region), sh_spec, setup, locl }          val { sourcepath, group = gr as (group, region), sh_spec, setup,
242                  locl, controllers }
243              = arg              = arg
244          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
245          fun mkSkelname () = FNP.mkSkelName policy sourcepath          fun mkSkelname () = FNP.mkSkelName policy sourcepath
# Line 322  Line 336 
336                 sh_spec = sh_spec,                 sh_spec = sh_spec,
337                 attribs = attribs,                 attribs = attribs,
338                 setup = setup,                 setup = setup,
339                 locl = locl }                 locl = locl,
340                   controllers = controllers }
341      end      end
342    
343      fun info (split, noguid) =      fun info (split, noguid) =
# Line 333  Line 348 
348      (* the following functions are only concerned with getting the data,      (* the following functions are only concerned with getting the data,
349       * not with checking time stamps *)       * not with checking time stamps *)
350      fun getParseTree gp (i as INFO ir, quiet, noerrors) = let      fun getParseTree gp (i as INFO ir, quiet, noerrors) = let
351          val { sourcepath, persinfo = PERS { parsetree, ... }, ... } = ir          val { sourcepath, persinfo = PERS { parsetree, ... },
352                  controllers, ... } =
353                ir
354          val err = if noerrors then (fn m => ())          val err = if noerrors then (fn m => ())
355                    else (fn m => error gp i EM.COMPLAIN m EM.nullErrorBody)                    else (fn m => error gp i EM.COMPLAIN m EM.nullErrorBody)
356      in      in
357          case !parsetree of          case !parsetree of
358              SOME pt => SOME pt              SOME pt => SOME pt
359            | NONE => let            | NONE => let
360                    val orig_settings =
361                        map (fn c => #save'restore c ()) controllers
362                  fun work stream = let                  fun work stream = let
363                      val _ = if noerrors orelse quiet then ()                      val _ = if noerrors orelse quiet then ()
364                              else Say.vsay ["[parsing ",                              else Say.vsay ["[parsing ",
# Line 378  Line 397 
397                          else (source, source)                          else (source, source)
398                      end                      end
399                  in                  in
400                        app (fn c => #set c ()) controllers;
401                      (SF.parse parse_source, source)                      (SF.parse parse_source, source)
402                        before app (fn r => r ()) orig_settings
403                  end                  end
404                  fun openIt () = TextIO.openIn (SrcPath.osstring sourcepath)                  fun openIt () = TextIO.openIn (SrcPath.osstring sourcepath)
405                    fun cleanup _ = app (fn r => r ()) orig_settings
406                  val pto =                  val pto =
407                      SOME (SafeIO.perform { openIt = openIt,                      SOME (SafeIO.perform { openIt = openIt,
408                                             closeIt = TextIO.closeIn,                                             closeIt = TextIO.closeIn,
409                                             work = work,                                             work = work,
410                                             cleanup = fn _ => () })                                             cleanup = cleanup })
411                  (* Counting the trees explicitly may be a bit slow,                  (* Counting the trees explicitly may be a bit slow,
412                   * but maintaining an accurate count is difficult, so                   * but maintaining an accurate count is difficult, so
413                   * this method should be robust.  (I don't think that                   * this method should be robust.  (I don't think that

Legend:
Removed from v.1634  
changed lines
  Added in v.1635

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