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
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 755, Thu Dec 14 07:57:55 2000 UTC revision 756, Thu Dec 14 16:01:33 2000 UTC
# Line 16  Line 16 
16      type rebindings = SrcPath.rebindings      type rebindings = SrcPath.rebindings
17    
18      val nativeSpec = SrcPath.osstring_relative      val nativeSpec = SrcPath.osstring_relative
19        val nativePreSpec = SrcPath.osstring_prefile_relative
     val nativePre = SrcPath.osstring_prefile  
20    
21      val srcpath = SrcPath.file      val srcpath = SrcPath.file
22    
23        val augment = SrcPath.extend
24    
25      exception ToolError of { tool: string, msg: string }      exception ToolError of { tool: string, msg: string }
26    
27      type pathmaker = string -> presrcpath      type pathmaker = unit -> presrcpath
28    
29        type fnspec = { name: string, mkpath: pathmaker }
30    
31      datatype toolopt =      datatype toolopt =
32          STRING of { name: string, mkpath: pathmaker }          STRING of fnspec
33        | SUBOPTS of { name: string, opts: toolopts }        | SUBOPTS of { name: string, opts: toolopts }
34      withtype toolopts = toolopt list      withtype toolopts = toolopt list
35    
# Line 49  Line 52 
52    
53      type rulefn = unit -> partial_expansion      type rulefn = unit -> partial_expansion
54      type rulecontext = rulefn -> partial_expansion      type rulecontext = rulefn -> partial_expansion
55      type rule =      type rule = { spec: spec,
56          { spec: spec, mkNativePath: pathmaker, context: rulecontext } ->                    native2pathmaker: string -> pathmaker,
57                      context: rulecontext,
58                      defaultClassOf: fnspec -> class option } ->
59          partial_expansion          partial_expansion
60    
61        type gcarg = { name: string, mkfname: unit -> string }
62    
63      type registry = { classes : rule StringMap.map ref,      type registry = { classes : rule StringMap.map ref,
64                        sfx_classifiers : (string -> class option) ref,                        sfx_classifiers : (string -> class option) ref,
65                        gen_classifiers : (string -> class option) ref }                        gen_classifiers : (gcarg -> class option) ref }
66    
67      fun layer (look1, look2) s = case look1 s of NONE => look2 s | x => x      fun layer (look1, look2) s = case look1 s of NONE => look2 s | x => x
68    
# Line 102  Line 109 
109    
110      datatype classifier =      datatype classifier =
111          SFX_CLASSIFIER of string -> class option          SFX_CLASSIFIER of string -> class option
112        | GEN_CLASSIFIER of string -> class option        | GEN_CLASSIFIER of gcarg -> class option
113    
114      fun stdSfxClassifier { sfx, class } =      fun stdSfxClassifier { sfx, class } =
115          SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)          SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)
# Line 217  Line 224 
224                           cleanup = fn _ => () }                           cleanup = fn _ => () }
225    
226      (* query default class *)      (* query default class *)
227      fun defaultClassOf load_plugin p = let      fun defaultClassOf load_plugin (s: fnspec) = let
228            val p = #name s
229            val mkfname = SrcPath.osstring_prefile o #mkpath s
230            val gcarg = { name = p, mkfname = mkfname }
231          fun sfx_gen_check e =          fun sfx_gen_check e =
232              case sfx_classifiers e of              case sfx_classifiers e of
233                  SOME c => SOME c                  SOME c => SOME c
234                | NONE => gen_classifiers p                | NONE => gen_classifiers gcarg
   
