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

Parent Directory | Revision Log

---

Revision 2 - (view) (download)
Original Path: sml/trunk/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