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/tools/main/private-tools.sml
[smlnj] / sml / trunk / src / cm / tools / main / private-tools.sml  
ViewVC logotype

Diff of /sml/trunk/src/cm/tools/main/private-tools.sml

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

revision 1631, Fri Sep 24 21:21:31 2004 UTC revision 1632, Mon Sep 27 22:18:07 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 valsyn what { value, ctlName, tyName } =
375                                        fail (concat ["error ", what,
376                                                      " controller: unable to parse value `",
377                                                      value, "' for ", ctlName,
378                                                      " : ", tyName])
379                                    fun set (what, c, v) =
380                                        Controls.set (c, v)
381                                        handle Controls.ValueSyntax vse =>
382                                               valsyn what vse
383                                    fun mk (n, v) =
384                                        case ControlRegistry.control
385                                                 BasicControl.topregistry
386                                                 (fields #"." n)
387                                         of NONE =>
388                                              err ("no such control: " ^ n)
389                                          | SOME c => let
390                                                fun sr () =
391                                                    let val orig = Controls.get c
392                                                    in
393                                                     fn () =>
394                                                        set ("restoring", c, orig)
395                                                    end
396                                                fun s () = set ("setting", c, v)
397                                            in
398                                                { save'restore = sr, set = s }
399                                            end
400                                    fun loop ([], a) = a
401                                      | loop (STRING nv :: r, a) =
402                                          (case fields #"=" (#name nv) of
403                                               [n, v] => loop (r, mk (n, v) :: a)
404                                             | [n] => loop (r, mk (n, "true") :: a)
405                                             | _ => err "invalid controller spec")
406                                      | loop (SUBOPTS { name = "name",
407                                                        opts = [STRING n] } ::
408                                              SUBOPTS { name = "value",
409                                                        opts = [STRING v] } :: r,
410                                              a) =
411                                          loop (r, mk (#name n, #name v) :: a)
412                                      | loop (SUBOPTS { name = "name",
413                                                        opts = [STRING n] } :: r,
414                                              a) =
415                                          loop (r, mk (#name n, "true") :: a)
416                                      | loop _ = err "invalid controller spec"
417                                in
418                                    loop (subopts, [])
419                                end
420    
421                      val splitting = let                      val splitting = let
422                          fun invalid () = err "invalid lambdasplit spec"                          fun invalid () = err "invalid lambdasplit spec"
423                          fun spec (s: fnspec) =                          fun spec (s: fnspec) =
# Line 354  Line 431 
431                            | SOME [STRING x] => spec x                            | SOME [STRING x] => spec x
432                            | _ => invalid ()                            | _ => invalid ()
433                      end                      end
434                        val controllers =
435                            if lazysml then lazy_controller :: controllers
436                            else controllers
437                  in                  in
438                      (srq, setup, splitting, noguid, locl)                      (srq, setup, splitting, noguid, locl, controllers)
439                  end                  end
440          val p = srcpath (mkpath ())          val p = srcpath (mkpath ())
441          val sparam = { share = srq, setup = setup, split = splitting,          val sparam = { share = srq, setup = setup, split = splitting,
442                         noguid = noguid,                         noguid = noguid,
443                         locl = locl }                         locl = locl, controllers = controllers }
444      in      in
445          ({ smlfiles = [(p, sparam)],          ({ smlfiles = [(p, sparam)],
446             sources = [(p, { class = "sml", derived = derived })],             sources = [(p, { class = "sml", derived = derived })],
# Line 482  Line 562 
562          fun sfx (s, c) =          fun sfx (s, c) =
563              registerClassifier (stdSfxClassifier { sfx = s, class = c })              registerClassifier (stdSfxClassifier { sfx = s, class = c })
564      in      in
565          val _ = registerClass ("sml", smlrule)          val _ = registerClass ("sml", smlrule false)
566            val _ = registerClass ("lazysml", smlrule true)
567          val _ = registerClass ("cm", cmrule)          val _ = registerClass ("cm", cmrule)
568    
569          val _ = sfx ("sml", "sml")          val _ = sfx ("sml", "sml")
570            val _ = sfx ("lml", "lazysml")
571          val _ = sfx ("sig", "sml")          val _ = sfx ("sig", "sml")
572          val _ = sfx ("fun", "sml")          val _ = sfx ("fun", "sml")
573          val _ = sfx ("cm", "cm")          val _ = sfx ("cm", "cm")
Legend:
Removed from v.1631  
changed lines
  Added in v.1632
root@smlnj-gforge.cs.uchicago.edu
 ViewVC Help
Powered by ViewVC 1.0.0  
Powered By FusionForge