Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/tools/nowebtool.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/tools/nowebtool.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 634 - (view) (download)

1 : blume 634 (*
2 :     * A tool for source code written using Norman Ramsey's "noweb".
3 :     *
4 :     * (C) 2000 Lucent Technologies, Bell Laboratories
5 :     *
6 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :     *)
8 :     structure NowebTool = struct
9 :     local
10 :     open Tools
11 :    
12 :     val tool = "Noweb"
13 :     val class = "noweb"
14 :    
15 :     val stdCmdPath = "notangle"
16 :    
17 :     val kw_target = "target" (* "master" keyword *)
18 :    
19 :     val kw_name = "name" (* sub-keywords... *)
20 :     val kw_root = "root"
21 :     val kw_class = "class"
22 :     val kw_options = "options"
23 :     val kw_lineformat = "lineformat"
24 :     val kw_cpif = "cpif"
25 :     val kwl =
26 :     [kw_name, kw_root, kw_class, kw_options, kw_lineformat, kw_cpif]
27 :    
28 :     fun err msg = raise ToolError { tool = tool, msg = msg }
29 :     fun kwerr what kw = err (concat [what, " keyword `", kw, "'"])
30 :     fun badkw kw = kwerr "unknown" kw
31 :     fun misskw kw = kwerr "missing" kw
32 :     fun badspec kw = kwerr "bad specification for " kw
33 :    
34 :     structure StringMap = RedBlackMapFn
35 :     (struct
36 :     type ord_key = string
37 :     val compare = String.compare
38 :     end)
39 :    
40 :     val lnr = ref (foldl StringMap.insert' StringMap.empty
41 :     [("sml", "(*#line %L \"%F\"*)"),
42 :     ("cm", "#line %L %F%N")])
43 :    
44 :     fun rule { spec, context, mkNativePath } = let
45 :     val (str, pathmaker, _, too) = spec
46 :     val sname = nativeSpec (pathmaker str)
47 :     fun oneTarget (tname, rname, tclass, topts, lf, cpif) = let
48 :     fun runcmd () = let
49 :     val cmdname = mkCmdName stdCmdPath
50 :     fun number f = concat ["-L'", f, "' "]
51 :     val nonumber = "-L'' "
52 :     val fmtopt =
53 :     case lf of
54 :     NONE => let
55 :     fun classNumbering c =
56 :     case StringMap.find (!lnr, c) of
57 :     NONE => nonumber
58 :     | SOME f => number f
59 :     in
60 :     case tclass of
61 :     SOME c => classNumbering c
62 :     | NONE =>
63 :     (case defaultClassOf tname of
64 :     SOME c => classNumbering c
65 :     | NONE => "-L'' ")
66 :     end
67 :     | SOME f => number f
68 :     val redirect = if cpif then "| cpif " else ">"
69 :     val cmd = concat [cmdname, " ", fmtopt, "-R'", rname, "' ",
70 :     sname, " ", redirect, tname]
71 :    
72 :     in
73 :     vsay ["[", cmd, "]\n"];
74 :     if OS.Process.system cmd = OS.Process.success then ()
75 :     else err cmd
76 :     end
77 :     in
78 :     if outdated tool ([tname], sname) then runcmd ()
79 :     else ();
80 :     (tname, mkNativePath, tclass, topts)
81 :     end
82 :    
83 :     fun simpleTarget { name, mkpath } = let
84 :     val tname = nativeSpec (mkpath name)
85 :     in
86 :     oneTarget (tname, tname, NONE, NONE, NONE, true)
87 :     end
88 :    
89 :     fun oneOpt (STRING x) = simpleTarget x
90 :     | oneOpt (SUBOPTS { name, opts }) = let
91 :     fun subopts [STRING x] = simpleTarget x
92 :     | subopts opts = let
93 :     val { matches, restoptions } =
94 :     parseOptions { tool = tool, keywords = kwl,
95 :     options = opts }
96 :     fun fmatch kw =
97 :     case matches kw of
98 :     NONE => misskw kw
99 :     | SOME [STRING { name, mkpath }] =>
100 :     nativeSpec (mkpath name)
101 :     | _ => badspec kw
102 :     fun smatch kw =
103 :     case matches kw of
104 :     NONE => NONE
105 :     | SOME [STRING { name, ... }] => SOME name
106 :     | _ => badspec kw
107 :     in
108 :     case restoptions of
109 :     [] => let
110 :     val tname = fmatch kw_name
111 :     val rname = getOpt (smatch kw_root, tname)
112 :     val tclass = smatch kw_class
113 :     val topts = matches kw_options
114 :     val lf = smatch kw_lineformat
115 :     val cpif =
116 :     case smatch kw_cpif of
117 :     NONE => true
118 :     | SOME s =>
119 :     (case Bool.fromString s of
120 :     SOME x => x
121 :     | NONE => badspec kw_cpif)
122 :     in
123 :     oneTarget (tname, rname, tclass, topts,
124 :     lf, cpif)
125 :     end
126 :     | _ => err "unrecognized target option(s)"
127 :     end
128 :     in
129 :     if name = kw_target then subopts opts
130 :     else badkw name
131 :     end
132 :     fun rulefn () =
133 :     ({ cmfiles = [], smlfiles = [] },
134 :     case too of
135 :     SOME opts => map oneOpt opts
136 :     | NONE => let
137 :     val { base, ext } = OS.Path.splitBaseExt sname
138 :     val base =
139 :     case ext of
140 :     NONE => base
141 :     | SOME e => if e = "nw" then base else sname
142 :     fun exp e = let
143 :     val tname = OS.Path.joinBaseExt { base = base,
144 :     ext = SOME e }
145 :     in
146 :     oneTarget (tname, tname, NONE, NONE, NONE, true)
147 :     end
148 :     in
149 :     [exp "sig", exp "sml"]
150 :     end)
151 :     in
152 :     context rulefn
153 :     end
154 :     in
155 :     val _ = registerClass (class, rule)
156 :     fun lineNumbering class = let
157 :     fun get () = StringMap.find (!lnr, class)
158 :     fun set NONE =
159 :     ((lnr := #1 (StringMap.remove (!lnr, class)))
160 :     handle LibBase.NotFound => ())
161 :     | set (SOME f) = lnr := StringMap.insert (!lnr, class, f)
162 :     in
163 :     { get = get, set = set }
164 :     end
165 :     end
166 :     end

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