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 651 - (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 : blume 642 val { name = str, mkpath, opts = too, derived, ... } : spec = spec
46 :     val p = mkpath str
47 :     val sname = nativeSpec p
48 : blume 634 fun oneTarget (tname, rname, tclass, topts, lf, cpif) = let
49 :     fun runcmd () = let
50 :     val cmdname = mkCmdName stdCmdPath
51 :     fun number f = concat ["-L'", f, "' "]
52 :     val nonumber = "-L'' "
53 :     val fmtopt =
54 :     case lf of
55 :     NONE => let
56 :     fun classNumbering c =
57 :     case StringMap.find (!lnr, c) of
58 :     NONE => nonumber
59 :     | SOME f => number f
60 :     in
61 :     case tclass of
62 :     SOME c => classNumbering c
63 :     | NONE =>
64 :     (case defaultClassOf tname of
65 :     SOME c => classNumbering c
66 :     | NONE => "-L'' ")
67 :     end
68 :     | SOME f => number f
69 :     val redirect = if cpif then "| cpif " else ">"
70 :     val cmd = concat [cmdname, " ", fmtopt, "-R'", rname, "' ",
71 :     sname, " ", redirect, tname]
72 :    
73 :     in
74 :     vsay ["[", cmd, "]\n"];
75 :     if OS.Process.system cmd = OS.Process.success then ()
76 :     else err cmd
77 :     end
78 :     in
79 :     if outdated tool ([tname], sname) then runcmd ()
80 :     else ();
81 : blume 642 { name = tname, mkpath = mkNativePath,
82 :     class = tclass, opts = topts, derived = true }
83 : blume 634 end
84 :    
85 :     fun simpleTarget { name, mkpath } = let
86 :     val tname = nativeSpec (mkpath name)
87 :     in
88 :     oneTarget (tname, tname, NONE, NONE, NONE, true)
89 :     end
90 :    
91 :     fun oneOpt (STRING x) = simpleTarget x
92 :     | oneOpt (SUBOPTS { name, opts }) = let
93 :     fun subopts [STRING x] = simpleTarget x
94 :     | subopts opts = let
95 :     val { matches, restoptions } =
96 :     parseOptions { tool = tool, keywords = kwl,
97 :     options = opts }
98 :     fun fmatch kw =
99 :     case matches kw of
100 :     NONE => misskw kw
101 :     | SOME [STRING { name, mkpath }] =>
102 :     nativeSpec (mkpath name)
103 :     | _ => badspec kw
104 :     fun smatch kw =
105 :     case matches kw of
106 :     NONE => NONE
107 :     | SOME [STRING { name, ... }] => SOME name
108 :     | _ => badspec kw
109 :     in
110 :     case restoptions of
111 :     [] => let
112 :     val tname = fmatch kw_name
113 :     val rname = getOpt (smatch kw_root, tname)
114 :     val tclass = smatch kw_class
115 :     val topts = matches kw_options
116 :     val lf = smatch kw_lineformat
117 :     val cpif =
118 :     case smatch kw_cpif of
119 :     NONE => true
120 :     | SOME s =>
121 :     (case Bool.fromString s of
122 :     SOME x => x
123 :     | NONE => badspec kw_cpif)
124 :     in
125 :     oneTarget (tname, rname, tclass, topts,
126 :     lf, cpif)
127 :     end
128 :     | _ => err "unrecognized target option(s)"
129 :     end
130 :     in
131 :     if name = kw_target then subopts opts
132 :     else badkw name
133 :     end
134 :     fun rulefn () =
135 : blume 642 ({ cmfiles = [], smlfiles = [],
136 :     sources = [(p, { class = class, derived = derived })] },
137 : blume 634 case too of
138 :     SOME opts => map oneOpt opts
139 :     | NONE => let
140 :     val { base, ext } = OS.Path.splitBaseExt sname
141 :     val base =
142 :     case ext of
143 :     NONE => base
144 :     | SOME e => if e = "nw" then base else sname
145 :     fun exp e = let
146 :     val tname = OS.Path.joinBaseExt { base = base,
147 :     ext = SOME e }
148 :     in
149 :     oneTarget (tname, tname, NONE, NONE, NONE, true)
150 :     end
151 :     in
152 :     [exp "sig", exp "sml"]
153 :     end)
154 :     in
155 :     context rulefn
156 :     end
157 : blume 642 fun sfx s =
158 :     registerClassifier (stdSfxClassifier { sfx = s, class = class })
159 : blume 634 in
160 :     val _ = registerClass (class, rule)
161 : blume 642 val _ = sfx "nw"
162 : blume 634 fun lineNumbering class = let
163 :     fun get () = StringMap.find (!lnr, class)
164 :     fun set NONE =
165 :     ((lnr := #1 (StringMap.remove (!lnr, class)))
166 :     handle LibBase.NotFound => ())
167 :     | set (SOME f) = lnr := StringMap.insert (!lnr, class, f)
168 :     in
169 :     { get = get, set = set }
170 :     end
171 :     end
172 :     end

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