235      in      in
236          case OS.Path.ext p of          case OS.Path.ext p of
237              SOME e =>              SOME e =>
# Line 234  Line 243 
243                       if globally load_plugin plugin then sfx_gen_check e                       if globally load_plugin plugin then sfx_gen_check e
244                       else NONE                       else NONE
245                   end)                   end)
246            | NONE => gen_classifiers p            | NONE => gen_classifiers gcarg
247      end      end
248    
249      fun parseOptions { tool, keywords, options } = let      fun parseOptions { tool, keywords, options } = let
# Line 255  Line 264 
264          loop (options, StringMap.empty, [])          loop (options, StringMap.empty, [])
265      end      end
266    
267      fun smlrule { spec, context, mkNativePath } = let      fun smlrule { spec, context, native2pathmaker, defaultClassOf } = let
268          val { name, mkpath, opts = oto, derived, ... } : spec = spec          val { name, mkpath, opts = oto, derived, ... } : spec = spec
269          val tool = "sml"          val tool = "sml"
270          fun err s = raise ToolError { tool = tool, msg = s }          fun err s = raise ToolError { tool = tool, msg = s }
# Line 298  Line 307 
307                  in                  in
308                      (srq, setup)                      (srq, setup)
309                  end                  end
310          val p = srcpath (mkpath name)          val p = srcpath (mkpath ())
311      in      in
312          ({ smlfiles = [(p, srq, setup)],          ({ smlfiles = [(p, srq, setup)],
313             sources = [(p, { class = "sml", derived = derived })],             sources = [(p, { class = "sml", derived = derived })],
314             cmfiles = [] },             cmfiles = [] },
315           [])           [])
316      end      end
317      fun cmrule { spec, context, mkNativePath } = let      fun cmrule { spec, context, native2pathmaker, defaultClassOf } = let
318          val { name, mkpath, opts = oto, derived, ... } : spec = spec          val { name, mkpath, opts = oto, derived, ... } : spec = spec
319          fun err m = raise ToolError { tool = "cm", msg = m }          fun err m = raise ToolError { tool = "cm", msg = m }
320          fun proc_opts (rb, vrq, []) = (rb, vrq)          fun proc_opts (rb, vrq, []) = (rb, vrq)
# Line 326  Line 335 
335              (case opts of              (case opts of
336                   [SUBOPTS { name = "anchor", opts = [STRING { name, ... }] },                   [SUBOPTS { name = "anchor", opts = [STRING { name, ... }] },
337                    SUBOPTS { name = "value", opts = [STRING v] }] =>                    SUBOPTS { name = "value", opts = [STRING v] }] =>
338                   proc_opts ({ anchor = name, value = #mkpath v (#name v) }                   proc_opts ({ anchor = name, value = #mkpath v () }
339                              :: rb,                              :: rb,
340                              vrq, r)                              vrq, r)
341                 | _ => err "ill-formed bind specification")                 | _ => err "ill-formed bind specification")
# Line 335  Line 344 
344          val (rb, vrq) = case oto of          val (rb, vrq) = case oto of
345                              NONE => ([], NONE)                              NONE => ([], NONE)
346                            | SOME l => proc_opts ([], NONE, l)                            | SOME l => proc_opts ([], NONE, l)
347          val p = srcpath (mkpath name)          val p = srcpath (mkpath ())
348      in      in
349          ({ smlfiles = [],          ({ smlfiles = [],
350             sources = [(p, { class = "cm", derived = derived })],             sources = [(p, { class = "cm", derived = derived })],
# Line 344  Line 353 
353      end      end
354    
355      fun expand { error, local_registry = lr, spec, context, load_plugin } = let      fun expand { error, local_registry = lr, spec, context, load_plugin } = let
356          fun mkNativePath s =          val dummy = ({ smlfiles = [], cmfiles = [], sources = [] }, [])
357            fun norule _ = dummy
358            fun native2pathmaker s () =
359              SrcPath.native { err = error } { context = context, spec = s }              SrcPath.native { err = error } { context = context, spec = s }
360          fun class2rule class =          fun class2rule class =
361              case classes class of              case classes class of
# Line 354  Line 365 
365                      val plugin = OS.Path.joinBaseExt { base = base,                      val plugin = OS.Path.joinBaseExt { base = base,
366                                                         ext = SOME "cm" }                                                         ext = SOME "cm" }
367                      fun complain () =                      fun complain () =
368                          (error (concat ["unknown class \"", class, "\""]);                          (error (concat ["unknown class: ", class]);
369                           smlrule)                           norule)
370                  in                  in
371                      if globally (load_plugin context) plugin then                      if globally (load_plugin context) plugin then
372                          case classes class of                          case classes class of
# Line 364  Line 375 
375                      else complain ()                      else complain ()
376                  end                  end
377    
378          fun expand1 (spec as { name, class = co, ... }) = let          fun expand1 (spec as { name, mkpath, class = co, ... }) = let
379                val fns = { name = name, mkpath = mkpath }
380              val rule =              val rule =
381                  case co of                  case co of
382                      SOME c0 => class2rule (String.map Char.toLower c0)                      SOME c0 => class2rule (String.map Char.toLower c0)
383                    | NONE =>                    | NONE =>
384                          (case defaultClassOf (load_plugin context) name of                          (case defaultClassOf (load_plugin context) fns of
385                               SOME c => class2rule c                               SOME c => class2rule c
386                             | NONE => smlrule)                             | NONE =>
387                                 (error (concat ["unable to classify: ", name]);
388                                  norule))
389              fun rcontext rf = let              fun rcontext rf = let
390                  val dir = SrcPath.osstring_dir context                  val dir = SrcPath.osstring_dir context
391                  val cwd = OS.FileSys.getDir ()                  val cwd = OS.FileSys.getDir ()
# Line 383  Line 397 
397              end              end
398          in          in
399              rule { spec = spec, context = rcontext,              rule { spec = spec, context = rcontext,
400                     mkNativePath = mkNativePath }                     native2pathmaker = native2pathmaker,
401                       defaultClassOf = defaultClassOf (load_plugin context) }
402              handle ToolError { tool, msg } =>              handle ToolError { tool, msg } =>
403                     (error (concat ["tool \"", tool, "\" failed: ", msg]);                     (error (concat ["tool \"", tool, "\" failed: ", msg]);
404                      ({ smlfiles = [], cmfiles = [], sources = [] }, []))                      dummy)
405          end          end
406          fun loop (expansion, []) = expansion          fun loop (expansion, []) = expansion
407            | loop ({ smlfiles, cmfiles, sources }, item :: items) = let            | loop ({ smlfiles, cmfiles, sources }, item :: items) = let

Legend:
Removed from v.755  
changed lines
  Added in v.756

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