![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to main.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / lib / twig|
Return to main.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / lib / twig |
1.1 root 1: (* May 1989, Jussi Rintanen, Helsinki University of Technology *)
2:
3: functor MAKEmain (structure Parser : PARSER
4: and Automata : AUTOMATA
5: sharing Automata.Parser = Parser)
6: : sig val main : string -> unit end =
7: struct
8:
9: open Parser Automata
10:
11: val int2str : int -> string = makestring
12:
13: val accum = revfold
14:
15: fun count (a,nil) = 0
16: | count (a,h::t) = (if a = h then 1 else 0) + count (a,t)
17:
18: fun member p = (count p) <> 0
19:
20: (* Output *)
21:
22: fun labellist (Leaf (Label l)) = [l]
23: | labellist (Tree (_,cs)) = accum (fn (c,ac) => ac@(labellist c)) cs []
24: | labellist _ = []
25:
26: fun index (passed,nil) = []
27: | index (passed,h::t) =
28: (if member (h,passed) orelse member (h,t)
29: then h^(int2str (count (h,passed) + 1))
30: else h):: (index (h::passed,t))
31:
32: fun emitlist' (e,nil) = ()
33: | emitlist' (e,[a]) = e a
34: | emitlist' (e,h::t) = (e h;e",";emitlist' (e,t))
35:
36: fun emitlist (e,l) = (e"[";emitlist'(e,l);e"]")
37:
38: fun emitcost (emit, rules, defaultcost) =
39: (emit "fun execute_cost (n:rule, ir, children) =\nlet open User\n";
40: case defaultcost of
41: NoCost => ()
42: | Cost code => (emit "val DC = ( "; app emit code; emit ") (map cost children)\n");
43: emit "val ABORT = (fn () => raise MatchAbort)\n in\ncase n of\n ";
44: app (fn (Rule(n,_,_,p,Cost ss,_)) =>
45: (emit (int2str n);
46: emit " => (case map cost children of ";
47: emitlist (emit, index ([],labellist p));
48: emit " => (";
49: app emit ss;
50: emit ") | _ => raise InternalError \"S4\")\n | ")
51: | (Rule(n,_,_,_,NoCost,_)) => (emit (int2str n);emit" => DC\n | "))
52: rules;
53: emit "_ => raise InternalError \"S4.3.\"\nend\n\n")
54:
55: fun tokens (passed,h::t) =
56: let val suffix =
57: if member (h,passed) orelse member (h,t)
58: then (int2str (count (h,passed)+1))
59: else ""
60: in
61: ("_"^h^" "^h^suffix,
62: "execute (nth(children,"^(int2str (length passed))^"))"
63: )::(tokens (h::passed,t))
64: end
65: | tokens _ = []
66:
67: fun reftokens ls = tokens ([],ls)
68:
69: fun DOtokens (passed,h::t) =
70: let val suffix =
71: if member (h,passed) orelse member (h,t)
72: then (int2str (count (h,passed)+1))
73: else ""
74: in
75: ("DO"^h^suffix,
76: (* "let val C = nth(children,"^(int2str (length passed))^")in fn () => let val _"^h^" V = execute C in V end end" *)
77: "let val C = nth(children,"^(int2str (length passed))^")in fn () => case execute C of _"^h^" V => V | _ => raise InternalError \"S4.3\" end"
78: )::(DOtokens (h::passed,t))
79: end
80: | DOtokens _ = []
81:
82: fun DOreftokens ls = DOtokens ([],ls)
83:
84: fun emittuple'(e,nil) = ()
85: | emittuple'(e,[a]) = e a
86: | emittuple'(e,h::t) = (e h;e",";emittuple'(e,t))
87:
88: fun emittuple (e,t) = (e"(";emittuple'(e,t);e")")
89:
90: fun emitval (e,l) =
91: (emittuple (e,map (fn (_,a) => a) l);
92: e" of ";
93: emittuple (e,map (fn (a,_) => a) l))
94:
95: fun emitaction (emit, rules) =
96: (emit "fun execute (Skeleton (n,_, ir, children)) =\n\
97: \ let open User\n";
98: emit "in\ncase n of\n";
99: app (fn (Rule(n,t,Label l,p,_,Action ss)) =>
100: let val labels = labellist p
101: in
102: emit (int2str n);
103: emit " => ";
104: (case t of
105: Ordinary => emit ("_"^l)
106: | Topdown => emit ("_"^l)
107: | Rewrite => emit "__rewrite");
108: if labels <> nil
109: then (emit " ( case ";
110: (case t of
111: Ordinary =>
112: emitval (emit,reftokens (labellist p))
113: | Topdown =>
114: emitval (emit,DOreftokens (labellist p))
115: | Rewrite => emitval (emit,[("_","()")]));
116: emit " => ")
117: else ();
118: app emit ss;
119: if labels <> nil
120: then
121: case t of
122: Ordinary => emit " | _ => raise InternalError \"S5\" )"
123: | Topdown => emit" )"
124: | Rewrite => emit" )"
125: else ();
126: emit "\n | "
127: end | _ => ())
128: rules;
129: emit "_ => raise Match\n";
130: emit "end\n\n")
131:
132: fun emitrewrite (emit, rules) =
133: (emit "fun rewriterule (r:rule) =\n\
134: \ case r of\n";
135: app (fn (Rule(n,Rewrite,_,_,_,_)) =>
136: (emit (int2str n); emit " => true |") | _ => ())
137: rules;
138: emit "_ => false\n")
139:
140: (* Symbol datatype declaration *)
141:
142: fun symbol2str (Label s) = "__"^s
143: | symbol2str (Node (s,_)) = s
144:
145: fun emitsymbols (emit,symbols) =
146: let val maxarity =
147: accum
148: (fn (Node (_,a),max) => if a > max then a else max | (_,a) => a )
149: symbols 0
150: in
151: emit "ARC of int";
152: map
153: (fn s => emit (" | "^(symbol2str s)))
154: symbols;
155: emit "\n"
156: end
157:
158: (* Unit match trees *)
159:
160: fun leafs (Leaf _) = 1
161: | leafs (Tree(_,cs)) = fold (op +) (map leafs cs) 0
162:
163: fun emitmatches (_,nil) = ()
164: | emitmatches (emit, (Rule(n0,_,_,p,_,_)::rules)) =
165: (emit "val matchcounts = [\n";
166: let val n =
167: (emit ("(" ^ (int2str n0) ^ "," ^ (int2str (leafs p)) ^ ")");
168: accum
169: (fn (Rule(n,_,_,p,_,_),m) =>
170: (emit (",\n(" ^ (int2str n) ^ "," ^ (int2str (leafs p)) ^ ")");
171: if n > m then n else m))
172: rules n0)
173: in
174: emit "]\nval matchtable = let val a = array(";
175: emit (int2str (n+1));
176: emit ",0) in ((app (fn(r,m)=>update (a,r,m)) matchcounts); a) end\n\n\
177: \fun matches r = matchtable sub r\n\n"
178: end)
179:
180: (* Unit rules *)
181:
182: datatype matchtree = Chain of int * symbol * matchtree list
183:
184: fun closurize unitrules =
185: let val rec member =
186: (fn (a,nil) => false | (a,h::t) => if a=h then true else member (a,t))
187: val initials =
188: accum
189: (fn ((_,_,i),a) => if member (i,a) then a else i::a)
190: unitrules nil
191: fun build_unittree (nt,visited) =
192: accum (fn ((r,n,p),ac) =>
193: if p = nt andalso not (member (n,visited))
194: then Chain(r,n,build_unittree(n,n::visited))::ac
195: else ac) unitrules nil
196: in
197: map (fn i => (i,build_unittree (i,[i]))) initials
198: end
199:
200: fun emitmatchtreelist (emit,nil) = ()
201: | emitmatchtreelist (emit,[m]) = emitmatchtree (emit, m)
202: | emitmatchtreelist (emit,(h::t)) = (emitmatchtree (emit,h); emit ","; emitmatchtreelist (emit,t))
203: and emitmatchtree (emit, Chain (i, j, ml)) =
204: (emit "Chain (";
205: emit (int2str i);
206: emit ",";
207: emit (symbol2str j);
208: emit ",[";
209: emitmatchtreelist (emit,ml);
210: emit "])")
211:
212: fun emitunitrules (emit, matchtrees,symbols) =
213: (emit "datatype matchtree = Chain of int * symbol * matchtree list\n";
214: emit "fun unitmatches nt = (case nt of\n";
215: app (fn (s,ms) => (emit (symbol2str s);
216: emit " => [";
217: emitmatchtreelist (emit,ms);
218: emit "]\n | "))
219: matchtrees;
220: emit "_ => [])\n\n")
221:
222: fun partition' (nil,u,n) = (u,n)
223: | partition' (Rule(r,_,l,Leaf s,_,_)::t,u,n) = partition' (t,(r,l,s)::u,n)
224: | partition' (r::t,u,n) = partition' (t,u,r::n)
225:
226: fun partition l = partition' (l,nil,nil)
227:
228: (* Main *)
229:
230: fun fatal s = output std_out ("Fatal error: "^s^"\n")
231:
232: fun main inputfilename =
233: let
234: val outputfilename = inputfilename ^ ".sml"
235: val (inputf, outputf) = (open_in inputfilename,open_out outputfilename)
236: val emit = output outputf
237: val (inserts, rules, dcost, structuren, label_type, symbols) = specification inputf
238: val (unitrules, otherrules) = partition rules
239: in
240: emit "structure ";
241: emit structuren;
242: emit " =\n\
243: \struct\n\
244: \ structure User =\n\
245: \ struct\n\
246: \datatype symbol =\n";
247: emitsymbols (emit,symbols);
248: app (fn Prologue ss => (app emit ss) | Insert ss => (app emit ss)) inserts;
249: emit "\n\ndatatype result = __rewrite of tree | ";
250: emit label_type;
251: emit "\n end\n\n\
252: \structure Specification =\n\
253: \ struct\n\
254: \structure User = User\n\nopen User\n\
255: \type rule = int\n\
256: \datatype skeletal = Skeleton of (rule * cost * tree * skeletal list)\n\
257: \exception MatchAbort\n\
258: \fun cost (Skeleton(_,c,_,_)) = c\n\
259: \exception InternalError of string\n\n\
260: \fun get_subtree (n,t) = nth (get_subtrees t,n-1)\n\n";
261: emitcost (emit,rules,dcost);
262: emitaction (emit,rules);
263: emitmatches (emit, rules);
264: build_automaton (outputf,symbols,otherrules);
265: emitunitrules(emit, closurize unitrules,symbols);
266: emitrewrite (emit,rules);
267: emit "fun getreplacement (__rewrite t) = t | getreplacement _ = raise InternalError \"problem with rewrite 996\"\n\
268: \ end\n\
269: \structure Internal = MAKEtreeprocessor(Specification)\n\
270: \exception NoCover = Internal.NoCover\n\
271: \exception InternalError = Internal.InternalError\n\
272: \val translate = Internal.translate\n\
273: \end;\n";
274: close_in inputf;
275: close_out outputf
276: end
277: handle ParserError s => fatal s
278: | AutomatonError s => fatal s
279:
280: end;
281:
282: structure Parser = MAKEparser(structure Symboltable = Symboltable
283: and Lexer = Lexer);
284:
285: structure Main = MAKEmain(structure Parser = Parser
286: and Automata = MAKEautomata(structure Parser = Parser));
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.