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 /ml-burg/trunk/burg.sml
ViewVC logotype

Annotation of /ml-burg/trunk/burg.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 250 - (view) (download)
Original Path: sml/trunk/src/ml-burg/burg.sml

1 : monnier 249 (* burg.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     * $Log$
6 :     * Revision 1.1.1.8 1999/04/17 18:56:04 monnier
7 :     * version 110.16
8 :     *
9 :     * Revision 1.2 1997/10/28 15:02:45 george
10 :     * Made compatible with new basis
11 :     *
12 :     # Revision 1.1.1.1 1997/01/14 01:37:59 george
13 :     # Version 109.24
14 :     #
15 :     * Revision 1.1.1.2 1997/01/11 18:52:29 george
16 :     * ml-burg Version 109.24
17 :     *
18 :     * Revision 1.3 1996/06/03 17:48:15 jhr
19 :     * Changes to bring ML-Burg upto new SML/NJ library.
20 :     *
21 :     * Revision 1.2 1996/02/26 15:02:05 george
22 :     * print no longer overloaded.
23 :     * use of makestring has been removed and replaced with Int.toString ..
24 :     * use of IO replaced with TextIO
25 :     *
26 :     * Revision 1.1.1.1 1996/01/31 16:01:24 george
27 :     * Version 109
28 :     *
29 :     *)
30 :    
31 :    
32 :     signature BURGEMIT = sig
33 :     exception BurgError
34 :     val emit : TextIO.instream * (unit -> TextIO.outstream) -> unit
35 :     end
36 :    
37 :    
38 :    
39 :     structure BurgEmit : BURGEMIT =
40 :     struct
41 :    
42 :     structure HashStringKey : HASH_KEY = struct
43 :     type hash_key = string
44 :     val hashVal = HashString.hashString
45 :     val sameKey = (op =) : string * string -> bool
46 :     end
47 :     structure BurgHash = HashTableFn (HashStringKey)
48 :     exception NotThere; (* raised by BurgHash.find *)
49 :    
50 :     exception BurgError (* for error reporting *)
51 :    
52 :     val inf = 16383
53 :    
54 :     open BurgAST
55 :    
56 :     (* debugging *)
57 :     fun debug s = (TextIO.output (TextIO.stdErr, s);
58 :     TextIO.flushOut TextIO.stdErr)
59 :    
60 :    
61 :     (* Output functions *)
62 :     val s_out = ref TextIO.stdOut (* changed into the output stream *)
63 :     fun say s = TextIO.output (!s_out, s)
64 :     fun saynl s = say (s^"\n")
65 :     fun sayi s = say ("\t"^s)
66 :     fun sayinl s = say ("\t"^s^"\n")
67 :    
68 :    
69 :     fun arrayapp (function, array) =
70 :     let
71 :     val len = Array.length array
72 :     fun loop pos =
73 :     if pos=len then ()
74 :     else
75 :     (function (Array.sub (array, pos)); loop (pos+1))
76 :     in
77 :     loop 0
78 :     end
79 :    
80 :     fun arrayiter (function, array) =
81 :     let
82 :     val len = Array.length array
83 :     fun loop pos =
84 :     if pos=len then ()
85 :     else
86 :     (function (pos, Array.sub (array, pos)); loop (pos+1))
87 :     in
88 :     loop 0
89 :     end
90 :    
91 :     fun iter (function, n) =
92 :     let
93 :     fun loop pos =
94 :     if pos=n then () else (function pos; loop (pos+1))
95 :     in
96 :     loop 0
97 :     end
98 :    
99 :     fun listiter (function, lis) =
100 :     let
101 :     fun loop (pos, li) =
102 :     case li of
103 :     [] => ()
104 :     | (l::ll) => (function (pos, l); loop ((pos+1), ll))
105 :     in
106 :     loop (0, lis)
107 :     end
108 :    
109 :     exception NotSameSize
110 :    
111 :     fun exists2 (function, list1, list2) =
112 :     let
113 :     exception Found
114 :     fun loop ([],[]) = ()
115 :     | loop (e1::l1,e2::l2) =
116 :     if function (e1,e2) then raise Found else loop (l1,l2)
117 :     | loop _ = raise NotSameSize
118 :     in
119 :     (loop (list1,list2); false) handle Found => true
120 :     end
121 :    
122 :     fun forall2 (f,l1,l2) = not (exists2 (not o f, l1, l2))
123 :    
124 :     fun map2 (function, list1, list2) =
125 :     let
126 :     fun loop ([],[],acc) = rev acc
127 :     | loop (e1::l1,e2::l2,acc) = loop (l1,l2,(function(e1,e2))::acc)
128 :     | loop _ = raise NotSameSize
129 :     in
130 :     loop (list1,list2,[])
131 :     end
132 :    
133 :     fun tofirstupper s = (case String.explode s
134 :     of [] => ""
135 :     | (c::r) => implode(Char.toUpper c :: (map Char.toLower r))
136 :     (* end case *))
137 :    
138 :     fun emit (s_in, oustreamgen) =
139 :     let
140 :    
141 :     (*
142 :     * Error reporting
143 :     *)
144 :     val error_encountered = ref false
145 :     fun warning s = (error_encountered := true;
146 :     TextIO.output (TextIO.stdErr, "Error: "^s^"\n");
147 :     TextIO.flushOut TextIO.stdErr)
148 :     fun error s = (TextIO.output (TextIO.stdErr, "Error: "^s^"\n");
149 :     TextIO.flushOut TextIO.stdErr;
150 :     raise BurgError)
151 :     fun stop_if_error () = if !error_encountered then raise BurgError else ()
152 :    
153 :     (*
154 :     * ids (for hashing) :
155 :     * TERMINAL (internal terminal number, external terminal string/number)
156 :     * NONTERMINAL (internal nonterminal number)
157 :     *)
158 :     datatype ids = TERMINAL of int * string
159 :     | NONTERMINAL of int
160 :    
161 :     (* hash table type *)
162 :     type htt = ids BurgHash.hash_table
163 :    
164 :     (*
165 :     * rule_pat :
166 :     * NT (nonterminal)
167 :     * T (terminal, sons)
168 :     *)
169 :     datatype rule_pat = NT of int | T of int * rule_pat list
170 :    
171 :     (*
172 :     * rule
173 :     *)
174 :     type ern = string (* type for external rule name *)
175 :     type rule = {nt:int, pat:rule_pat, ern:ern, cost: int, num:int}
176 :    
177 :    
178 :    
179 :     (* hash table symbols *)
180 :     val HT = BurgHash.mkTable (60, NotThere) : htt
181 :    
182 :     (* hash table for rule names and the arity of the pattern *)
183 :     val HR = BurgHash.mkTable (60, NotThere)
184 :     : int BurgHash.hash_table
185 :    
186 :    
187 :     val start_sym = ref (NONE : string option) (* %start symbol *)
188 :     val start = ref 0 (* nonterminal where to start *)
189 :    
190 :    
191 :     val term_prefix = ref "" (* prefix for terminals *)
192 :     val rule_prefix = ref "" (* prefix for rules *)
193 :     val sig_name = ref "" (* BURM by default *)
194 :     val struct_name = ref "" (* Burm (first upper, rest lower) *)
195 :    
196 :     val nb_t = ref 0 (* current internal terminal number *)
197 :     val nb_nt = ref 0 (* current internal nonterminal number *)
198 :    
199 :     (* Return a new internal terminal number *)
200 :     fun gen_tnum () = !nb_t before (nb_t := !nb_t+1)
201 :    
202 :     (* Return a new internal nonterminal number *)
203 :     fun gen_ntnum () = !nb_nt before (nb_nt := !nb_nt+1)
204 :    
205 :    
206 :     (*
207 :     * Emit the header
208 :     *)
209 :     fun emit_header (SPEC {head, ...}) = app say head
210 :    
211 :    
212 :     (*
213 :     * Emit the tail
214 :     *)
215 :     fun emit_tail (SPEC {tail, ...}) = app say tail
216 :    
217 :    
218 :     (*
219 :     * Give each terminal an internal terminal number,
220 :     * and remember the external terminal number.
221 :     * Also, find start symbol.
222 :     *)
223 :     fun reparse_decls (SPEC {decls=decls, ...}) =
224 :     let
225 :     val t_prefix = ref (NONE : string option)
226 :     val r_prefix = ref (NONE : string option)
227 :     val s_name = ref (NONE : string option)
228 :    
229 :     fun newt (sym, etn') =
230 :     let
231 :     val etn = case etn' of
232 :     SOME str => str
233 :     | NONE => sym
234 :     in
235 :     case (BurgHash.find HT sym) : ids option of
236 :     NONE => BurgHash.insert HT (sym, TERMINAL (gen_tnum(), etn))
237 :     | SOME _ => warning ("term "^sym^" redefined")
238 :     end
239 :    
240 :     fun newdecl (START s) =
241 :     (case !start_sym of
242 :     NONE => start_sym := (SOME s)
243 :     | (SOME _) => warning "%start redefined")
244 :     | newdecl (TERM l) = app newt l
245 :     | newdecl (TERMPREFIX tp) =
246 :     (case (!t_prefix) of
247 :     NONE => t_prefix := (SOME tp)
248 :     | _ => warning "%termprefix redefined")
249 :     | newdecl (RULEPREFIX rp) =
250 :     (case (!r_prefix) of
251 :     NONE => r_prefix := (SOME rp)
252 :     | _ => warning "%ruleprefix redefined")
253 :     | newdecl (SIG s) =
254 :     (case (!s_name) of
255 :     NONE => s_name := (SOME s)
256 :     | _ => warning "%sig redefined")
257 :     in
258 :     app newdecl decls;
259 :     if !nb_t=0 then error "no terminals !" else ();
260 :     term_prefix :=
261 :     (case (!t_prefix) of
262 :     NONE => ""
263 :     | SOME tp => tp);
264 :     rule_prefix :=
265 :     (case (!r_prefix) of
266 :     NONE => ""
267 :     | SOME rp => rp);
268 :     sig_name :=
269 :     (case (!s_name) of
270 :     NONE => "BURM"
271 :     | SOME s => String.translate (String.str o Char.toUpper) s);
272 :     struct_name := tofirstupper (!sig_name)
273 :     end (* fun reparse_decls *)
274 :    
275 :    
276 :     fun get_id sym =
277 :     case (BurgHash.find HT sym) : ids option of
278 :     NONE => error ("symbol "^sym^" not declared")
279 :     | SOME id => id
280 :    
281 :    
282 :     (*
283 :     * Arrays that contain for each t or nt its external symbol.
284 :     *)
285 :     val sym_terminals = ref (Array.array (0,("","")))
286 :     val sym_nonterminals = ref (Array.array (0,""))
287 :    
288 :    
289 :     fun build_num_to_sym_arrays () =
290 :     let
291 :     fun store (sym, TERMINAL (t, etn)) =
292 :     Array.update (!sym_terminals, t, (sym, etn))
293 :     | store (sym, NONTERMINAL nt) =
294 :     Array.update (!sym_nonterminals, nt, sym)
295 :     in
296 :     sym_terminals := Array.array (!nb_t, ("",""));
297 :     sym_nonterminals := Array.array (!nb_nt, (""));
298 :     BurgHash.appi store HT
299 :     end
300 :    
301 :     fun get_ntsym nt = Array.sub (!sym_nonterminals, nt)
302 :     fun get_tsym t = #1 (Array.sub (!sym_terminals, t))
303 :    
304 :    
305 :     fun reparse_rules (SPEC {rules=spec_rules, ...}) =
306 :     let
307 :     (* Arity for terminals. *)
308 :     val t_arity = Array.array (!nb_t, NONE : int option)
309 :    
310 :     fun newnt (RULE (ntsym, _, _, _)) =
311 :     case (BurgHash.find HT ntsym) : ids option of
312 :     NONE => BurgHash.insert HT (ntsym, NONTERMINAL (gen_ntnum ()))
313 :     | SOME (TERMINAL _) =>
314 :     warning (ntsym^" redefined as a nonterminal")
315 :     | SOME (NONTERMINAL _) => ()
316 :    
317 :    
318 :     val rule_num = ref 0 (* first rule is rule 1 *)
319 :    
320 :     fun newrule (RULE (ntsym, pattern, ern, costlist)) =
321 :     let
322 :     val num = (rule_num := !rule_num+1; !rule_num)
323 :    
324 :     val nt =
325 :     case BurgHash.find HT ntsym of
326 :     SOME (NONTERMINAL nt) => nt
327 :     | _ => error "internal : get nt"
328 :    
329 :     val cost = case costlist of [] => 0 | (c::_) => c
330 :    
331 :     val pat =
332 :     let
333 :     fun makepat (PAT (sym, sons)) =
334 :     case get_id sym of
335 :     NONTERMINAL nt =>
336 :     (NT nt) before
337 :     (if (null sons) then () else
338 :     warning ("nonterminal "^sym^" is not a tree"))
339 :     | TERMINAL (t, _) =>
340 :     let
341 :     val len = List.length sons
342 :     in
343 :     case Array.sub (t_arity, t) of
344 :     NONE => Array.update (t_arity, t, SOME len)
345 :     | SOME len' => if len=len' then () else
346 :     warning ("bad arity for terminal "^sym);
347 :     T (t, map makepat sons)
348 :     end
349 :     in
350 :     makepat pattern
351 :     end (* val pat *)
352 :     val patarity =
353 :     let
354 :     fun cnt (NT _, n) = n+1
355 :     | cnt (T (_, pat), n) =
356 :     List.foldl cnt n pat
357 :     in
358 :     cnt (pat, 0)
359 :     end
360 :     in
361 :     case (BurgHash.find HR ern) of
362 :     NONE => BurgHash.insert HR (ern, patarity)
363 :     | SOME ar => if ar = patarity then () else
364 :     warning ("rulename "^ern^" is used with patterns of different arity");
365 :     {nt=nt, pat=pat, ern=ern, cost=cost, num=num}
366 :     end (* fun newrule *)
367 :    
368 :     val _ = app newnt spec_rules
369 :     val _ = stop_if_error ()
370 :     val _ = if !nb_nt=0 then error "no rules !" else ()
371 :     val rules = Array.fromList (map newrule spec_rules)
372 :     val _ = stop_if_error ()
373 :     val _ = build_num_to_sym_arrays ()
374 :     val arity = Array.tabulate (!nb_t, (* terminals numbers begin at 0 *)
375 :     fn i => case Array.sub (t_arity, i) of
376 :     NONE => 0 before
377 :     (warning ("terminal "^(get_tsym i)^" unused"))
378 :     | SOME len => len)
379 :     val _ = stop_if_error ()
380 :     in
381 :     (rules, arity)
382 :     end (* fun reparse_rules *)
383 :    
384 :    
385 :     fun print_intarray array =
386 :     let
387 :     fun printit (pos, n) =
388 :     (if pos>0 then say "," else ();
389 :     say (Int.toString n)
390 :     )
391 :     in
392 :     arrayiter (printit, array)
393 :     end
394 :    
395 :     (*
396 :     * Print a rule.
397 :     *)
398 :     fun print_rule ({nt, pat, ern, cost, ...} : rule) =
399 :     let
400 :     fun print_sons [] = ()
401 :     | print_sons [p] = print_pat p
402 :     | print_sons (p::pl) =
403 :     (print_pat p; say ","; print_sons pl)
404 :     and print_pat (NT nt) = say (get_ntsym nt)
405 :     | print_pat (T (t, sons)) =
406 :     (say (get_tsym t);
407 :     case (List.length sons) of
408 :     0 => ()
409 :     | len => (say "("; print_sons sons; say ")")
410 :     )
411 :     in
412 :     say ((get_ntsym nt)^":\t");
413 :     print_pat pat;
414 :     say ("\t= "^ern^" ("^(Int.toString cost)^");\n")
415 :     end
416 :    
417 :    
418 :     fun prep_rule_cons ({ern=ern, ...} : rule) = (!rule_prefix)^ern
419 :    
420 :    
421 :     fun prep_node_cons t =
422 :     let
423 :     val (sym, _) = Array.sub (!sym_terminals, t)
424 :     in
425 :     "N_"^sym
426 :     end
427 :    
428 :    
429 :     fun prep_term_cons t = (!term_prefix)^(#2 (Array.sub (!sym_terminals, t)))
430 :    
431 :    
432 :     (*
433 :     * rules_for_lhs : array with the rules for a given lhs nt
434 :     * chains_for_rhs : array with the chain rules for a given rhs nt
435 :     * rule_groups :
436 :     * (rl,ntl,str_for_match,uniqstr,iscst,iswot) list list array
437 :     * array of, for each terminal that begin a pattern
438 :     * list of, for each different "case of"
439 :     * list of, for each pattern in "case of"
440 :     * (rule list * ntl) list
441 :     * string for the match expression printing
442 :     * unique string for constant patterns
443 :     * is_cst (bool: is the pattern without nonterminals)
444 :     * is_wot (bool: is the pattern without terminals : A(x,y,z,t))
445 :     *)
446 :    
447 :     fun build_rules_tables (rules : rule array) =
448 :     let
449 :     val rules_for_lhs = Array.array (!nb_nt, []:rule list)
450 :     val chains_for_rhs = Array.array (!nb_nt, []:rule list)
451 :    
452 :     fun add_lhs_rhs (rule as {nt,pat,...} : rule) =
453 :     (Array.update (rules_for_lhs, nt,
454 :     rule::(Array.sub (rules_for_lhs, nt)));
455 :     case pat of
456 :     NT rhs => Array.update (chains_for_rhs, rhs,
457 :     rule::(Array.sub (chains_for_rhs, rhs)))
458 :     | _ => ()
459 :     )
460 :    
461 :    
462 :     fun findntl (rule as {pat,...} : rule) =
463 :     let
464 :     fun flat (NT nt, ntl) = nt::ntl
465 :     | flat (T (_,sons), ntl) = List.foldr flat ntl sons
466 :     in
467 :     (rule, flat (pat,[]))
468 :     end
469 :    
470 :    
471 :     local
472 :     exception NotSamePat;
473 :     fun samepattern (NT _, NT _) = true
474 :     | samepattern (T (t1,spat1), T (t2, spat2)) =
475 :     if t1=t2
476 :     then samepatternsons (spat1,spat2)
477 :     else raise NotSamePat
478 :     | samepattern _ = raise NotSamePat
479 :     and samepatternsons (l1,l2) =
480 :     if ((forall2 (fn (p1,p2) => samepattern (p1,p2), l1, l2))
481 :     handle NotSameSize => raise NotSamePat)
482 :     then true
483 :     else raise NotSamePat
484 :     in
485 :     fun samepat (p1,p2) =
486 :     samepattern (p1,p2) handle NotSamePat => false
487 :     end
488 :    
489 :     fun clustersamepat (zap as ({pat,...}:rule, _), rg) =
490 :     let
491 :     fun loop ([],_) = (pat,[zap])::rg
492 :     | loop ((e as (p,zapl))::rest, acc) =
493 :     if samepat (p,pat)
494 :     then acc@((p,zap::zapl)::rest) (* don't keep order *)
495 :     else loop (rest,e::acc)
496 :     in
497 :     loop (rg, [])
498 :     end
499 :    
500 :    
501 :     fun minmaxcostlhss (pat,zapl) =
502 :     let
503 :     fun min (({cost,...}:rule,_), b) = if cost<=b then cost else b
504 :     fun max (({cost,...}:rule,_), b) = if cost>=b then cost else b
505 :     val mincost = List.foldl min inf zapl
506 :     val maxcost = List.foldl max ~1 zapl
507 :     fun addlhs (({nt=lhs,...}:rule,_), lhss) =
508 :     let
509 :     fun loop ([],_) = lhs::lhss
510 :     | loop (e as (i::il), acc) =
511 :     if lhs=i then lhss
512 :     else if lhs<i then (rev acc)@(lhs::e)
513 :     else loop (il,i::acc)
514 :     in
515 :     loop (lhss, [])
516 :     end
517 :     val lhss = List.foldl addlhs [] zapl
518 :     in
519 :     (pat,zapl,mincost,maxcost,lhss)
520 :     end
521 :    
522 :    
523 :     (* zapl is (rule,ntl) list *)
524 :     fun clustersamentl (pat,zapl,min,max,lhss) =
525 :     let
526 :     fun scan ((r,ntl),clusters) =
527 :     let
528 :     fun loop ([],_) = ([r],ntl)::clusters
529 :     | loop ((e as (rl,ntl'))::rest, acc) =
530 :     if ntl=ntl'
531 :     then acc@((r::rl,ntl)::rest) (* don't keep order *)
532 :     else loop (rest,e::acc)
533 :     in
534 :     loop (clusters ,[])
535 :     end
536 :     val rlntll = List.foldl scan [] zapl
537 :     in
538 :     (* rlntll is (rule list,ntl) list *)
539 :     (pat,rlntll,min,max,lhss)
540 :     end
541 :    
542 :    
543 :    
544 :     datatype utype = NotUnif | NoMG | SameG | FirstMG | SecondMG
545 :    
546 :     local
547 :     exception Forced of utype
548 :     fun uniftype (NT _, NT _) = SameG
549 :     | uniftype (NT _, T _) = FirstMG
550 :     | uniftype (T _, NT _) = SecondMG
551 :     | uniftype (T (t1,spat1), T (t2,spat2)) =
552 :     if t1<>t2 then raise (Forced NotUnif) else
553 :     (let
554 :     val sonsg = map2 (uniftype, spat1, spat2)
555 :     fun addson (NotUnif,_) = raise (Forced NotUnif)
556 :     | addson (_,NotUnif) = raise (Forced NotUnif)
557 :     | addson (NoMG,_) = NoMG
558 :     | addson (_,NoMG) = NoMG
559 :     | addson (SameG,x) = x
560 :     | addson (x,SameG) = x
561 :     | addson (FirstMG, FirstMG) = FirstMG
562 :     | addson (SecondMG, SecondMG) = SecondMG
563 :     | addson _ = NoMG
564 :     in
565 :     List.foldl addson SameG sonsg
566 :     end
567 :     handle NotSameSize => error "bug : uniftype")
568 :     in
569 :     fun unify (p1,p2) = (uniftype (p1,p2)) handle (Forced x) => x
570 :     end
571 :    
572 :    
573 :     (* "matches" is a list. Each elem is a list of (pat,...)
574 :     * in increasing order of minimum cost for the rl, and with
575 :     * either non-unifiable patterns, or with a pattern more general
576 :     * than another -- but only if the more general one is second, and
577 :     * it has a strictly higher cost, and all lhs of rules in the more
578 :     * general pattern are also lhs of some rules in the less general
579 :     * one (that is, if the less general rule matches, we lose
580 :     * nothing in not seeing the more general one).
581 :     * That's all.
582 :     *)
583 :     fun clustermatches (elem as (pat,_,mincost,maxcost,lhss),
584 :     matches) =
585 :     let
586 :     (* works on already (increasing,unique) ordered lists *)
587 :     fun subset ([],_) = true
588 :     | subset (_,[]) = false
589 :     | subset (a1 as (e1::l1),e2::l2) =
590 :     if e1=e2 then subset (l1,l2)
591 :     else if e1>(e2:int) then subset (a1,l2)
592 :     else false
593 :     datatype sowhat = ANOTHER | NOTU | AFTER | BEFORE of int
594 :     fun loop (prev, i, []) = prev
595 :     | loop (prev, i, (p,_,min,max,lh)::rest) =
596 :     case unify (pat,p) of
597 :     NotUnif => loop (prev,i+1,rest)
598 :     | NoMG => ANOTHER
599 :     | SameG => error "bug : clustermatches.SameG"
600 :     | FirstMG =>
601 :     if mincost>(max:int) andalso subset (lhss,lh)
602 :     then
603 :     case prev of
604 :     NOTU => loop (AFTER,i+1,rest)
605 :     | AFTER => loop (AFTER,i+1,rest)
606 :     | BEFORE k => ANOTHER
607 :     | _ => error "bug : clustermatches.FirstMG"
608 :     else ANOTHER
609 :     | SecondMG =>
610 :     if min>(maxcost:int) andalso subset (lh,lhss)
611 :     then
612 :     case prev of
613 :     NOTU => loop (BEFORE i,i+1,rest)
614 :     | AFTER => loop (BEFORE i,i+1,rest)
615 :     | BEFORE k => ANOTHER
616 :     | _ => error "bug : clustermatches.SecondMG"
617 :     else ANOTHER
618 :     fun insertat (0,prev,next,e) = (rev prev)@(e::next)
619 :     | insertat (n,prev,x::next,e) = insertat (n-1,x::prev,next,e)
620 :     | insertat (_,prev,[],e) = rev (e::prev)
621 :     fun try ([],_) = [elem]::matches
622 :     | try (l::ll,acc) =
623 :     case loop (NOTU,0,l) of
624 :     ANOTHER => try (ll,l::acc)
625 :     | NOTU => acc@((elem::l)::ll) (* don't keep order *)
626 :     | AFTER => acc@((l@[elem])::ll)
627 :     | BEFORE i => acc@((insertat (i,[],l,elem))::ll)
628 :     in
629 :     try (matches,[])
630 :     end
631 :    
632 :    
633 :     val uniq_cnt = ref 0
634 :    
635 :     fun compute (pat, rlntll, _, _, _) =
636 :     let
637 :     fun do_pat (NT nt, cnt, iswot) =
638 :     let val s = Int.toString cnt in
639 :     ("(s"^s^"_c,s"^s^"_r,_,_)", cnt+1, iswot)
640 :     end
641 :     | do_pat (T (t,sons), cnt, _) =
642 :     let
643 :     val (s,cnt',_) = do_sons (sons, cnt)
644 :     in
645 :     ("(_,_,"^(prep_node_cons t)
646 :     ^(if null sons then "" else
647 :     if null (tl sons) then s else
648 :     "("^s^")")
649 :     ^",_)"
650 :     , cnt', false)
651 :     end
652 :     and do_sons (sons,cnt) =
653 :     let
654 :     val (s,cnt,_,iswot) =
655 :     List.foldl (fn (pat,(s,cnt,first,iswot)) =>
656 :     let
657 :     val (s',cnt',iswot') =
658 :     do_pat (pat,cnt,iswot)
659 :     in
660 :     (if first then s' else s^","^s', cnt', false,
661 :     iswot')
662 :     end
663 :     ) ("",cnt,true,true) sons
664 :     in (s,cnt,iswot) end
665 :    
666 :     val (string_for_match, iscst, iswot) =
667 :     case pat of
668 :     T (_,sons) =>
669 :     let val (s,c,iswot) = do_sons (sons,0)
670 :     in (s,c=0,iswot) end
671 :     | NT _ => error "bug : string_for_match"
672 :     val uniqstr = Int.toString(!uniq_cnt) before (uniq_cnt := !uniq_cnt+1)
673 :    
674 :     in
675 :     (rlntll, string_for_match, uniqstr, iscst, iswot)
676 :     end
677 :    
678 :     val tgroup = Array.array (!nb_t, []:rule list)
679 :    
680 :     fun addt (rule as {pat,...} : rule) =
681 :     case pat of
682 :     T (t,_) => Array.update (tgroup, t, rule::(Array.sub (tgroup, t)))
683 :     | NT _ => ()
684 :     val _ = arrayapp (addt,rules)
685 :    
686 :     fun eacht t =
687 :     let
688 :     val v1 = Array.sub (tgroup, t)
689 :     (* v1 : rule list *)
690 :     val v2 = map findntl v1
691 :     (* v2 : (rule * ntl) list (= zap list) *)
692 :     val v3 = List.foldl clustersamepat [] v2
693 :     (* v3 : (pattern * zap list) list *)
694 :     val v4 = map minmaxcostlhss v3
695 :     (* v4 : (pattern * zap list * mincost * maxcost * lhss) list*)
696 :     val v5 = map clustersamentl v4
697 :     (* v5 : same thing with (rule list * ntl) list (= rlntll)
698 :     instead of zap list *)
699 :     val v6 = List.foldl clustermatches [] v5
700 :     (* v6 : (pattern * rlntll * min * max * lhss) list list *)
701 :     in
702 :     (* now, inside each subgroup, compute the elements *)
703 :     map (map compute) v6
704 :     (* : (rlntll*str_for_match*uniqstr*iscst*iswot) list list *)
705 :     end
706 :    
707 :     val rule_groups = Array.tabulate (!nb_t, eacht)
708 :     in
709 :     arrayapp (add_lhs_rhs, rules);
710 :     (rules_for_lhs, chains_for_rhs, rule_groups)
711 :     end
712 :    
713 :    
714 :     (*
715 :     * Check that each nonterminal is reachable from start.
716 :     *)
717 :     fun check_reachable (start, rules_for_lhs : rule list array) =
718 :     let
719 :     val notseen = Array.array (!nb_nt, true)
720 :     fun explore_nt nt =
721 :     (Array.update (notseen, nt, false);
722 :     app (fn ({pat,...}:rule) => reach pat)
723 :     (Array.sub (rules_for_lhs, nt))
724 :     )
725 :     and reach (NT nt) =
726 :     if Array.sub (notseen, nt) then explore_nt nt else ()
727 :     | reach (T (t, sons)) = app reach sons
728 :     fun test (nt, b) =
729 :     if b then
730 :     warning ("nonterminal "^(get_ntsym nt)^" is unreachable")
731 :     else ()
732 :     in
733 :     explore_nt start;
734 :     arrayiter (test, notseen);
735 :     stop_if_error ()
736 :     end
737 :    
738 :    
739 :     (**
740 :     ** Emit the code
741 :     **)
742 :    
743 :     fun emit_type_rule rules =
744 :     let
745 :     (* I just want a map, really, not a hashtable. *)
746 :     val H = BurgHash.mkTable (32, NotThere) : unit BurgHash.hash_table
747 :     val first = ref true
748 :     fun onerule (rule as {ern=ern, ...} : rule) =
749 :     let
750 :     val name = prep_rule_cons rule
751 :     in
752 :     case (BurgHash.find H name) of
753 :     NONE =>
754 :     let
755 :     val patarity =
756 :     case (BurgHash.find HR ern) of
757 :     NONE => error "emit_type_rule, no rule name ?"
758 :     | SOME ar => ar
759 :     fun pr 0 = ""
760 :     | pr 1 = " of (rule * tree)"
761 :     | pr n = ((pr (n-1))^" * (rule * tree)")
762 :     val constructor = name^(pr patarity)
763 :     in
764 :     BurgHash.insert H (name, ());
765 :     if !first then first := false else say "\t\t| ";
766 :     saynl constructor
767 :     end
768 :     | SOME _ => ()
769 :     end
770 :     in
771 :     say " datatype rule = ";
772 :     arrayapp (onerule, rules)
773 :     end
774 :    
775 :    
776 :    
777 :     fun emit_ruleToString rules = let
778 :     val H : unit BurgHash.hash_table = BurgHash.mkTable(32,NotThere)
779 :     val first = ref true
780 :     fun onerule (rule as {ern,...}:rule) = let
781 :     val name = prep_rule_cons rule
782 :     in
783 :     case (BurgHash.find H name)
784 :     of NONE => let
785 :     val patarity =
786 :     case BurgHash.find HR ern
787 :     of NONE => error "emit_ruleToString.onerule"
788 :     | SOME ar => ar
789 :     fun pr 0 = ""
790 :     | pr _ = " _"
791 :     val constructor = "("^ name ^ (pr patarity) ^ ")"
792 :     in
793 :     BurgHash.insert H (name,());
794 :     if !first then first:=false
795 :     else say " | ruleToString";
796 :     say constructor;
797 :     saynl (" = " ^ "\"" ^ name ^ "\"")
798 :     end
799 :     | SOME _ => ()
800 :     end
801 :     in
802 :     say " fun ruleToString ";
803 :     arrayapp (onerule,rules)
804 :     end
805 :    
806 :    
807 :    
808 :     fun emit_debug rules =
809 :     let
810 :     fun p_nterm (i, sym) =
811 :     saynl ("nonterm "^(Int.toString i)^" : "^sym)
812 :     fun p_rule (i, rule as {num, ...} : rule) =
813 :     (say ("rule "^(Int.toString num)^" : ");
814 :     print_rule rule
815 :     )
816 :     in
817 :     saynl "(***** debug info *****";
818 :     arrayiter (p_nterm, !sym_nonterminals);
819 :     say "\n";
820 :     arrayiter (p_rule, rules);
821 :     saynl "**********************)\n\n"
822 :     end
823 :    
824 :    
825 :     fun emit_struct_burmterm () =
826 :     let
827 :     fun loop t =
828 :     (if t=0 then () else say "\t | ";
829 :     saynl (prep_term_cons t)
830 :     )
831 :     in
832 :     saynl ("structure "^(!struct_name)^"Ops = struct");
833 :     say " datatype ops = ";
834 :     iter (loop, !nb_t);
835 :     saynl "end\n\n"
836 :     end
837 :    
838 :     fun emit_sig_burmgen () =
839 :     (saynl ("signature "^(!sig_name)^"_INPUT_SPEC = sig");
840 :     saynl " type tree";
841 :     saynl (" val opchildren : tree -> "^(!struct_name)
842 :     ^"Ops.ops * (tree list)");
843 :     saynl "end\n\n"
844 :     )
845 :    
846 :     fun emit_sig_burm rules =
847 :     (saynl ("signature "^(!sig_name)^" = sig");
848 :     saynl " exception NoMatch";
849 :     saynl " type tree";
850 :     emit_type_rule rules;
851 :     saynl " val reduce : tree -> rule * tree";
852 :     saynl " val ruleToString : rule -> string";
853 :     saynl "end\n\n"
854 :     )
855 :    
856 :     fun emit_beg_functor (rules, arity) =
857 :     let
858 :     fun loop_node t =
859 :     let
860 :     val ar = Array.sub (arity, t)
861 :     fun loop_sons i =
862 :     (say "s_tree";
863 :     if i=ar then () else
864 :     (say " * "; loop_sons (i+1))
865 :     )
866 :     in
867 :     say (if t=0 then " " else " | ");
868 :     say (prep_node_cons t);
869 :     if ar>0 then
870 :     (say "\t\tof ";
871 :     loop_sons 1
872 :     )
873 :     else ();
874 :     say "\n"
875 :     end
876 :     in
877 :     saynl ("functor "^(!struct_name)^"Gen (In : "
878 :     ^(!sig_name)^"_INPUT_SPEC) : "^(!sig_name)^" =");
879 :     saynl " struct\n";
880 :     saynl " type tree = In.tree\n";
881 :     saynl " exception NoMatch";
882 :     emit_type_rule rules;
883 :     say "\n\n";
884 :     emit_ruleToString rules; say "\n\n";
885 :     saynl " type s_cost = int Array.array";
886 :     saynl " type s_rule = int Array.array";
887 :     saynl " datatype s_node =";
888 :     iter (loop_node, !nb_t);
889 :     saynl " withtype s_tree = s_cost * s_rule * s_node * tree\n\n";
890 :     saynl " val sub = Array.sub";
891 :     saynl " val update = Array.update"
892 :     end
893 :    
894 :    
895 :     fun emit_val_cst (rules, arity, chains_for_rhs, rule_groups) =
896 :     let
897 :     fun do_cstrule (t, rlntll: (rule list * int list) list,
898 :     uniqstr, iscst) =
899 :     if iscst then
900 :     let
901 :     val ar = Array.sub (arity, t)
902 :     val a_cost = Array.array (!nb_nt, inf);
903 :     val a_rule = Array.array (!nb_nt, 0);
904 :    
905 :     fun record ({nt=lhs, cost, num, ...} : rule, c) =
906 :     let
907 :     val cc = c + cost
908 :     in
909 :     if cc < (Array.sub (a_cost, lhs)) then
910 :     (Array.update (a_cost, lhs, cc);
911 :     Array.update (a_rule, lhs, num);
912 :     app (fn rule => record (rule, cc))
913 :     (Array.sub (chains_for_rhs, lhs))
914 :     )
915 :     else ()
916 :     end
917 :     in
918 :     app ((app (fn rule => record (rule, 0))) o #1) rlntll;
919 :     if ar=0 then
920 :     (saynl (" val leaf_"^(prep_node_cons t)^" =");
921 :     say " (Array.fromList [";
922 :     print_intarray a_cost;
923 :     say "],\n Array.fromList [";
924 :     print_intarray a_rule;
925 :     saynl ("],\n "^(prep_node_cons t)^")")
926 :     )
927 :     else
928 :     (say (" val cst_cost_"^uniqstr^" = Array.fromList [");
929 :     print_intarray a_cost;
930 :     saynl "]";
931 :     say (" val cst_rule_"^uniqstr^" = Array.fromList [");
932 :     print_intarray a_rule;
933 :     saynl "]"
934 :     )
935 :     end
936 :     else ()
937 :    
938 :     fun do_cstrules (t, ll) =
939 :     app (app (fn (rlntll,_,uniqstr,iscst,_) =>
940 :     do_cstrule (t, rlntll, uniqstr, iscst))) ll
941 :     val n = Int.toString (!nb_nt)
942 :     val sinf = Int.toString inf
943 :     in
944 :     arrayiter (do_cstrules, rule_groups);
945 :     saynl (" val s_c_nothing = Array.array ("^n^","^sinf^")");
946 :     saynl (" val s_r_nothing = Array.array ("^n^",0)");
947 :     say "\n\n"
948 :     end
949 :    
950 :    
951 :     fun emit_label_function (rules, arity, chains_for_rhs, rule_groups) =
952 :     let
953 :     val firstcl = ref true
954 :     fun emit_closure (nt, rl : rule list) =
955 :     let
956 :     val firstrule = ref true
957 :     fun emit_cl ({nt=lhs, cost, num, ...} : rule) =
958 :     let
959 :     val c = Int.toString cost
960 :     val slhs = Int.toString lhs;
961 :     in
962 :     if !firstrule
963 :     then firstrule := false
964 :     else say ";\n\t ";
965 :     saynl ("if c + "^c^" < sub (s_c,"^slhs^") then");
966 :     sayinl (" (update (s_c,"^slhs^",c + "^c^");");
967 :     sayi (" update (s_r,"^slhs^","^(Int.toString num)
968 :     ^")");
969 :     if null (Array.sub (chains_for_rhs, lhs)) then () else
970 :     say (";\n\t closure_"^(get_ntsym lhs)
971 :     ^" (s_c, s_r, c + "^c^")");
972 :     saynl "\n\t )";
973 :     sayinl " else";
974 :     sayi " ()"
975 :     end
976 :     in
977 :     if null rl then () else
978 :     (if !firstcl then
979 :     (firstcl := false; say "\tfun") else say "\tand";
980 :     saynl (" closure_"^(get_ntsym nt)^" (s_c, s_r, c) =");
981 :     sayi " (";
982 :     List.app emit_cl rl;
983 :     saynl "\n\t )"
984 :     )
985 :     end
986 :    
987 :    
988 :     val nbnt = Int.toString (!nb_nt)
989 :     val sinf = Int.toString inf
990 :     val firstmatch = ref true
991 :    
992 :     fun emit_match t =
993 :     let (* "(" *)
994 :     val ar = Array.sub (arity, t)
995 :    
996 :     fun inlistofsons i = (say ("t"^(Int.toString i));
997 :     if i=(ar-1) then () else say ",")
998 :    
999 :     fun listofsons () =
1000 :     (say " ("; iter (inlistofsons, ar); say ")")
1001 :    
1002 :     val firstcst = ref true
1003 :     fun emit_match_cst (_,str,uniq,iscst,_) =
1004 :     if iscst then
1005 :     (if !firstcst
1006 :     then (say "\t "; firstcst := false)
1007 :     else say "\t | ";
1008 :     saynl ("("^str^") =>");
1009 :     sayinl ("\t (cst_cost_"^uniq^", cst_rule_"^uniq^")")
1010 :     )
1011 :     else ()
1012 :    
1013 :    
1014 :    
1015 :     val firstcase = ref true
1016 :     val firstcaseelem = ref true
1017 :     fun emit_match_case (rlntll,str,uniq,iscst,iswot) =
1018 :     if iscst then () else
1019 :     (if !firstcase then
1020 :     (firstcase := false;
1021 :     saynl "z =>";
1022 :     sayinl "\tlet";
1023 :     sayinl ("\t val s_c = Array.array ("
1024 :     ^nbnt^","^sinf^")");
1025 :     sayinl ("\t val s_r = Array.array ("
1026 :     ^nbnt^",0)");
1027 :     sayinl "\tin")
1028 :     else ();
1029 :     if !firstcaseelem then
1030 :     (firstcaseelem := false;
1031 :     sayinl "\tcase z of";
1032 :     sayi "\t ")
1033 :     else sayi "\t | ";
1034 :     saynl ("("^str^") =>");
1035 :     sayinl "\t (";
1036 :     let
1037 :     fun dorules (rl : rule list, ntl) =
1038 :     let
1039 :     fun dorule ({nt=lhs, num, cost, ...} : rule) =
1040 :     let
1041 :     val slhs = Int.toString lhs
1042 :     val c = Int.toString cost
1043 :     in
1044 :     sayinl ("\t\t if c + "^c^" < sub (s_c,"^slhs
1045 :     ^") then");
1046 :     sayinl ("\t\t (update (s_c, "^slhs
1047 :     ^", c + "^c^");");
1048 :     sayinl ("\t\t update (s_r, "^slhs
1049 :     ^", "^(Int.toString num)^");");
1050 :     if null (Array.sub (chains_for_rhs, lhs)) then ()
1051 :     else sayinl ("\t\t closure_"
1052 :     ^(get_ntsym lhs)
1053 :     ^" (s_c, s_r, c + "^c^");");
1054 :     sayinl "\t\t ())";
1055 :     sayinl "\t\t else ();"
1056 :     end
1057 :     in
1058 :     sayi "\t if ";
1059 :     listiter ((fn (i, nt) =>
1060 :     (if i=0 then () else say "andalso ";
1061 :     say ("sub (s"^(Int.toString i)^"_r,"
1062 :     ^(Int.toString (nt:int))
1063 :     ^")<>0 "))),
1064 :     ntl);
1065 :     saynl "then";
1066 :     sayinl "\t\t let";
1067 :     sayi ("\t\t val c = ");
1068 :     listiter ((fn (i, nt) =>
1069 :     (if i=0 then () else say " + ";
1070 :     say ("sub (s"^(Int.toString i)^"_c,"
1071 :     ^(Int.toString (nt:int))^")"))),
1072 :     ntl);
1073 :     saynl "\n\t\t\t in";
1074 :     app dorule rl;
1075 :     sayinl "\t\t ()";
1076 :     sayinl "\t\t end";
1077 :     sayinl "\t else ();"
1078 :     end
1079 :     in
1080 :     app dorules rlntll
1081 :     end;
1082 :     sayinl "\t ()";
1083 :     sayinl "\t )"
1084 :     ) (* fun emit_match_case *)
1085 :    
1086 :     in (* ")(" fun emit_match *)
1087 :    
1088 :     if !firstmatch
1089 :     then (sayi " "; firstmatch := false)
1090 :     else sayi "| ";
1091 :     say ((!struct_name)^"Ops.");
1092 :     saynl ((prep_term_cons t)^" =>");
1093 :    
1094 :     if ar=0 then (* leaf term *)
1095 :     if null (Array.sub (rule_groups, t))
1096 :     then sayinl (" (s_c_nothing, s_r_nothing, "
1097 :     ^(prep_node_cons t)^")")
1098 :     else sayinl (" leaf_"^(prep_node_cons t))
1099 :     else (* ar<>0 *)
1100 :     let
1101 :     val group = Array.sub (rule_groups, t)
1102 :     fun dosamecase eleml =
1103 :     (firstcaseelem := true;
1104 :     app emit_match_case eleml;
1105 :     if (not (!firstcaseelem) andalso
1106 :     not (List.exists (fn (_,_,_,_,iswot) => iswot) eleml))
1107 :     then sayinl "\t | _ => ()" else ();
1108 :     if (not (!firstcaseelem)) then sayinl "\t ;" else ()
1109 :     )
1110 :     in
1111 :     sayinl " let";
1112 :     sayi " val [";
1113 :     iter (inlistofsons, ar);
1114 :     saynl "] = map rec_label children";
1115 :     sayinl " in";
1116 :     if null group then (* transfert rule *)
1117 :     (sayi " (s_c_nothing, s_r_nothing, ";
1118 :     say (prep_node_cons t);
1119 :     listofsons ();
1120 :     saynl ")"
1121 :     )
1122 :     else
1123 :     (sayi " let val (s_c, s_r) = case";
1124 :     listofsons ();
1125 :     saynl " of";
1126 :     app (app emit_match_cst) group;
1127 :     sayi (if !firstcst then "\t " else "\t | ");
1128 :     app dosamecase group;
1129 :     if !firstcase then
1130 :     saynl "_ => (s_c_nothing, s_r_nothing)"
1131 :     else
1132 :     (sayinl "\t (s_c, s_r)";
1133 :     sayinl "\tend"
1134 :     );
1135 :     sayi " in (s_c, s_r, ";
1136 :     say (prep_node_cons t);
1137 :     listofsons ();
1138 :     saynl ") end"
1139 :     );
1140 :     sayinl " end"
1141 :     end
1142 :    
1143 :     end (* ")" fun emit_match *)
1144 :    
1145 :    
1146 :     in
1147 :     saynl " fun rec_label (tree : In.tree) =";
1148 :     saynl " let";
1149 :     arrayiter (emit_closure, chains_for_rhs);
1150 :     sayinl "val (term, children) = In.opchildren tree";
1151 :     sayinl "val (s_c, s_r, t) = case term of";
1152 :     iter (emit_match, !nb_t);
1153 :     saynl " in";
1154 :     saynl " (s_c, s_r, t, tree)";
1155 :     saynl " end\n"
1156 :     end
1157 :    
1158 :    
1159 :     fun emit_reduce_function (rules) =
1160 :     let
1161 :     val firstmatch = ref true
1162 :    
1163 :     fun domatch (rule as {num, pat, ...} : rule) =
1164 :     let
1165 :     fun flatsons (the_sons, cnt, ntl) =
1166 :     List.foldl
1167 :     (fn (patson, (b, c, l, ss)) =>
1168 :     let
1169 :     val (c', l', ss') = flat (patson, c, l)
1170 :     in
1171 :     (false, c', l', (if b then ss' else ss^","^ss'))
1172 :     end)
1173 :     (true, cnt, ntl, "")
1174 :     the_sons
1175 :     and flat (pat, cnt, ntl) =
1176 :     case pat of
1177 :     NT nt => (cnt+1, nt::ntl, "t"^(Int.toString cnt))
1178 :     | T (t, sons) =>
1179 :     let
1180 :     val len = List.length sons
1181 :     val (_, cnt', ntl', s') = flatsons (sons, cnt, ntl)
1182 :     val nexts =
1183 :     "(_,_,"^(prep_node_cons t)
1184 :     ^(if len=0 then "" else
1185 :     (if len=1 then " "^s' else " ("^s'^")"))
1186 :     ^",_)"
1187 :     in
1188 :     (cnt', ntl', nexts)
1189 :     end
1190 :    
1191 :     val (cnt, ntl, s) = flat (pat, 0, [])
1192 :     val ntl = rev ntl
1193 :     in
1194 :     if !firstmatch then (firstmatch := false; say "\t\t(") else
1195 :     say "\t | (";
1196 :     saynl ((Int.toString num)^", "^s^") =>");
1197 :     sayi ("\t ("^(prep_rule_cons rule));
1198 :     case pat of
1199 :     NT nt => say (" (doreduce (t0,"^(Int.toString nt)^"))")
1200 :     | T (t, _) =>
1201 :     (case List.length ntl of
1202 :     0 => ()
1203 :     | _ =>
1204 :     (say " (";
1205 :     listiter ((fn (i,nt) =>
1206 :     (if i=0 then () else say ", ";
1207 :     say ("doreduce (t"^(Int.toString i)^","
1208 :     ^(Int.toString nt)^")"))),
1209 :     ntl);
1210 :     say ")")
1211 :     );
1212 :     saynl ")"
1213 :     end
1214 :     in
1215 :     saynl " fun doreduce (stree : s_tree, nt) =";
1216 :     saynl " let";
1217 :     sayinl "val (s_c, s_r, _, tree) = stree";
1218 :     sayinl "val cost = sub (s_c, nt)";
1219 :     saynl " in";
1220 :    
1221 :     sayinl ("if cost="^(Int.toString inf)^" then");
1222 :     sayinl (" (print (\"No Match on nonterminal \"^(Int.toString nt)^\"\\n\");");
1223 :     sayinl (" print \"Possibilities were :\\n\";");
1224 :     sayinl (" let");
1225 :     sayinl (" fun loop n =");
1226 :     sayinl (" let");
1227 :     sayinl (" val c = Array.sub (s_c, n);");
1228 :     sayinl (" val r = Array.sub (s_r, n);");
1229 :     sayinl (" in");
1230 :     sayinl (" if c=16383 then () else");
1231 :     sayinl (" print (\"rule \"^(Int.toString r)^\" with cost \"");
1232 :     sayinl (" ^(Int.toString c)^\"\\n\");");
1233 :     sayinl (" loop (n+1)");
1234 :     sayinl (" end");
1235 :     sayinl (" in");
1236 :     sayinl (" (loop 0) handle General.Subscript => ()");
1237 :     sayinl (" end;");
1238 :     sayinl (" raise NoMatch)");
1239 :     sayinl ("else");
1240 :    
1241 :    
1242 :     sayinl " let";
1243 :     sayinl " val rulensons =";
1244 :     sayinl " case (sub (s_r, nt), stree) of";
1245 :     arrayapp (domatch, rules);
1246 :     sayinl " | _ => raise NoMatch (* bug in iburg *)";
1247 :     sayinl " in";
1248 :     sayinl " (rulensons, tree)";
1249 :     sayinl " end";
1250 :     saynl " end\n"
1251 :     end
1252 :    
1253 :    
1254 :     fun emit_end_functor (start : int) =
1255 :     (saynl " fun reduce (tree) =";
1256 :     saynl (" doreduce (rec_label (tree), "^(Int.toString start)^")");
1257 :     saynl " end\n\n"
1258 :     )
1259 :    
1260 :     in
1261 :     let
1262 :     val spec = #1 (Parse.parse s_in) before TextIO.closeIn s_in
1263 :     val _ = reparse_decls spec
1264 :     val (rules, arity) = reparse_rules spec
1265 :     val start =
1266 :     case !start_sym of
1267 :     NONE => 0
1268 :     | SOME sym =>
1269 :     case get_id sym of
1270 :     TERMINAL _ => error ("cannot start on a terminal")
1271 :     | NONTERMINAL n => n
1272 :     (* rule numbers for each nonterminal (array) *)
1273 :     val (rules_for_lhs, chains_for_rhs, rule_groups)
1274 :     = build_rules_tables rules
1275 :     in
1276 :     check_reachable (start, rules_for_lhs);
1277 :     s_out := (oustreamgen ());
1278 :     emit_header (spec);
1279 :     emit_debug (rules);
1280 :     emit_struct_burmterm ();
1281 :     emit_sig_burmgen ();
1282 :     emit_sig_burm (rules);
1283 :     emit_beg_functor (rules, arity);
1284 :     emit_val_cst (rules, arity, chains_for_rhs, rule_groups);
1285 :     emit_label_function (rules, arity, chains_for_rhs, rule_groups);
1286 :     emit_reduce_function (rules);
1287 :     emit_end_functor (start);
1288 :     emit_tail (spec);
1289 :     TextIO.closeOut (!s_out)
1290 :     end
1291 :     end (* fun emit *)
1292 :    
1293 :     end
1294 :    

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