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 2114 - (view) (download)

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

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