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

SCM Repository

[smlnj] Annotation of /sml/trunk/src/ml-burg/burg.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3 - (view) (download)
Original Path: sml/branches/SMLNJ/src/ml-burg/burg.sml

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

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