Annotation of /sml/branches/SMLNJ/src/ml-burg/burg.sml

Parent Directory | Revision Log

---

Revision 8 - (view) (download)

1 :	monnier	2	(* burg.sml
2 :			*
3 :			* COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :			*
5 :			* $Log$
6 :	monnier	8	* Revision 1.1.1.2 1998/01/18 01:00:04 monnier
7 :			* *** empty log message ***
8 :	monnier	2	*
9 :	monnier	8	* Revision 1.2 1997/10/28 15:02:45 george
10 :			* Made compatible with new basis
11 :			*
12 :	monnier	2	# 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 :	monnier	8	saynl " val sub = Array.sub";
891 :			saynl " val update = Array.update"
892 :	monnier	2	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