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/tools/main/private-tools.sml
ViewVC logotype

Diff of /sml/branches/blume-private-devel/src/cm/tools/main/private-tools.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 45  Line 45 
45    
46      type splitting = int option option      type splitting = int option option
47    
48        type controller =
49             { save'restore: unit -> unit -> unit,
50               set: unit -> unit }
51    
52      type smlparams =      type smlparams =
53           { share: Sharing.request,           { share: Sharing.request,
54             setup: setup,             setup: setup,
55             split: splitting,             split: splitting,
56             noguid: bool,             noguid: bool,
57             locl: bool }             locl: bool,
58               controllers: controller list }
59    
60      type cmparams =      type cmparams =
61           { version: Version.t option,           { version: Version.t option,
# Line 279  Line 284 
284          loop (options, StringMap.empty, [])          loop (options, StringMap.empty, [])
285      end      end
286    
287      fun smlrule { spec, context, native2pathmaker, defaultClassOf, sysinfo } =      fun smlrule enforce_lazy
288                { spec, context, native2pathmaker, defaultClassOf, sysinfo } =
289      let val { name, mkpath, opts = oto, derived, ... } : spec = spec      let val { name, mkpath, opts = oto, derived, ... } : spec = spec
290          val tool = "sml"          val tool = "sml"
291          fun err s = raise ToolError { tool = tool, msg = s }          fun err s = raise ToolError { tool = tool, msg = s }
292            fun fail s = raise Fail ("(SML Tool) " ^ s)
293          val kw_setup = "setup"          val kw_setup = "setup"
294            val kw_with = "with"
295          val kw_lambdasplit = "lambdasplit"          val kw_lambdasplit = "lambdasplit"
296          val kw_noguid = "noguid"          val kw_noguid = "noguid"
297            val kw_local = "local"
298            val kw_lazy = "lazy"
299          val UseDefault = NONE          val UseDefault = NONE
300          val Suggest = SOME          val Suggest = SOME
301          val (srq, setup, splitting, noguid, locl) =          val lazy_controller =
302                { save'restore =
303                  fn () => let val orig = !Control.lazysml
304                           in
305                            fn () => Control.lazysml := orig
306                           end,
307                  set = fn () => Control.lazysml := true }
308            val (srq, setup, splitting, noguid, locl, controllers) =
309              case oto of              case oto of
310                  NONE => (Sharing.DONTCARE, (NONE, NONE), UseDefault,                  NONE => (Sharing.DONTCARE, (NONE, NONE), UseDefault,
311                           false, false)                           false, false, if enforce_lazy then [lazy_controller]
312                                           else [])
313                | SOME to => let                | SOME to => let
314                      val { matches, restoptions } =                      val { matches, restoptions } =
315                          parseOptions { tool = tool,                          parseOptions { tool = tool,
316                                         keywords = [kw_setup, kw_lambdasplit],                                         keywords = [kw_setup,
317                                                       kw_with,
318                                                       kw_lambdasplit],
319                                         options = to }                                         options = to }
320                      fun is_shspec "shared" = true                      fun is_shspec "shared" = true
321                        | is_shspec "private" = true                        | is_shspec "private" = true
# Line 310  Line 330 
330                            | _ => err "invalid option(s)"                            | _ => err "invalid option(s)"
331                      fun isKW kw s = String.compare (kw, s) = EQUAL                      fun isKW kw s = String.compare (kw, s) = EQUAL
332                      val (locls, restoptions) =                      val (locls, restoptions) =
333                          List.partition (isKW "local") restoptions                          List.partition (isKW kw_local) restoptions
334                      val (noguids, restoptions) =                      val (noguids, restoptions) =
335                          List.partition (isKW "noguid") restoptions                          List.partition (isKW kw_noguid) restoptions
336                        val (lazies, restoptions) =
337                            List.partition (isKW kw_lazy) restoptions
338                      val locl = not (List.null locls)                      val locl = not (List.null locls)
339                      val noguid = not (List.null noguids)                      val noguid = not (List.null noguids)
340                        val lazysml = enforce_lazy orelse not (List.null lazies)
341                      val _ = if List.null restoptions then ()                      val _ = if List.null restoptions then ()
342                              else err (concat                              else err (concat
343                                            ("invalid option(s): " ::                                            ("invalid option(s): " ::
# Line 341  Line 364 
364                                               opts = [STRING pre] }]) =>                                               opts = [STRING pre] }]) =>
365                              (SOME (#name pre), SOME (#name post))                              (SOME (#name pre), SOME (#name post))
366                            | _ => err "invalid setup spec"                            | _ => err "invalid setup spec"
367    
368                        val controllers =
369                            case matches kw_with of
370                                NONE => []
371                              | SOME subopts => let
372                                    fun fields c s =
373                                        String.fields (fn c' => c = c') s
374                                    fun set (c, v) =
375                                        Controls.set' (c, v)
376                                        handle Controls.ValueSyntax vse =>
377                                               fail (concat ["error setting \
378                                                             \ controller: \
379                                                             \unable to parse \
380                                                             \value `",
381                                                             #value vse, "' for ",
382                                                             #ctlName vse, " : ",
383                                                             #tyName vse])
384                                    fun mk (n, v) =
385                                        case ControlRegistry.control
386                                                 BasicControl.topregistry
387                                                 (fields #"." n)
388                                         of NONE =>
389                                              err ("no such control: " ^ n)
390                                          | SOME c =>
391                                              { save'restore =
392                                                  fn () => Controls.save'restore c,
393                                                set = set (c, v) }
394                                    fun loop ([], a) = a
395                                      | loop (STRING nv :: r, a) =
396                                          (case fields #"=" (#name nv) of
397                                               [n, v] => loop (r, mk (n, v) :: a)
398                                             | [n] => loop (r, mk (n, "true") :: a)
399                                             | _ => err "invalid controller spec")
400                                      | loop (SUBOPTS { name = "name",
401                                                        opts = [STRING n] } ::
402                                              SUBOPTS { name = "value",
403                                                        opts = [STRING v] } :: r,
404                                              a) =
405                                          loop (r, mk (#name n, #name v) :: a)
406                                      | loop (SUBOPTS { name = "name",
407                                                        opts = [STRING n] } :: r,
408                                              a) =
409                                          loop (r, mk (#name n, "true") :: a)
410                                      | loop _ = err "invalid controller spec"
411                                in
412                                    loop (subopts, [])
413                                end
414    
415                      val splitting = let                      val splitting = let
416                          fun invalid () = err "invalid lambdasplit spec"                          fun invalid () = err "invalid lambdasplit spec"
417                          fun spec (s: fnspec) =                          fun spec (s: fnspec) =
# Line 354  Line 425 
425                            | SOME [STRING x] => spec x                            | SOME [STRING x] => spec x
426                            | _ => invalid ()                            | _ => invalid ()
427                      end                      end
428                        val controllers =
429                            if lazysml then lazy_controller :: controllers
430                            else controllers
431                  in                  in
432                      (srq, setup, splitting, noguid, locl)                      (srq, setup, splitting, noguid, locl, controllers)
433                  end                  end
434          val p = srcpath (mkpath ())          val p = srcpath (mkpath ())
435          val sparam = { share = srq, setup = setup, split = splitting,          val sparam = { share = srq, setup = setup, split = splitting,
436                         noguid = noguid,                         noguid = noguid,
437                         locl = locl }                         locl = locl, controllers = controllers }
438      in      in
439          ({ smlfiles = [(p, sparam)],          ({ smlfiles = [(p, sparam)],
440             sources = [(p, { class = "sml", derived = derived })],             sources = [(p, { class = "sml", derived = derived })],
# Line 482  Line 556 
556          fun sfx (s, c) =          fun sfx (s, c) =
557              registerClassifier (stdSfxClassifier { sfx = s, class = c })              registerClassifier (stdSfxClassifier { sfx = s, class = c })
558      in      in
559          val _ = registerClass ("sml", smlrule)          val _ = registerClass ("sml", smlrule false)
560            val _ = registerClass ("lazysml", smlrule true)
561          val _ = registerClass ("cm", cmrule)          val _ = registerClass ("cm", cmrule)
562    
563          val _ = sfx ("sml", "sml")          val _ = sfx ("sml", "sml")
564            val _ = sfx ("lml", "lazysml")
565          val _ = sfx ("sig", "sml")          val _ = sfx ("sig", "sml")
566          val _ = sfx ("fun", "sml")          val _ = sfx ("fun", "sml")
567          val _ = sfx ("cm", "cm")          val _ = sfx ("cm", "cm")

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