![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to mlyacc.hdr.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / lib / mlyacc|
Return to mlyacc.hdr.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / lib / mlyacc |
1.1 root 1: (* ML-Yacc parser generator version 1.0
2: Copyright (c) 1989 by Andrew W. Appel, David R. Tarditi
3:
4: This software comes with ABSOLUTELY NO WARRANTY.
5: This software is subject only to the PRINCETON STANDARD ML SOFTWARE LIBRARY
6: COPYRIGHT NOTICE, LICENSE AND DISCLAIMER, (in the file "COPYRIGHT",
7: distributed with this software). You may copy and distribute this software;
8: see the COPYRIGHT NOTICE for details and restrictions.
9: *)
10: signature BASESET =
11: sig
12: type elem
13: type base_set
14: exception Select_arb
15: val empty: base_set
16: and insert: elem -> base_set -> base_set
17: and exists: elem -> base_set -> bool
18: and find: elem -> base_set -> elem option
19: and setfold: ((elem * 'b) -> 'b) -> base_set -> 'b -> 'b
20: and revsetfold: ((elem * 'b) -> 'b) -> base_set -> 'b -> 'b
21: and elem_gt: (elem * elem -> bool)
22: and elem_eq: (elem * elem -> bool)
23: and select_arb: base_set -> elem
24: and set_eq: (base_set * base_set) -> bool
25: and set_gt: (base_set * base_set) -> bool
26: and app : (elem -> 'a) -> base_set -> unit
27: end;
28:
29: signature FULLSET =
30: sig
31: type set
32: type elem
33: exception Select_arb
34: val card: set -> int
35: and app: (elem -> 'b) -> set -> unit
36: and set_eq: (set * set) -> bool
37: and set_gt: (set * set) -> bool
38: and find : elem -> set -> elem option
39: and exists: elem -> set -> bool
40: and contained: elem -> (set -> bool)
41: and difference: set * set -> set
42: and elem_eq: (elem * elem -> bool)
43: and elem_gt : (elem * elem -> bool)
44: and empty: set
45: and insert: elem -> set -> set
46: and is_empty: set -> bool
47: and make_list: set -> elem list
48: and make_set: (elem list -> set)
49: and remove: (elem * set) -> set
50: and same_set: set * set -> bool
51: and partition: (elem -> bool) -> (set -> set * set)
52: and revsetfold: ((elem * 'b) -> 'b) -> set -> 'b -> 'b
53: and setfold: ((elem * 'b) -> 'b) -> set -> 'b -> 'b
54: and select_arb: set -> elem
55: and singleton: (elem -> set)
56: and union: set * set -> set
57: and closure: set * (elem -> set) -> set
58: end;
59:
60: signature GRAPH =
61: sig
62:
63: type node
64: type edge
65: type graph
66:
67: val null_graph: graph
68: val nodes_of: graph -> node list
69: val num_nodes: graph -> int
70: val join: graph * node * edge * node -> graph
71:
72: (* drt(9/12/88) - new functions added because join is inefficient,
73: if one or both of the nodes already exist *)
74:
75: val add_edge : graph * node * edge * node -> graph
76: val add_node : graph * node -> graph
77:
78: (* set of graph edges: records of {From:node, Edge:edge, To:node} *)
79:
80:
81: structure EdgeSet : FULLSET
82:
83: val edges: graph * node -> EdgeSet.set (* all edges from a node *)
84: val all_edges : graph -> EdgeSet.set
85:
86: val find_node : graph * node -> node option
87:
88: end;
89:
90: signature BUSY =
91: sig
92: val dot: unit -> unit
93: val star: unit -> unit
94: val print: string -> unit
95: val println: string -> unit
96:
97: val withSpace: ('a -> unit) -> ('a -> unit)
98: val withNewline: ('a -> unit) -> ('a -> unit)
99:
100: val withDot: ('a -> 'b) -> 'a -> 'b
101:
102: val sendto_list : unit -> unit
103: val sendto_file : outstream -> unit
104:
105: val get_list : unit -> string list
106: end;
107:
108: signature MEMO =
109: sig
110: type Arg
111:
112: val memo_fn: ((Arg * Arg) -> bool) -> ((Arg -> '2a) -> (Arg -> '2a))
113:
114: exception Enum_memo_fn
115:
116: val enum_memo_fn: ((Arg -> int) * int) -> ((Arg -> '2a) -> (Arg -> '2a))
117:
118: exception Catalog
119:
120: val catalog: {tag: Arg -> 'tag,
121: ordOfTag: 'tag -> int,
122: items: Arg list
123: } -> ('tag -> Arg list)
124: end;
125: signature V2_LR_GRAMMAR =
126: sig
127: datatype Terminal = T of int
128: and Nonterminal = NT of int
129:
130: datatype Symbol = TERM of Terminal
131: | NONTERM of Nonterminal
132:
133: datatype Attribute = ATTRIB of {lhs: Nonterminal,
134: rhsLength: int,
135: num : int
136: }
137:
138: datatype Rule = RULE of {lhs: Nonterminal,
139: rhs: Symbol list,
140: attribute: Attribute,
141: precedence: int option
142: }
143:
144: val termHash: Terminal -> int
145: val nontermHash: Nonterminal -> int
146:
147: val eqTerminal: Terminal * Terminal -> bool
148: val eqNonterminal: Nonterminal * Nonterminal -> bool
149:
150: val gtTerminal: Terminal * Terminal -> bool
151: val gtNonterminal: Nonterminal * Nonterminal -> bool
152: end;
153: signature V2_LSET =
154: sig
155: structure G : V2_LR_GRAMMAR
156: type Lookahead
157: val emptylookahead : Lookahead
158:
159: (* Sets the bool ref to true if lookahead arg 1
160: set - lookahead arg 2 set <> null, i.e. if merging the 2 lookahead
161: sets adds something to lookahead arg 1 set
162: *)
163:
164: val mergelookahead : ((Lookahead * Lookahead) * bool ref) -> Lookahead
165:
166: (* returns true if any terminal in the terminal list is not in
167: was not already in the lookahead set
168: *)
169:
170: val addterms: Lookahead * G.Terminal list -> Lookahead
171: val makelookaheadlist : Lookahead -> G.Terminal list
172: end
173:
174: signature V2_LR_UTILS =
175: sig
176: structure G: V2_LR_GRAMMAR
177: structure CoreSet : FULLSET
178: structure Lset : V2_LSET
179:
180: datatype Core = CORE of { I : {coreLHS: G.Nonterminal,
181: corePrecedence: int option,
182: coreAttribute: G.Attribute},
183: coreRHSbefore: G.Symbol list,
184: coreRHSafter: G.Symbol list,
185: prop: bool ref,
186: lookaheads : Lset. Lookahead ref
187: }
188:
189: sharing type CoreSet.elem = Core
190:
191: val eqSymbol: G.Symbol * G.Symbol -> bool
192: val gtSymbol: G.Symbol * G.Symbol -> bool
193:
194: val eqCore: Core * Core -> bool
195: val gtCore: Core * Core -> bool
196:
197: val mkshowSymbol: {showTerminalClass : G.Terminal -> string,
198: showNonterminal : G.Nonterminal -> string } ->
199: G.Symbol -> string
200:
201: val printCore: {showSymbol : G.Symbol -> string,
202: showNonterminal : G.Nonterminal -> string,
203: showTerminalClass : G.Terminal -> string} -> Core -> unit
204: val printCoreSet: {printCore : Core -> unit} -> CoreSet.set -> unit
205:
206: val mkselectCores: {rules : G.Rule list,
207: numNonterminals : int }
208: -> G.Nonterminal -> CoreSet.set
209: val mkcoreClosure: {rules : G.Rule list,
210: numNonterminals : int,
211: selectCores : G.Nonterminal -> CoreSet.set
212: } -> CoreSet.set -> CoreSet.set
213:
214: val immediateSymbols: CoreSet.set -> G.Symbol list
215: val copyCoreSet : CoreSet.set -> CoreSet.set
216:
217: type true
218: val prop_f_to_c_a :
219: {first_string : G.Symbol list -> G.Terminal list,
220: selectCores : G.Nonterminal -> CoreSet.set} ->
221: (CoreSet.set -> unit)
222: val propagate_l_to_c_a :
223: {selectCores : G.Nonterminal -> CoreSet.set } ->
224: (CoreSet.set * bool ref) -> unit
225: val propagate_l_to_g_i : (Core -> Core) ->
226: (((CoreSet.set * G.Symbol * CoreSet.set) *
227: bool ref) -> unit)
228: val set_prop : (G.Symbol list -> bool) -> (CoreSet.set -> unit)
229: val hardwire_eof : (CoreSet.set * G.Terminal * G.Nonterminal) -> unit
230: end;
231:
232: signature V2_LR_GRAPH =
233: sig
234: structure G: V2_LR_GRAMMAR
235: structure Lr_Graph : GRAPH
236: val mkGraph : {rules : G.Rule list, verbose : bool,
237: eof : G.Terminal, start : G.Nonterminal,
238: termPrecedence : G.Terminal -> int option,
239: showTerminalClass : G.Terminal -> string,
240: showTerminalValue : G.Terminal -> string,
241: showNonterminal : G.Nonterminal -> string,
242: showAttribute : G.Attribute -> string,
243: numTerminals : int,
244: numNonterminals : int
245: } -> Lr_Graph.graph
246: end;
247:
248: signature V2_LOOKAHEAD =
249: sig
250: structure G: V2_LR_GRAMMAR
251: structure Utils : V2_LR_UTILS
252: val mkfunctions : {numNonterminals:int,
253: selectCores : G.Nonterminal -> Utils.CoreSet.set,
254: showNonterminal : G.Nonterminal -> string,
255: showTerminalClass : G.Terminal -> string
256: } -> {nullable_string : G.Symbol list -> bool,
257: first_string : G.Symbol list -> G.Terminal list}
258: end;
259: signature V2_LR_TABLE =
260: sig
261: structure G: V2_LR_GRAMMAR
262: val mktable :
263: outstream ->
264: {rules : G.Rule list, verbose : bool,
265: eof : G.Terminal, start : G.Nonterminal,
266: termPrecedence : G.Terminal -> int option,
267: showTerminalClass : G.Terminal -> string,
268: showTerminalValue : G.Terminal -> string,
269: showNonterminal : G.Nonterminal -> string,
270: showAttribute : G.Attribute -> string,
271: numTerminals : int,
272: numNonterminals : int
273: } -> unit
274: end;
275: structure Busy: BUSY =
276: struct
277: val len = ref 0
278: val file = ref std_out (* file to send output *)
279: val list = ref (nil : string list) (* or list to save output on *)
280: val to_file = ref true (* true = to file, false = to_list *)
281:
282: val sendto_list = fn () => (to_file := false; list := nil)
283: val sendto_file = fn f => (file := f; to_file := true)
284: val get_list = fn () => (!list)
285:
286: val dots = ref false
287:
288: val P = fn x => if (!to_file) then output (!file) x
289: else list := x :: (!list)
290:
291: fun sym s = (if !len = 75 then (P "\n"; len := 0) else ();
292: flush_out (!file);
293: P s;
294: len := !len + 1;
295: dots := true
296: )
297:
298: fun dot() = sym "."
299: fun star() = sym "*"
300:
301: fun print s = (if !dots then (P "\n"; len := 0) else ();
302: dots := false;
303: P s;
304: len := !len + size s
305: );
306:
307: fun println s = (print s; P "\n"; len := 0)
308:
309: fun withSpace pr = fn x => (pr x; print " ")
310: fun withNewline pr = fn x => (pr x; println " ")
311:
312: fun withDot f a = f a before dot()
313: end;
314:
315: functor Memo(type Arg): MEMO =
316: struct
317: type Arg = Arg
318: type 'a relation = 'a * 'a -> bool
319:
320: fun memo_fn (Eq: Arg relation) (F: Arg -> '2a) =
321: let val MemoSet = (ref nil): (Arg * '2a) list ref
322: fun MemoCall(Arg, (X, Y) :: XYRest, Eq) =
323: if Eq(Arg, X) then Y else MemoCall(Arg, XYRest, Eq) |
324: MemoCall(Arg, nil, _) =
325: let val Y = F(Arg)
326: in (MemoSet := (Arg, Y) :: !MemoSet; Y)
327: end
328:
329: in fn X => MemoCall(X, !MemoSet, Eq)
330: end
331:
332: exception Enum_memo_fn
333: fun enum_memo_fn (Enum: Arg -> int, Max: int) (F: Arg -> '2a) =
334: let val MemoArray = array(Max, NONE): '2a option array
335: in fn x =>
336: let val n = Enum(x)
337: in case MemoArray sub n of
338: NONE => let val y = F(x)
339: in update(MemoArray, n, SOME(y)); y
340: end |
341: SOME(y) => y
342: end
343: handle Subscript => raise Enum_memo_fn
344: end
345:
346: (* catalog: given a function Tag for getting the selector tag
347: from any object, bundle the objects to give an efficient selector
348: function *)
349:
350: exception Catalog
351: fun catalog{tag, ordOfTag, items}: ('tag -> Arg list) =
352: let val OrdOfThing = ordOfTag o tag
353:
354: fun MaxOrdOfTag(Item :: IRest, Result): int =
355: (Busy.dot();
356: let val ThisOrd = OrdOfThing(Item)
357: in if ThisOrd > Result then MaxOrdOfTag(IRest, ThisOrd)
358: else MaxOrdOfTag(IRest, Result)
359: end
360: ) |
361: MaxOrdOfTag(nil, Result) = Result
362:
363: val MaxOrdOfTags =
364: (Busy.print "MaxOrdOfTags"; MaxOrdOfTag(items, 0))
365:
366: val TheCatalog =
367: array(MaxOrdOfTags + 1, NONE): Arg list option array
368:
369: fun InsertItem(Item) =
370: let val ord = OrdOfThing(Item)
371: in (case TheCatalog sub ord of
372: SOME(L) =>
373: update(TheCatalog, ord, SOME(Item :: L)) |
374:
375: NONE =>
376: update(TheCatalog, ord, SOME [Item])
377: ) before Busy.dot()
378: end
379:
380: val _ = (Busy.print "catalog"; map InsertItem items)
381:
382: in fn Tag => (case TheCatalog sub ordOfTag(Tag) of
383: SOME(L) => L |
384: NONE => raise Catalog
385: ) handle Subscript => raise Catalog
386: end
387: end;
388:
389: functor BaseSet(B : sig type elem
390: val gt : elem * elem -> bool
391: val eq : elem * elem -> bool
392: end ) : BASESET =
393:
394: struct
395:
396: type elem = B.elem
397: val elem_gt = B.gt
398: val elem_eq = B.eq
399:
400: datatype Color = RED | BLACK
401:
402: datatype base_set = EMPTY | TREE of (B.elem * Color * base_set * base_set)
403: exception Select_arb
404: val empty = EMPTY
405:
406: fun insert key t =
407: let fun f EMPTY = TREE(key,RED,EMPTY,EMPTY)
408: | f (TREE(k,BLACK,l,r)) =
409: if elem_gt (key,k)
410: then case f r
411: of r as TREE(rk,RED, rl as TREE(rlk,RED,rll,rlr),rr) =>
412: (case l
413: of TREE(lk,RED,ll,lr) =>
414: TREE(k,RED,TREE(lk,BLACK,ll,lr),
415: TREE(rk,BLACK,rl,rr))
416: | _ => TREE(rlk,BLACK,TREE(k,RED,l,rll),
417: TREE(rk,RED,rlr,rr)))
418: | r as TREE(rk,RED,rl, rr as TREE(rrk,RED,rrl,rrr)) =>
419: (case l
420: of TREE(lk,RED,ll,lr) =>
421: TREE(k,RED,TREE(lk,BLACK,ll,lr),
422: TREE(rk,BLACK,rl,rr))
423: | _ => TREE(rk,BLACK,TREE(k,RED,l,rl),rr))
424: | r => TREE(k,BLACK,l,r)
425: else if elem_gt(k,key)
426: then case f l
427: of l as TREE(lk,RED,ll, lr as TREE(lrk,RED,lrl,lrr)) =>
428: (case r
429: of TREE(rk,RED,rl,rr) =>
430: TREE(k,RED,TREE(lk,BLACK,ll,lr),
431: TREE(rk,BLACK,rl,rr))
432: | _ => TREE(lrk,BLACK,TREE(lk,RED,ll,lrl),
433: TREE(k,RED,lrr,r)))
434: | l as TREE(lk,RED, ll as TREE(llk,RED,lll,llr), lr) =>
435: (case r
436: of TREE(rk,RED,rl,rr) =>
437: TREE(k,RED,TREE(lk,BLACK,ll,lr),
438: TREE(rk,BLACK,rl,rr))
439: | _ => TREE(lk,BLACK,ll,TREE(k,RED,lr,r)))
440: | l => TREE(k,BLACK,l,r)
441: else TREE(key,BLACK,l,r)
442: | f (TREE(k,RED,l,r)) =
443: if elem_gt(key,k) then TREE(k,RED,l, f r)
444: else if elem_gt(k,key) then TREE(k,RED, f l, r)
445: else TREE(key,RED,l,r)
446: in case f t
447: of TREE(k,RED, l as TREE(_,RED,_,_), r) => TREE(k,BLACK,l,r)
448: | TREE(k,RED, l, r as TREE(_,RED,_,_)) => TREE(k,BLACK,l,r)
449: | t => t
450: end
451:
452: fun select_arb (TREE(k,_,l,r)) = k
453: | select_arb EMPTY = raise Select_arb
454:
455: fun exists key t =
456: let fun look EMPTY = false
457: | look (TREE(k,_,l,r)) =
458: if elem_gt(k,key) then look l
459: else if elem_gt(key,k) then look r
460: else true
461: in look t
462: end
463:
464: fun find key t =
465: let fun look EMPTY = NONE
466: | look (TREE(k,_,l,r)) =
467: if elem_gt(k,key) then look l
468: else if elem_gt(key,k) then look r
469: else SOME k
470: in look t
471: end
472:
473: fun revsetfold f t start =
474: let fun scan (EMPTY,value) = value
475: | scan (TREE(k,_,l,r),value) = scan(r,f(k,scan(l,value)))
476: in scan(t,start)
477: end
478:
479: fun setfold f t start =
480: let fun scan(EMPTY,value) = value
481: | scan(TREE(k,_,l,r),value) = scan(l,f(k,scan(r,value)))
482: in scan(t,start)
483: end
484:
485: fun app f t =
486: let fun scan EMPTY = ()
487: | scan(TREE(k,_,l,r)) = (scan l; f k; scan r)
488: in scan t
489: end
490:
491: (* equal_tree : test if two trees are equal. Two trees are equal if
492: the set of leaves are equal *)
493:
494: fun set_eq (tree1 as (TREE _),tree2 as (TREE _)) =
495: let datatype pos = L | R | M
496: exception Done
497: fun getvalue(stack as ((a,position)::b)) =
498: (case a
499: of (TREE(k,_,l,r)) =>
500: (case position
501: of L => getvalue ((l,L)::(a,M)::b)
502: | M => (k,case r of EMPTY => b | _ => (a,R)::b)
503: | R => getvalue ((r,L)::b)
504: )
505: | EMPTY => getvalue b
506: )
507: | getvalue(nil) = raise Done
508: fun f (nil,nil) = true
509: | f (s1 as (_ :: _),s2 as (_ :: _ )) =
510: let val (v1,news1) = getvalue s1
511: and (v2,news2) = getvalue s2
512: in (elem_eq(v1,v2)) andalso f(news1,news2)
513: end
514: | f _ = false
515: in f ((tree1,L)::nil,(tree2,L)::nil) handle Done => false
516: end
517: | set_eq (EMPTY,EMPTY) = true
518: | set_eq _ = false
519:
520: (* gt_tree : Test if tree1 is greater than tree 2 *)
521:
522: fun set_gt (tree1,tree2) =
523: let datatype pos = L | R | M
524: exception Done
525: fun getvalue(stack as ((a,position)::b)) =
526: (case a
527: of (TREE(k,_,l,r)) =>
528: (case position
529: of L => getvalue ((l,L)::(a,M)::b)
530: | M => (k,case r of EMPTY => b | _ => (a,R)::b)
531: | R => getvalue ((r,L)::b)
532: )
533: | EMPTY => getvalue b
534: )
535: | getvalue(nil) = raise Done
536: fun f (nil,nil) = false
537: | f (s1 as (_ :: _),s2 as (_ :: _ )) =
538: let val (v1,news1) = getvalue s1
539: and (v2,news2) = getvalue s2
540: in (elem_gt(v1,v2)) orelse (elem_eq(v1,v2) andalso f(news1,news2))
541: end
542: | f (_,nil) = true
543: | f (nil,_) = false
544: in f ((tree1,L)::nil,(tree2,L)::nil) handle Done => false
545: end
546: end
547:
548: functor FullSet (B : sig type elem
549: val eq : (elem*elem) -> bool
550: val gt : (elem*elem) -> bool
551: end
552: ) : FULLSET =
553: struct
554: structure C = BaseSet(B)
555: open C
556: type set = base_set
557:
558: fun is_empty(S) = (let val (_) = select_arb(S) in false end
559: handle Select_arb => true)
560:
561: fun make_list(S) = setfold (fn (a,r) => a::r) S nil
562:
563: val contained = exists
564:
565: fun make_set l =
566: List.fold (fn (a,NewSet) => insert a NewSet) l empty
567:
568: fun partition F S = setfold (fn (a,(Yes,No)) =>
569: if F(a) then (insert a Yes,No)
570: else (Yes,insert a No))
571: S (empty,empty)
572:
573: fun remove(X, XSet) =
574: let val (YSet, _) =
575: partition (fn a => not (elem_eq (X, a))) XSet
576: in YSet
577: end
578:
579: fun difference(Xs, Ys) =
580: setfold (fn (a,Xs') => if exists a Ys then Xs' else insert a Xs') Xs
581: empty
582:
583: fun singleton X = insert X empty
584:
585: fun card(S) = setfold (fn (a,count) => count+1) S 0
586:
587: val same_set = set_eq
588:
589: fun union(Xs,Ys)= setfold (fn (a,Xs) => insert a Xs) Ys Xs
590:
591: local
592: fun closure'(from, f, result) =
593: if is_empty from then result
594: else
595: let val (more,result) =
596: setfold (fn (a,(more',result')) =>
597: let val more = f a
598: val new = difference(more,result)
599: in (union(more',new),union(result',new))
600: end) from
601: (empty,result)
602: in closure'(more,f,result)
603: end
604: in
605: fun closure(start, f) = closure'(start, f, start)
606: end
607: end;
608:
609: functor Graph (B :
610: sig
611: type node
612: type edge
613: val eq_node : node * node -> bool
614: val gt_node : node * node -> bool
615: val eq_edge : edge * edge -> bool
616: val gt_edge : edge * edge -> bool
617: end
618: ) : GRAPH =
619: struct
620:
621: open B
622:
623: type graph_edge = {From : node, Edge : edge, To :node }
624:
625: fun EqEdge ({From=F1,Edge=E1, To = T1},{From=F2,Edge=E2,To=T2}) =
626: eq_node (F1,F2) andalso eq_node (T1,T2) andalso eq_edge(E1,E2)
627:
628: fun GtEdge ({From=F1,Edge=E1, To = T1},{From=F2,Edge=E2,To=T2}) =
629: gt_node(F1,F2) orelse (eq_node(F1,F2) andalso
630: (gt_node(T1,T2) orelse (eq_node(T1,T2) andalso gt_edge(E1,E2))))
631:
632: structure N = FullSet (struct
633: type elem = node
634: val eq = eq_node
635: val gt = gt_node
636: end
637: )
638:
639: structure EdgeSet = FullSet (struct
640: type elem = graph_edge
641: val eq = EqEdge
642: val gt= GtEdge
643: end
644: )
645:
646:
647: datatype graph = GRAPH of {TheNodes : N.set, TheEdges : EdgeSet.set}
648:
649: fun find_node (GRAPH {TheNodes, ...},n) = N.find n TheNodes
650:
651: val null_graph = GRAPH {TheNodes = N.empty, TheEdges = EdgeSet.empty}
652:
653: fun nodes_of(GRAPH{TheNodes, ...}) = N.make_list TheNodes
654:
655: fun num_nodes(GRAPH{TheNodes, ...}) = N.card(TheNodes)
656:
657: fun add_node (GRAPH {TheNodes, TheEdges} , n1) =
658: GRAPH{TheNodes=N.insert n1 TheNodes, TheEdges=TheEdges}
659:
660: fun add_edge (GRAPH {TheNodes, TheEdges}, n1, Edge, n2) =
661: let val NewEdges =
662: EdgeSet.insert {From=n1, Edge=Edge, To=n2} TheEdges
663: in GRAPH {TheNodes=TheNodes, TheEdges=NewEdges}
664: end
665:
666: fun join (GRAPH{TheNodes, TheEdges},n1, Edge, n2) =
667: GRAPH {TheNodes=N.insert n1 (N.insert n2 TheNodes),
668: TheEdges= EdgeSet.insert {From=n1,Edge=Edge,
669: To=n2} TheEdges }
670:
671: fun edges ( GRAPH {TheNodes, TheEdges }, n) =
672: let fun match {From, Edge,To} = eq_node (From, n)
673: in EdgeSet.setfold (fn (e,r) =>
674: if match e then EdgeSet.insert e r else r)
675: TheEdges EdgeSet.empty
676: end
677:
678: fun all_edges(GRAPH{TheEdges, ...}) = TheEdges
679:
680: end;
681: functor V2_Lset (G : V2_LR_GRAMMAR) : V2_LSET =
682: struct
683: open G
684: structure G = G
685: abstype Lookahead = LS of (G.Terminal*int) list
686: with val emptylookahead = LS nil
687:
688: (* mergelookahead - return true as the second element of the
689: pair if lookahead set 2 contains some elements lookahead
690: set 1 does not
691: *)
692:
693: fun mergelookahead (p,flag : bool ref) : Lookahead =
694: let fun f(nil,nil,r) = rev r
695: | f(a::a',nil,r) = f(a',nil,a::r)
696: | f(nil,b::b',r) = f(b',nil,b::r)
697: | f(x as ((a as (_,hash_a))::a'),
698: y as ((b as (_,hash_b))::b'),r) =
699: if ((hash_a : int ) < hash_b) then
700: f(a',y,a::r)
701: else if (hash_a>hash_b) then
702: f(x,b',b::r)
703: else f(a',b',a::r)
704: in case p of
705: (LS a,LS b) =>
706: let val r = f(a,b,nil)
707: in (if (length a) < (length r) then
708: flag := true
709: else (); LS r)
710: end
711: end
712:
713: (* addterms - adds terminals to a lookahead set *)
714:
715: fun addterms(LS a,l) =
716: let fun g(l,e) =
717: let val hash_e = termHash e
718: fun insert(nil,e) = [(e,hash_e)]
719: | insert(t as ((a' as (_,hash_a))::a),e) =
720: if (hash_a<hash_e) then a'::(insert(a,e))
721: else if (hash_a=hash_e) then t
722: else (e,hash_e)::a'::a
723: in insert(l,e)
724: end
725: val r=List.fold (fn (e,r) => g(r,e)) l a
726: in LS r
727: end
728:
729: fun makelookaheadlist (LS a) = List.map (fn (t,_) => t) a
730: end
731: end;
732:
733: functor V2_LrUtils(structure G : V2_LR_GRAMMAR): V2_LR_UTILS =
734: struct
735:
736: structure G = G
737: structure Lset = V2_Lset(G)
738: structure Memo = Memo(type Arg = G.Nonterminal)
739:
740: open G
741:
742: val DEBUG = false
743: val print = if DEBUG then output std_out
744: else Busy.print
745: val println = if DEBUG then fn x => (print x; print "\n")
746: else Busy.println
747: val withNewline = if DEBUG then (fn pr => fn x => (pr x; print "\n"))
748: else Busy.withNewline
749:
750: (* diagnostics *)
751: val mkshowSymbol =
752: fn {showTerminalClass = showTerminalClass : G.Terminal -> string,
753: showNonterminal = showNonterminal : G.Nonterminal -> string
754: } => fn (TERM t) => showTerminalClass t
755: | (NONTERM nt) => showNonterminal nt
756:
757: fun showSpaced f lst = fold (fn (x, y) => x ^ " " ^ y) (map f lst) ""
758:
759: datatype Core = CORE of { I : {coreLHS: G.Nonterminal,
760: corePrecedence: int option,
761: coreAttribute: G.Attribute},
762: coreRHSbefore: G.Symbol list,
763: coreRHSafter: G.Symbol list,
764: prop : bool ref,
765: lookaheads : Lset.Lookahead ref
766: }
767:
768:
769: val printCore =
770: fn {showSymbol=showSymbol: G.Symbol -> string,
771: showNonterminal=showNonterminal : G.Nonterminal -> string,
772: showTerminalClass=showTerminalClass : G.Terminal -> string } =>
773: fn (CORE c) =>
774: let val {I = {coreLHS=coreLHS, ...}, coreRHSbefore, coreRHSafter,
775: prop, lookaheads} = c
776: in (
777: print(showNonterminal coreLHS ^ " : "
778: ^ showSpaced showSymbol (rev coreRHSbefore)
779: ^ "_"
780: ^ showSpaced showSymbol coreRHSafter
781: );
782: if DEBUG then
783: print(" lookaheads: " ^ showSpaced showTerminalClass
784: (Lset.makelookaheadlist (!lookaheads))
785: )
786: else ()
787: )
788: end
789:
790: fun gtSymbol(TERM t1, TERM t2) = gtTerminal(t1,t2)
791: | gtSymbol(NONTERM nt1, NONTERM nt2) = gtNonterminal(nt1,nt2)
792: | gtSymbol (TERM _,NONTERM _) = true
793: | gtSymbol _ = false
794:
795: fun eqSymbol(TERM t1, TERM t2) = eqTerminal(t1,t2)
796: | eqSymbol(NONTERM nt1, NONTERM nt2) =eqNonterminal(nt1,nt2)
797: | eqSymbol _ = false
798:
799: fun eqCore(CORE {I = {coreAttribute = G.ATTRIB {num=n1,...}, ...},
800: coreRHSbefore=b1, ...},
801: CORE {I = {coreAttribute = G.ATTRIB {num=n2,...}, ...},
802: coreRHSbefore = b2, ...}
803: ) =
804: (n1 = n2) andalso (length b1 = length b2)
805:
806: fun gtCore(CORE {I = {coreAttribute = G.ATTRIB {num=n1,...}, ...},
807: coreRHSbefore=b1, ...},
808: CORE {I = {coreAttribute = G.ATTRIB {num=n2,...}, ...},
809: coreRHSbefore = b2, ...}
810: ) =
811: (n1>n2) orelse (n1=n2 andalso (length b1) > length (b2))
812:
813: structure CoreSet = FullSet (struct
814: type elem = Core
815: val gt = gtCore
816: val eq = eqCore
817: end)
818:
819: fun filter f (x :: xs) = if f x then x :: filter f xs else filter f xs
820: | filter f nil = nil
821:
822: fun buildCore(RULE{lhs, rhs, attribute, precedence}) =
823: CORE({I = {coreLHS=lhs,
824: corePrecedence=precedence,
825: coreAttribute=attribute},
826: coreRHSbefore=nil,
827: coreRHSafter=rhs,
828: prop=ref false,
829: lookaheads=ref Lset.emptylookahead
830: }
831: )
832:
833: fun copyCore(a as (CORE c)) =
834: case c
835: of {I,coreRHSbefore, coreRHSafter, ...} =>
836: CORE({I=I,
837: coreRHSbefore=coreRHSbefore,
838: coreRHSafter=coreRHSafter,
839: prop=ref false,
840: lookaheads = ref Lset.emptylookahead
841: })
842:
843: val copyCoreSet = fn s =>
844: CoreSet.setfold (fn (a,r)=> CoreSet.insert (copyCore a) r) s
845: CoreSet.empty
846:
847: val printCoreSet = fn {printCore = printCore : Core -> unit} =>
848: let val printCoreIndented = fn core =>
849: (print " "; withNewline printCore core)
850: in fn cores => CoreSet.app printCoreIndented cores
851: end
852:
853: val buildCores = fn rules => fn nt =>
854: let val matchingProds =
855: filter (fn RULE{lhs, ...} => eqNonterminal(lhs, nt))
856: rules
857:
858: val cores = CoreSet.make_set (map buildCore matchingProds)
859: in
860: (*
861: if DEBUG then
862: (println("buildCores " ^ showNonterminal nt);
863: printCoreSet cores
864: )
865: else
866: *) ();
867:
868: cores
869: end
870:
871: val mkselectCores =
872: fn {rules=rules : G.Rule list,numNonterminals=n : int} =>
873: (Memo.enum_memo_fn (G.nontermHash, n))
874: (buildCores rules)
875:
876: fun immediateSymbols cores =
877: CoreSet.setfold
878: (fn (CORE {coreRHSafter,...},result) =>
879: case coreRHSafter
880: of sym :: _ =>
881: if (exists (fn a => eqSymbol(a,sym)) result)
882: then result
883: else sym::result
884: | nil => result
885: ) cores nil
886:
887:
888: datatype true = T of Nonterminal | F
889:
890: (* Transitive closure : assumes array is an array of row arrays,
891: where entry a(i,j) is true if the ith item is connected to the
892: jth item, i.e. if the nonterminal with hash # i will cause all
893: the productions of the nonterminal with hash # j to be added to a
894: core set when
895: a production of the form 'a . B 'b, where hash B = i is
896: encountered *)
897:
898: val transitive_closure = fn (a : true array array) =>
899: let val size = Array.length a
900: val i = ref 0
901: val j = ref 0
902: val k = ref 0
903: in while (!i < size) do
904: (j := 0; while (!j < size) do
905:
906: (* check if jth nonterm derives ith nonterm *)
907:
908: (case ((a sub !j) sub !i) of
909: (T _) =>
910:
911: (* if so then connect jth nonterm w/ everything the
912: ith derives
913: *)
914: (k := 0;
915: while (!k < size) do
916: (case ((a sub !i) sub !k)
917: of (d as (T x)) => update(a sub !j,!k,d)
918: | _ => ();
919: if DEBUG then (
920: print ("doing " ^ (makestring (!i)) ^ " " ^
921: (makestring (!j)) ^ " " ^ (makestring (!k)) ^
922: "\n")
923: )
924: else ();
925: k := !k +1
926: )
927: )
928: | F => (); j := !j+1
929: );
930: i := !i + 1
931: )
932: end
933:
934: (* ComputeClosureAdditions - compute the nonterminals which must
935: be added when one nonterminal with a dot before it is added to
936: the core set. Do this by constructing an array indexed by
937: nonterminal hash #. Each a[i,j] entry is set to true when
938: nonterminal i derives nonterminal j. Then take the closure
939: of the array. (Clearly, if A -> .B, and B -> .C, then A -> .C,
940: also. *)
941:
942: fun ComputeClosureAdditions(rules,max) =
943: let val a = array(max,array(max,F)) (* re: same subarray, always *)
944: val _ = let val i = ref 0 (* re: make them different *)
945: in while (!i<max) do (* arrays *)
946: (update(a,!i,array(max,F)); i := !i + 1)
947: end
948: val g = fn (RULE {lhs,rhs=(NONTERM n)::_,...}) =>
949: update(a sub (nontermHash lhs),nontermHash n,T n)
950: | _ => ()
951: in (app g rules; transitive_closure(a); a)
952: end
953:
954: val ComputeClosureAdditions =
955: (*
956: if DEBUG then
957: fn (rules,max) =>
958: let val a = ComputeClosureAdditions(rules,max)
959: val i = ref 0
960: in (while (!i < max) do
961: (let val j = ref 0
962: in while (!j < max) do
963: (case ((a sub !i) sub !j) of
964: T i => print ((showNonterminal i) ^ " ")
965: | F => ();
966: j := !j+1)
967: end; println ""; i := !i+1
968: ); a)
969: end
970: else
971: *) ComputeClosureAdditions
972:
973: (* ComputeCoreSetClosure:
974:
975: Takes the closure of a core set. This consists of adding for
976: each item with a nonterminal immediately after the dot all
977: productions for which the nonterminal is the lhs. This process
978: is then repeated for the new production.
979:
980: We can compute the set of all nonterminals whose productions
981: must be added when a nonterminal is added using ComputeClosure-
982: Additions.
983:
984: We keep a boolean array indexed by nonterminal hash #'s. We look
985: at all the items in the core set. When we find an item with a non-
986: terminal immediately after the ., we set the corresponding element
987: in the bool array to true,s ince we must add all the productions for
988: that terminal. We also set the entries for all the nonterminals
989: which must be added when that nonterminal is added. This uses the
990: information from ComputeClosureAdditions.
991:
992: Note that we can check the entry for the nonterminal with the dot
993: before it before doing any of this. If it is true, since the
994: relation defined by ComputeClosureAdditions is transitive, all non-
995: terminals which would need to be added for this nonterminal have
996: already been added when it was added
997:
998: We then take the boolean array, and add all productions for
999: all nonterminals whose have been set to true.
1000: *)
1001:
1002: fun ComputeCoreSetClosure(cores,a,max,selectCores) =
1003: (* cores = core set, a = array from ComputeClosureAdditions,
1004: max = # of nonterminals *)
1005:
1006: let val b = array(max,F)
1007: fun g (CORE c) =
1008: let val {coreRHSafter,...} = c
1009: in case coreRHSafter of
1010: ((NONTERM n) :: _) =>
1011: let val num = nontermHash n
1012: in case (b sub num) of
1013: F => (update(b,num,T n);
1014: let val i = ref 0
1015: in while (!i < max) do
1016: (case ((a sub num) sub !i)
1017: of F => ()
1018: | (m as (T _)) =>
1019: update(b,!i,m);
1020: i := !i + 1
1021: )
1022: end
1023: )
1024: | (T _ ) => ()
1025: end
1026: | _ => ()
1027: end
1028: fun add_cores(cores) =
1029: let fun g (i,cores) =
1030: case (b sub i) of
1031: (T k) => CoreSet.union(cores,
1032: (selectCores k))
1033: | F => cores
1034: fun f(i,r) =
1035: if (i < max) then f(i+1,g(i,r))
1036: else r
1037: in f(0,cores)
1038: end
1039: in ((CoreSet.app g cores); add_cores cores)
1040: end
1041:
1042: val mkcoreClosure=
1043: fn {rules=rules:G.Rule list,
1044: numNonterminals=numNonterminals:int,
1045: selectCores=selectCores:G.Nonterminal->CoreSet.set
1046: } =>
1047: let val a = ComputeClosureAdditions (rules,numNonterminals)
1048: in fn cores =>
1049: ComputeCoreSetClosure(cores,a,numNonterminals,selectCores)
1050: end
1051:
1052: (* undefined now : printCoreSet, coreClosure
1053:
1054: val coreClosure =
1055: if DEBUG then
1056: fn cores =>
1057: (println "coreClosure of";
1058: printCoreSet cores;
1059: println "yields";
1060: let val cores' = coreClosure cores
1061: in
1062: printCoreSet cores';
1063: cores'
1064: end
1065: )
1066: else coreClosure
1067: *)
1068:
1069: (* prop_f_to_c_a: Propagate firsts to closure additions.
1070:
1071: For each item in a core of the form A -> 'a . B 'b, where
1072: B is a nonterminal, all B productions will contain first_string
1073: 'b in their lookahead set
1074: *)
1075:
1076: val prop_f_to_c_a : {first_string : G.Symbol list -> G.Terminal list,
1077: selectCores : G.Nonterminal -> CoreSet.set} ->
1078: (CoreSet.set -> unit) =
1079: fn {first_string = first_string : G.Symbol list -> G.Terminal list,
1080: selectCores = selectCores : G.Nonterminal -> CoreSet.set}
1081: => fn (cores : CoreSet.set) =>
1082:
1083: (* f : check if a core has a . before a nonterminal.
1084: If so, propagate the first set of the string
1085: following the nonterminal to all the productions
1086: derived from the nonterminal
1087: *)
1088:
1089: let val f = fn (CORE {coreRHSafter=(NONTERM b)::r, ...}) =>
1090: let val firsts = first_string r
1091: exception ClosureError
1092: val g = fn a =>
1093: case (CoreSet.find a cores) of
1094: NONE => raise ClosureError
1095: | SOME (CORE {lookaheads=l1, ...}) =>
1096: l1 := Lset.addterms(!l1,firsts)
1097: in CoreSet.app g (selectCores b)
1098: end
1099: | _ => ()
1100:
1101: in (CoreSet.app f cores)
1102: end
1103:
1104: (* set_prop: Prop is a boolean variable which is set to true
1105: for items which propagate their lookaheads to items derived
1106: from them. These items have the form 'a .B 'c, where
1107: 'c derives epsilon. The lookaheads propagate to those items
1108: derived from B through the closure operation, and to the
1109: item GOTO('a .B 'c, B). This function sets prop for all items
1110: in a core set.
1111:
1112: *)
1113:
1114: val set_prop =
1115: fn (nullable_string : G.Symbol list -> bool) =>
1116: let val g = fn (CORE c) =>
1117: let val c' = c
1118: in case c'
1119: of {coreRHSafter=(NONTERM _):: t,prop,...} =>
1120: if (nullable_string t) then prop := true
1121: else ()
1122: | _ => ()
1123: end
1124: in CoreSet.app g (* must be applied to a core set now *)
1125: end
1126:
1127: val hardwire_eof = fn (cores,eof,start) =>
1128: let val f = fn (CORE c) =>
1129: let val {I={coreLHS=lhs,...},lookaheads,...} = c
1130: in if (eqNonterminal(lhs,start)) then
1131: lookaheads := Lset.addterms(!lookaheads,[eof])
1132: else ()
1133: end
1134: in CoreSet.app f cores
1135: end
1136:
1137: (* propagate_l_to_c_a: Propagate lookaheads to closure additions.
1138: If an item in a core has the form A-> 'a .B 'b where B is a
1139: nonterminal, and 'b derives epsilon, then all productions of
1140: B get A's lookahead. Returns true if any change to a
1141: B productions lookahead occurs.
1142: *)
1143:
1144: val propagate_l_to_c_a =
1145: fn {selectCores=selectCores : G.Nonterminal -> CoreSet.set} =>
1146: fn (cores: CoreSet.set, result : bool ref) =>
1147: let val f = fn (CORE c) =>
1148: case c
1149:
1150: (* Check that a core item has the correct form *)
1151:
1152: of {prop=ref true,coreRHSafter=NONTERM n::_,
1153: lookaheads,...}=>
1154: let exception PropClosureError
1155:
1156: (* g: Takes an item whose lookahead depends on the
1157: above item, and merges the above item's
1158: lookahead into the item's lookahead
1159: *)
1160: exception PropClosureError
1161:
1162: val g = fn c =>
1163: case (CoreSet.find c cores) of
1164: (SOME (CORE {lookaheads=l, ...})) =>
1165: l := Lset.mergelookahead
1166: ((!l,!lookaheads),result)
1167: | NONE => raise PropClosureError
1168:
1169: (* apply g to the items directly derived from
1170: NONTERM n.
1171: *)
1172:
1173: in CoreSet.app g (selectCores n)
1174: end
1175: | _ => ()
1176: in CoreSet.app f cores
1177: end
1178:
1179: (* propagate_l_to_g_i: Propagate lookaheads to goto items *)
1180:
1181: val propagate_l_to_g_i =
1182:
1183:
1184: fn (shiftCore : Core -> Core) =>
1185:
1186: (* takes an edge from n1 to n2 *)
1187:
1188: fn ((n1: CoreSet.set, e: G.Symbol, n2 : CoreSet.set),result) =>
1189:
1190: let
1191:
1192: (* match: merge lookaheads of an item into the items
1193: which result from a shift
1194: *)
1195:
1196: val match=
1197: fn (a as (CORE {coreRHSafter=b::_,lookaheads=l1,...})) =>
1198: if eqSymbol(b,e) then
1199: case (CoreSet.find (shiftCore a) n2)
1200: of SOME (CORE {lookaheads=l2,...}) =>
1201: l2 := Lset.mergelookahead((!l2,!l1),result)
1202: | NONE => ()
1203: else ()
1204: | _ => ()
1205: in (CoreSet.app match n1)
1206: end
1207: end;
1208:
1209: functor V2_Lookahead(structure G : V2_LR_GRAMMAR
1210: structure Utils: V2_LR_UTILS
1211: sharing Utils.G = G
1212: ): V2_LOOKAHEAD =
1213: struct
1214: structure NontermMemo = Memo(type Arg = G.Nonterminal)
1215:
1216: structure G = G
1217: structure Utils = Utils
1218: open G Utils
1219:
1220: structure TermSet = FullSet(type elem = Terminal
1221: val gt = gtTerminal
1222: val eq = eqTerminal)
1223:
1224: structure NontermSet = FullSet(type elem = Nonterminal
1225: val gt = gtNonterminal
1226: val eq = eqNonterminal)
1227:
1228: val DEBUG = false
1229:
1230: (* build an enumerated memo-fn over nonterminals *)
1231:
1232: val mkfunctions =
1233: fn {numNonterminals,selectCores,showNonterminal,showTerminalClass} =>
1234: let
1235: val nontermMemo = NontermMemo.enum_memo_fn(nontermHash, numNonterminals)
1236:
1237: (* actual print functions (rather than string generators) *)
1238:
1239: val printTerminalClass = Busy.print o showTerminalClass
1240: val printNonterminal = Busy.print o showNonterminal
1241:
1242: (* The FIRST set construction functions *)
1243:
1244: (* nullable: true if nonterminal "nt" has some null rhs production *)
1245: fun nullable(nt, cores) =
1246: CoreSet.setfold (fn (CORE c,rest) =>
1247: let val {coreRHSafter, ...} = c
1248: in rest orelse (null coreRHSafter)
1249: end) cores false
1250:
1251:
1252: (* memo-ise "nullable", add diags *)
1253: fun prNullable(nt, b) =
1254: (Busy.println("Nullable " ^ showNonterminal nt ^ "? "
1255: ^ case b of true => "YES" | false => "NO"
1256: );
1257: b
1258: )
1259:
1260: val nullable =
1261: nontermMemo(if DEBUG then
1262: fn nt => prNullable(nt, nullable(nt, selectCores nt))
1263: else
1264: fn nt => nullable(nt, selectCores nt)
1265: )
1266:
1267: (* nullable_string: check if a string of terminals and variables is nullable *)
1268:
1269: fun nullable_string (TERM t :: _ ) = false
1270: | nullable_string (NONTERM t :: r ) =
1271: (if nullable t then (nullable_string r) else false)
1272: | nullable_string nil = true
1273:
1274: (* accumulate: look at the start of core right-hand-sides, looking past
1275: nullable nts, applying addObj to the visible symbols. *)
1276: fun accumulate(cores, empty, addObj) =
1277: let
1278: fun accumAlongSymbols(symbols, result) =
1279: case symbols
1280: of (sym as NONTERM nt) :: rest =>
1281: if nullable nt then
1282: accumAlongSymbols(rest, addObj(sym, result))
1283: else
1284: addObj(sym, result)
1285:
1286: | (sym as TERM _) :: _ => addObj(sym, result)
1287:
1288: | nil => result
1289:
1290: fun accumAlongCores(cores, result) =
1291: CoreSet.setfold (fn (CORE c,result) =>
1292: let val {coreRHSafter, ...} = c
1293: in accumAlongSymbols(coreRHSafter, result)
1294: end) cores result
1295: in
1296: accumAlongCores(cores, empty)
1297: end
1298:
1299:
1300: (* first1: the FIRST set of a nonterminal in the grammar. Only looks
1301: at other terminals, but it *is* clever enough to move past nullable
1302: nonterminals at the start of a production. *)
1303: fun first1 nt = accumulate(selectCores nt,
1304: TermSet.empty,
1305: fn (TERM t, set) => TermSet.insert t set
1306: | (_, set) => set
1307: )
1308:
1309: (* memo-ise first1, add diags *)
1310: fun prFirst1(nt, termSet) =
1311: (Busy.print("First1 set of " ^ showNonterminal nt ^ " = { ");
1312: TermSet.app (Busy.withSpace printTerminalClass) termSet;
1313: Busy.println "}";
1314: termSet)
1315: val first1 = nontermMemo(if DEBUG then fn nt => prFirst1(nt, first1 nt)
1316: else first1
1317: )
1318:
1319: (* starters1: given a nonterminal "nt", return the set of nonterminals
1320: which can start its productions. Looks past nullables, but doesn't
1321: recurse *)
1322: fun starters1 nt = accumulate(selectCores nt,
1323: NontermSet.empty,
1324: fn (NONTERM nt, set) =>
1325: NontermSet.insert nt set
1326: | (_, set) => set
1327: )
1328:
1329: (* memo-ise starters1, add diags *)
1330: fun prStarters1(nt, nontermSet) =
1331: (Busy.print("Starters1 set of " ^ showNonterminal nt ^ " = { ");
1332: NontermSet.app (Busy.withSpace printNonterminal) nontermSet;
1333: Busy.println "}";
1334: nontermSet
1335: )
1336:
1337: val starters1 =
1338: nontermMemo(if DEBUG then fn nt => prStarters1(nt, starters1 nt)
1339: else starters1
1340: )
1341:
1342: (* starters: a closure over starters1 *)
1343: fun starters nt = NontermSet.closure(NontermSet.singleton nt, starters1)
1344:
1345: (* memo-ise starters, add diags *)
1346: fun prStarters(nt, nontermSet) =
1347: (Busy.print("Starters set of " ^ showNonterminal nt ^ " = { ");
1348: NontermSet.app (Busy.withSpace printNonterminal) nontermSet;
1349: Busy.println "}";
1350: nontermSet
1351: )
1352:
1353: val starters =
1354: nontermMemo(if DEBUG then fn nt => prStarters(nt, starters nt)
1355: else starters
1356: )
1357:
1358: (* first: maps a nonterminal to its first-set. Get all the starters of
1359: the nonterminal, get the first1 terminal set of each of these,
1360: union the whole lot together *)
1361: fun first nt =
1362: let val startersSet = starters nt
1363: val startersList = startersSet
1364: in
1365: NontermSet.setfold (fn (a,r) => TermSet.union(r,first1 a))
1366: startersList TermSet.empty
1367: end
1368:
1369: (* memo-ise first, add diags *)
1370: fun prFirst(nt, termSet) =
1371: (Busy.print("First set of " ^ showNonterminal nt ^ " = { ");
1372: TermSet.app (Busy.withSpace printTerminalClass) termSet;
1373: Busy.println "}";
1374: termSet
1375: )
1376:
1377: val first =
1378: nontermMemo(if DEBUG then fn nt => prFirst(nt, first nt)
1379: else first
1380: )
1381:
1382:
1383:
1384: (* prefix: all possible terminals starting a symbol list *)
1385: fun prefix symbols =
1386: case symbols
1387: of TERM t :: _ => TermSet.singleton t
1388: | NONTERM nt :: rest =>
1389: if nullable nt then
1390: TermSet.union(first nt, prefix rest)
1391: else
1392: first nt
1393: | nil => TermSet.empty
1394:
1395: in {first_string = fn n => TermSet.make_list (prefix n),
1396: nullable_string = nullable_string}
1397: end
1398: end
1399:
1400: functor V2_LrGraph(structure G: V2_LR_GRAMMAR
1401: structure Utils: V2_LR_UTILS
1402: structure Lookahead: V2_LOOKAHEAD
1403: sharing Lookahead.Utils = Utils
1404: sharing Lookahead.G = Utils.G = G
1405: ) : V2_LR_GRAPH =
1406: struct
1407:
1408: open G Lookahead Utils
1409:
1410: val DEBUG = false
1411:
1412: (* type abbrevs for the type of graph we're generating *)
1413: type State = {state: int, cores: CoreSet.set}
1414:
1415: structure Lr_Graph = Graph
1416: (struct
1417: type node = {state : int, cores : CoreSet.set }
1418: type edge = Symbol
1419: val gt_node = fn ({cores,...}:State,{cores=cores',...}:State) =>
1420: CoreSet.set_gt(cores,cores')
1421: val eq_node = fn ({cores,...}:State,{cores=cores',...}:State) =>
1422: CoreSet.set_eq(cores,cores')
1423: val eq_edge = eqSymbol
1424: val gt_edge = gtSymbol
1425: end)
1426:
1427: type Graph = Lr_Graph.graph
1428:
1429: (* the goto function from State * Symbol to State list *)
1430: fun coreMatch(CORE c, symbol) =
1431: let val {coreRHSafter, ...} = c
1432: in
1433: case coreRHSafter
1434: of (symbol' :: _) => eqSymbol(symbol, symbol')
1435: | _ => false
1436: end
1437:
1438: exception ShiftCore
1439: fun shiftCore (a as (CORE c)) =
1440: case c
1441: of {I, coreRHSbefore, coreRHSafter=hd :: tl, prop,lookaheads} =>
1442: CORE({I=I,
1443: coreRHSbefore=hd :: coreRHSbefore,
1444: coreRHSafter=tl,
1445: prop=prop,
1446: lookaheads = lookaheads
1447: }
1448: )
1449: | _ => raise ShiftCore
1450:
1451: val mkGraph = fn {rules = rules : G.Rule list, verbose = verbose : bool,
1452: eof = eof: G.Terminal,start = start: G.Nonterminal,
1453: termPrecedence = termPrecedence: G.Terminal -> int option,
1454: showTerminalClass=showTerminalClass: G.Terminal -> string,
1455: showTerminalValue=showTerminalValue : G.Terminal -> string,
1456: showNonterminal=showNonterminal : G.Nonterminal -> string,
1457: showAttribute=showAttribute : G.Attribute -> string,
1458: numTerminals=numTerminals : int,
1459: numNonterminals=numNonterminals : int
1460: } =>
1461: let val showSymbol = mkshowSymbol {showTerminalClass=showTerminalClass,
1462: showNonterminal=showNonterminal}
1463: val printCore = printCore {showSymbol = showSymbol,
1464: showNonterminal = showNonterminal,
1465: showTerminalClass = showTerminalClass}
1466: val printCoreSet = printCoreSet {printCore=printCore}
1467: val selectCores = mkselectCores
1468: {rules=rules,numNonterminals=numNonterminals}
1469: val coreClosure = mkcoreClosure {rules=rules,
1470: numNonterminals = numNonterminals,
1471: selectCores = selectCores}
1472:
1473: val {first_string,nullable_string} =
1474: mkfunctions {numNonterminals = numNonterminals,
1475: selectCores = selectCores,
1476: showNonterminal = showNonterminal,
1477: showTerminalClass = showTerminalClass
1478: }
1479: (* the traversal of a set of cores which can shift on "symbol" *)
1480: fun traversal'(cores, symbol, result) =
1481: coreClosure(
1482: CoreSet.setfold (fn (a,result) =>
1483: if coreMatch(a,symbol) then CoreSet.insert (shiftCore a) result
1484: else result) cores result
1485: )
1486:
1487: (* include the symbol itself as well, for convenience in graph
1488: generation *)
1489: fun traversal cores symbol =
1490: (symbol, traversal'(cores, symbol, CoreSet.empty))
1491:
1492: val NextStateNum = ref 0
1493:
1494: val traversal =
1495: if DEBUG then
1496: fn cores =>
1497: fn symbol =>
1498: (Busy.println("Traversal by " ^ showSymbol symbol
1499: ^ " gives"
1500: );
1501: let val (_, cores') = traversal cores symbol
1502: in
1503: printCoreSet cores';
1504: (symbol, cores')
1505: end
1506: )
1507: else
1508: traversal
1509:
1510: (* incorporate1: incorporate a traversal from->symbol->cores into
1511: "graph". Return new graph, and optionally the `to' node, if
1512: it wasn't already present.
1513: *)
1514: fun incorporate1(graph, from: Lr_Graph.node,
1515: (symbol, cores : CoreSet.set)) =
1516: case (Lr_Graph.find_node(graph,{state=0,cores=cores})) of
1517: SOME existingNode =>
1518: (if DEBUG then
1519: (Busy.println "*Existing node found:";
1520: printCoreSet(#cores(existingNode))
1521: )
1522: else ();
1523: (Lr_Graph.add_edge (graph, from, symbol,existingNode),
1524: NONE)
1525: )
1526: | NONE =>
1527: let val _ =
1528: if DEBUG then
1529: (Busy.println("*New state "
1530: ^ makestring (!NextStateNum));
1531: printCoreSet cores
1532: )
1533: else
1534: Busy.dot()
1535:
1536: (* make sure every graph node has * UNIQUE * reference
1537: variables
1538: *)
1539:
1540: val newNode = {cores=copyCoreSet cores,
1541: state=(!NextStateNum)}
1542: val _ = NextStateNum := (!NextStateNum)+1
1543: in (Lr_Graph.add_edge (Lr_Graph.add_node (graph,newNode) , from, symbol,
1544: newNode), SOME newNode)
1545: end
1546:
1547: (* incorporate': takes a graph, a from-node, and a list of traversals
1548: ((symbol*Core set) list). adds any new nodes to the front of "newNodes"
1549: *)
1550: fun incorporate'(graph, from: Lr_Graph.node , traversals, newNodes) =
1551:
1552: case traversals
1553: of this :: rest =>
1554: let val (graph', to) = incorporate1(graph, from, this)
1555: in case to
1556: of SOME node =>
1557: incorporate'(graph', from, rest, node :: newNodes)
1558: | NONE => incorporate'(graph', from, rest, newNodes)
1559: end
1560: | nil => (graph, newNodes)
1561:
1562: fun generateGraph(events, graph) =
1563: case events
1564: of (thisEvent :: restEvents) =>
1565: let
1566: val {state, cores}: State = thisEvent
1567:
1568: val closuredCores = cores
1569: val _ =
1570: if DEBUG then
1571: (Busy.println("*Collecting on event: "
1572: ^ makestring state
1573: );
1574: printCoreSet closuredCores
1575: )
1576: else ()
1577:
1578: val immedSymbols = immediateSymbols closuredCores
1579:
1580: val prSymbol = (Busy.withSpace Busy.print) o showSymbol
1581: val _ =
1582: if DEBUG then
1583: (Busy.print "*Immediate symbols: { ";
1584: map prSymbol immedSymbols;
1585: Busy.println "}"
1586: )
1587: else ()
1588:
1589: val traversals =
1590: List.fold (fn (immed_symbol,r) =>
1591: (traversal closuredCores immed_symbol) :: r)
1592: immedSymbols nil
1593:
1594: val (newGraph, newEvents) =
1595: incorporate'(graph, thisEvent, traversals,restEvents)
1596: in
1597: generateGraph(newEvents, newGraph)
1598: end
1599:
1600: | _ => graph
1601:
1602: (* propagate lookaheads : propagate lookaheads throughout the
1603: graph
1604: *)
1605:
1606: val propagatelookaheads = fn (g : Lr_Graph.graph) =>
1607: let val cores = Lr_Graph.nodes_of g
1608: val cores = List.map (fn c => #cores c) cores
1609: val edges = List.map (fn {From,Edge,To} =>
1610: (#cores(From),Edge,#cores(To)))
1611: (Lr_Graph.EdgeSet.make_list (Lr_Graph.all_edges g))
1612: val gp = ref true;
1613: val cp = ref true;
1614: val _ = List.app (set_prop nullable_string) cores
1615: val _ = List.app (prop_f_to_c_a {first_string=first_string,
1616: selectCores=selectCores}) cores
1617: val closure_prop = fn c =>
1618: propagate_l_to_c_a {selectCores=selectCores} (c,cp)
1619: val goto_prop =
1620: let val goto_prop' = propagate_l_to_g_i shiftCore
1621: in fn e => goto_prop'(e,gp)
1622: end
1623: in while (!gp = true orelse !cp = true) do
1624: (gp := false; cp := false;
1625: output std_out "Propagating lookaheads ...\n";
1626: List.app closure_prop cores;
1627: List.app goto_prop edges
1628: )
1629: end
1630:
1631: (* generate the graph *)
1632: val startCores = copyCoreSet(coreClosure(selectCores start))
1633: val startEvent = {cores=startCores, state=0}
1634:
1635: val _ = if DEBUG then () else Busy.print "Generating State Graph"
1636:
1637: val _ = NextStateNum := 1
1638: val graph = generateGraph([startEvent],
1639: Lr_Graph.add_node(Lr_Graph.null_graph,startEvent))
1640:
1641: val _ = hardwire_eof(startCores,eof,start)
1642: val _ = propagatelookaheads graph
1643: in graph
1644: end
1645: end;
1646: functor V2_TableGen(structure G: V2_LR_GRAMMAR): V2_LR_TABLE =
1647: struct
1648:
1649: structure G = G
1650:
1651: structure Utils =
1652: V2_LrUtils(structure G = G)
1653:
1654: structure Lookahead =
1655: V2_Lookahead(structure G = G
1656: structure Utils = Utils
1657: )
1658:
1659: structure Graph =
1660: V2_LrGraph (
1661: structure G = G
1662: structure Utils = Utils
1663: structure Lookahead = Lookahead
1664: )
1665:
1666: type 'entry Table = 'entry array array
1667:
1668: fun PrTable ((pr : string->unit),
1669: (T : 'entry Table),
1670: (Str: (int * 'entry) -> string),
1671: (EncaseRow : ('entry array -> unit) * (string->unit) ->
1672: 'entry array -> unit)) =
1673: let
1674: val PrintRow = fn (R : 'entry array) =>
1675: let fun f(i,cnt) =
1676: if i<Array.length(R) then
1677: let val s = Str (i,(R sub i))
1678: val cnt =
1679: let val newcount = cnt + size s
1680: in if newcount > 73 then (pr "\\\n\\"; size s)
1681: else newcount
1682: end
1683: in (pr s; f (i+1,cnt))
1684: end
1685: else ()
1686: in f(0,0)
1687: end
1688: fun PrintRows i =
1689: if i < (Array.length T) then
1690: (EncaseRow (PrintRow,pr) (T sub i); PrintRows(i+1))
1691: else ()
1692: in PrintRows 0
1693: end
1694:
1695: fun access(tab, row, col) = (tab sub row) sub col
1696:
1697: (* Generate a table from an initialisation value. Won't work if the
1698: actual value contains references *)
1699: fun genTable(value, r, c) =
1700: let
1701: fun rows 0 = nil
1702: | rows m = array(c, value) :: rows(m - 1)
1703: in
1704: arrayoflist(rows r)
1705: end
1706:
1707: (* assign a table entry, using "resolve" to check it against the existing
1708: entry *)
1709: fun assign(resolve: ('entry * 'entry) -> 'entry,
1710: T: 'entry Table,
1711: Row: int, Col: int,
1712: newEntry: 'entry) =
1713: let val R = T sub Row
1714: val oldEntry = R sub Col
1715:
1716: in update(R, Col, resolve(oldEntry, newEntry))
1717: end
1718:
1719: type State = int
1720: fun showState(state: State) = makestring state
1721:
1722: (* Specific table stuff *)
1723: datatype Action = SHIFT of State
1724: | REDUCE of G.Attribute
1725: | ERROR
1726:
1727: type Prec = int option
1728: type ActionEntry = {action: Action, prec: Prec}
1729: datatype Goto = GOTO of int option
1730:
1731: exception AssignAction (* of ActionEntry * ActionEntry *)
1732: exception AssignGoto of Goto (* Returns the current entry *)
1733:
1734: (* convert integer between 0 and 65535 to a a 2 byte character
1735: string representing the integer, with low byte first *)
1736:
1737: val convert_int = fn (i:int) =>
1738: if i>(256*256-1) then
1739: let exception Convert_int in raise Convert_int end
1740: else
1741: let val make_char = fn (i:int) =>
1742: let val s = makestring i
1743: in (substring("\\000",0,1+3 + (~(size s)))) ^ s
1744: end
1745: in (make_char (i mod 256)) ^ (make_char (i div 256))
1746: end
1747:
1748: local
1749: val make_entry = fn (i,s) => (convert_int (i+1)) ^ s
1750: val showAction = fn states => fn (n : int,{action, prec}) =>
1751: case action
1752: of (REDUCE (G.ATTRIB {num,...})) =>
1753: make_entry(n,convert_int(states+num))
1754: | (SHIFT i) =>
1755: make_entry(n,convert_int(i))
1756: | ERROR => ""
1757: val showGoto =
1758: fn (n:int,(GOTO(SOME j))) =>
1759: make_entry(n,convert_int(j))
1760: | _ => ""
1761: in
1762: val printLr_Table = fn (file : outstream, gotos, actions,
1763: DisplayAttributes,states) =>
1764: let val pr = output file
1765: val prln = fn s => (pr s; pr "\n");
1766: val EncaseRow = fn (PrintRow,pr) => fn r =>
1767: (PrintRow r; pr (convert_int 0); pr "\\\n\\")
1768: val PrintTable = fn (table,entry_print) =>
1769: (pr "\"\\\n\\";
1770: PrTable (pr,table,entry_print,EncaseRow);
1771: prln "\"")
1772: in (pr "\
1773: \structure Lr_Table : MLY_LR_TABLE = \n\
1774: \ struct\n\
1775: \ structure G = G\n\
1776: \ open G\n\
1777: \\n\
1778: \ type State = int \n\
1779: \ val initialState = 0 \n\
1780: \ fun showState(state: State) = makestring state \n\
1781: \\n\
1782: \ (* Specific table stuff *) \n\
1783: \ datatype Action = SHIFT of State \n\
1784: \ | REDUCE of Attribute \n\
1785: \ | ERROR \n\
1786: \ datatype Goto = GOTO of State\n";
1787: pr "local\n\
1788: \ val string_to_int = fn(s,index) => (ordof(s,index) + \n\
1789: \ ordof(s,index+1)*256,index+2)\n";
1790: DisplayAttributes(file);
1791: pr "val numStates =";
1792: prln (makestring states);
1793: pr "\
1794: \ val convert_string_to_list = fn conv_func => fn(s,index) =>\n\
1795: \ let fun f (r,index) =\n\
1796: \ let val (num,index) = string_to_int(s,index)\n\
1797: \ in if num=0 then (rev r,index)\n\
1798: \ else let val (i,index) = string_to_int(s,index)\n\
1799: \ in f((num-1,(conv_func i))::r,index)\n\
1800: \ end\n\
1801: \ end\n\
1802: \ in f(nil,index)\n\
1803: \ end\n\
1804: \ val convert_string_to_array = fn conv_func => fn s =>\n\
1805: \ let val convert_row =convert_string_to_list conv_func\n\
1806: \ fun f(r,index) =\n\
1807: \ if (index < size s) then\n\
1808: \ let val (newlist,index) = convert_row (s,index)\n\
1809: \ in f(newlist::r,index)\n\
1810: \ end\n\
1811: \ else arrayoflist(rev r)\n\
1812: \ in f(nil,0)\n\
1813: \ end\n\
1814: \ val int_to_goto = fn i => GOTO i\n\
1815: \\n\
1816: \ val int_to_action = fn i =>\n\
1817: \ if i >= numStates then\n\
1818: \ get_attribute(i-numStates)\n\
1819: \ else SHIFT i\n\
1820: \ val make_goto_table = convert_string_to_array int_to_goto\n\
1821: \ val make_action_table=convert_string_to_array int_to_action\n";
1822: prln "in";
1823: prln "val actionT = make_action_table";
1824: PrintTable(actions,showAction states);
1825: prln "val gotoT = make_goto_table";
1826: PrintTable(gotos,showGoto);
1827: pr "\
1828: \ exception NotThere\n\
1829: \ fun find(((key:int),data)::b,i) =\n\
1830: \ if (i>key) then find(b,i)\n\
1831: \ else if (i<key) then raise NotThere\n\
1832: \ else data\n\
1833: \ | find (nil,i) = raise NotThere\n\
1834: \ fun action(state,T t) =\n\
1835: \ find(actionT sub state,t) handle NotThere => ERROR\n\
1836: \ exception Goto\n\
1837: \ fun goto(state,NT t) =\n\
1838: \ (case find(gotoT sub state,t)\n\
1839: \ of (GOTO i) => i)\n\
1840: \ handle NotThere => raise Goto\n\
1841: \ end\nend\n")
1842: end
1843: end
1844:
1845: val mktable = fn dest => fn (ALL as
1846: {rules = rules : G.Rule list, verbose=verbose : bool,
1847: eof = eof : G.Terminal, start = start: G.Nonterminal,
1848: termPrecedence = termPrecedence: G.Terminal -> int option,
1849: showTerminalClass= showTerminalClass: G.Terminal -> string,
1850: showTerminalValue=showTerminalValue : G.Terminal -> string,
1851: showNonterminal=showNonterminal : G.Nonterminal -> string,
1852: showAttribute=showAttribute : G.Attribute -> string,
1853: numTerminals=numTerminals : int,
1854: numNonterminals=numNonterminals : int
1855: }) =>
1856: let
1857: val rr_error = ref false
1858:
1859: (* DisplayAttributes: print values for the attributes of the rules,
1860: of the form a{rule #} = ATTRIB ... These values are used in
1861: the printed out version of the Action table. *)
1862:
1863: fun DisplayAttributes (f) =
1864: let val pr = (output f)
1865: in (pr
1866: "val get_attribute= \n\
1867: \ let val convert_back = fn (s,i) =>\n\
1868: \ let val (lhs,ni) = string_to_int(s,i)\n\
1869: \ val (rhsLength,ni) = string_to_int(s,ni)\n\
1870: \ val (num,ni) = string_to_int(s,ni)\n\
1871: \ in (REDUCE(G.ATTRIB{lhs=G.NT lhs,rhsLength=rhsLength,\n\
1872: \ num=num}),ni,num)\n\
1873: \ end\n\
1874: \ val numRules =";
1875: pr (makestring (List.length rules));
1876: pr "\nval attrib_data =\n\"";
1877: app(fn (G.RULE {attribute=G.ATTRIB {lhs,rhsLength,num},...}) =>
1878: (
1879: (* nonterminal number *)
1880:
1881: pr (convert_int (G.nontermHash lhs));
1882:
1883: (* rhs length *)
1884:
1885: pr (convert_int rhsLength);
1886:
1887: (* num *)
1888:
1889: pr (convert_int num);
1890: pr "\\\n\\"
1891: )) rules;
1892:
1893: pr "\"\n\
1894: \ val attrib_array = array(numRules,ERROR)\n\
1895: \ fun convert_string(s,index) =\n\
1896: \ if (index < (size s)) then\n\
1897: \ let val (result,newindex,num)=convert_back(s,index)\n\
1898: \ in (update(attrib_array,num,result);\n\
1899: \ convert_string(s,newindex))\n\
1900: \ end\n\
1901: \ else ()\n\
1902: \ in (convert_string(attrib_data,0); fn i => attrib_array sub i)\n\
1903: \ end\n";
1904: ())
1905: end
1906:
1907: val printTerminalClass = Busy.print o showTerminalClass
1908: val printNonterminal = Busy.print o showNonterminal
1909:
1910: fun srConflict(state, attrib, terminal) =
1911: (Busy.println(showState state ^ ": " ^ "shift/reduce conflict " ^
1912: "(shift " ^ (showTerminalClass terminal) ^ ",reduce " ^
1913: showAttribute attrib ^ ")")
1914: )
1915:
1916: fun precConflict(state, attrib, terminal) =
1917: (Busy.println ((showState state) ^
1918: ": terminal and rule have the same precedence for the");
1919: Busy.println ("shift/reduce conflict " ^
1920: "(shift " ^ (showTerminalClass terminal) ^ ",reduce " ^
1921: showAttribute attrib ^ ")")
1922: )
1923:
1924: fun rrConflict(a1, a2) =
1925: Busy.println("reduce/reduce conflict between "
1926: ^ showAttribute a1 ^ " and " ^ showAttribute a2
1927: )
1928: (* assign an action table entry for state on encountering terminal *)
1929:
1930: (* resolve: precedence handling was modified for nonassociative
1931: terminals. Before, if a rule's precedence was greater than a
1932: terminal's a precedence in a s/r conflict, a reduce was planted.
1933: Otherwise a shift occurred. If a rule's precedence was equal to
1934: a terminal's precedence, a shift was planted, but no warning message
1935: was printed. This does not allow for proper handling of
1936: associativities and precedence in a yacc-like parser generator.
1937:
1938: In yacc, each terminal may have a precedence and an associativity.
1939: A terminal may be left associative, right associative,
1940: or nonassociative. A rule is usually given the precedence of its
1941: rightmost terminal. We want to reduce if the precedence of the
1942: rule is > the terminal, or if the precedences are = and the terminal
1943: is left associative. We want to shift the terminal if the
1944: precedence of the terminal is higher than the rule's precedence,
1945: or if the precedences are equal and the terminal is right associative.
1946: If the precedences are equal and the terminal is nonassociative
1947: this is an error condition.
1948:
1949: We need to print a diagnostic indicating to the user when the
1950: precedences of the rule and the terminal are equal. Then we
1951: can give the rule precedence x, right associative terminals
1952: precedence x+1, left associative terminals precedence x-1, and
1953: nonassociative terminals precedence. x.
1954: *)
1955:
1956:
1957: fun assignAction(actions, state, terminal, entry) =
1958: let fun resolve ({action=ERROR, ...}, x) = x
1959: | resolve (s as {action=SHIFT _, prec=shiftPrec},
1960: r as {action=REDUCE a, prec=redPrec}) =
1961: (case (shiftPrec,redPrec)
1962: of (NONE,_) => (srConflict(state, a, terminal); s)
1963: | (_,NONE) => (srConflict(state, a, terminal); s)
1964: | (SOME (i:int),SOME j) =>
1965: if i = j then (precConflict(state, a, terminal); s)
1966: else if i > j then s
1967: else r
1968: )
1969: | resolve (r as {action=REDUCE _, ...},s as {action=SHIFT _, ...})=
1970: resolve(s,r)
1971: | resolve (r1 as {action=REDUCE a1, ...},
1972: r2 as {action=REDUCE a2, ...}) =
1973: (rrConflict(a1,a2); rr_error := true; r1)
1974: | resolve _ = let exception Resolve in raise Resolve end
1975: in assign(resolve, actions, state, G.termHash terminal, entry)
1976: end
1977:
1978: (* assign a goto entry for a state * nonterminal *)
1979: fun assignGoto(gotos, state, Nonterminal, Entry) =
1980: let fun resolve(GOTO NONE, x) = x |
1981: resolve(Old, _) = raise AssignGoto Old
1982: in
1983: assign(resolve, gotos, state, G.nontermHash Nonterminal, Entry)
1984: end
1985:
1986: (* make table entries for all the graph's edges *)
1987: fun plantEdgeMoves(actions, gotos, allEdges) =
1988: let val f =
1989: fn ({From={state=from,...},Edge,To={state=to,...}}
1990: : Graph.Lr_Graph.EdgeSet.elem) =>
1991: case Edge
1992: of G.TERM t =>
1993: assignAction(actions, from, t,
1994: {action=SHIFT to, prec=termPrecedence t})
1995: | G.NONTERM nt =>
1996: assignGoto(gotos, from, nt, GOTO(SOME to))
1997: in Graph.Lr_Graph.EdgeSet.app f allEdges
1998: end
1999:
2000: (* plant all reductions from a particular state *)
2001: fun plantReductions actions (state,r) =
2002: let val {cores, state} = state
2003:
2004: (* plant a reduction for a core item if the dot is at the end of
2005: the item *)
2006:
2007: val plantReduction =
2008: fn Utils.CORE {coreRHSafter=nil,lookaheads,
2009: I={corePrecedence, coreAttribute, ...},
2010: ...} =>
2011:
2012: (* plant a reduction for each terminal in the
2013: lookahead set *)
2014:
2015: List.app (fn lookahead =>
2016: assignAction(actions,state,lookahead,
2017: {action=REDUCE coreAttribute,
2018: prec=corePrecedence})
2019: ) (Utils.Lset.makelookaheadlist (!lookaheads))
2020:
2021: | _ => ()
2022: val closuredCores = (* coreClosure *) cores
2023:
2024: in (Busy.sendto_list();
2025: Utils.CoreSet.app plantReduction closuredCores;
2026: case Busy.get_list()
2027: of nil => r
2028: | l => (state,l)::r)
2029: end
2030:
2031: (* plant all reductions for all states *)
2032:
2033: fun plantStates(actions: ActionEntry Table,
2034: states: Graph.Lr_Graph.node list) =
2035: List.fold (fn (state,r) => (plantReductions actions) (state,r))
2036: states nil;
2037:
2038: (* Generate graph *)
2039:
2040: val graph = Graph.mkGraph ALL;
2041: val theNodes = Graph.Lr_Graph.nodes_of graph
2042: val theEdges = Graph.Lr_Graph.all_edges graph
2043: val numNodes = Graph.Lr_Graph.num_nodes graph
2044:
2045: val actions=genTable({action=ERROR,prec=NONE},numNodes, numTerminals)
2046: val gotos = genTable(GOTO NONE, numNodes, numNonterminals)
2047:
2048: in (Busy.println "Filling Tables";
2049: if verbose then
2050: (let val outfile = open_out "y.output"
2051: val allerrs = (plantEdgeMoves(actions,gotos,theEdges);
2052: plantStates(actions,theNodes))
2053: val errmsgs = fn state =>
2054: fold (fn ((s,l),r) => if s=state then l::r else r) allerrs
2055: nil
2056: val _ = Busy.sendto_file outfile
2057: val printCore = Utils.printCore
2058: {showSymbol = (Utils.mkshowSymbol
2059: ({showTerminalClass=showTerminalClass,
2060: showNonterminal=showNonterminal})
2061: ),
2062: showTerminalClass = showTerminalClass,
2063: showNonterminal = showNonterminal
2064: }
2065: val printCores = fn (state : int,cores) =>
2066: Utils.CoreSet.app (fn a =>
2067: let val (Utils.CORE c) = a
2068: val {coreRHSafter,
2069: I = {coreLHS,
2070: coreAttribute=Utils.G.ATTRIB {num, ...},
2071: ...},
2072: ...
2073: } = c
2074: in (Busy.print "\t";
2075: printCore a;
2076: case coreRHSafter
2077: of nil => Busy.println (" (reduce by rule "^
2078: (makestring num) ^ ")")
2079: | _ => Busy.println ""
2080: )
2081: end) cores
2082:
2083: val printActions = fn (state : int) =>
2084: let fun f i =
2085: if i < numTerminals then
2086: (case (#action(access(actions,state, i)))
2087: of SHIFT s =>
2088: Busy.println ("\t" ^
2089: (showTerminalClass (G.T i)) ^
2090: "\tshift " ^ (showState s))
2091: | REDUCE (G.ATTRIB {lhs,num,...}) =>
2092: Busy.println ("\t" ^ (showTerminalClass (G.T i))^
2093: "\treduce by rule " ^
2094: (makestring num))
2095: | ERROR => ();
2096: f (i+1))
2097: else ()
2098: fun g i =
2099: if i < numNonterminals then
2100: (case access(gotos, state, i)
2101: of GOTO(SOME s) =>
2102: Busy.println("\t" ^(showNonterminal (G.NT i))^
2103: "\tgoto " ^ (showState s))
2104: | _ => ();
2105: g (i+1))
2106: else ()
2107: in (f 0; g 0)
2108: end
2109: fun print_state a =
2110: let val {state,cores} = a
2111: val cores = (* coreClosure *) cores
2112: in
2113: (Busy.println "";
2114: revapp (revapp Busy.print) (errmsgs state);
2115: Busy.println "";
2116: Busy.println(" state " ^ (makestring state) ^
2117: ":");
2118: Busy.println "";
2119: printCores(state,cores);
2120: Busy.println "";
2121: printActions(state)
2122: )
2123: end
2124:
2125: fun find_state n =
2126: let fun f(a::b) =
2127: let val {state,cores} = a
2128: in if state=n then a else f b
2129: end
2130: in f theNodes
2131: end
2132: fun all_states () =
2133: let fun f i = if i<numNodes then
2134: (print_state (find_state i); f (i+1))
2135: else ()
2136: in f 0
2137: end
2138: in all_states();
2139: Busy.sendto_file std_out;
2140: close_out outfile
2141: end)
2142: else(plantEdgeMoves(actions, gotos,theEdges);
2143: let val errs = (plantStates(actions,theNodes))
2144: in (Busy.sendto_file std_out;
2145: revapp (fn (_,s) => map Busy.print s) errs)
2146: end
2147: );
2148:
2149: if (!rr_error) then raise AssignAction
2150: else printLr_Table(dest,gotos,actions,DisplayAttributes,numNodes)
2151: )
2152: end
2153: end;
2154: structure MLY_MAKE_PARSER =
2155: struct
2156: val print_parser = fn pr => pr
2157: "\
2158: \\n\
2159: \\n\
2160: \signature MLY_GRAMMAR =\n\
2161: \ sig\n\
2162: \ type Terminal\n\
2163: \ type Nonterminal\n\
2164: \ datatype Symbol = TERM of Terminal | NONTERM of Nonterminal\n\
2165: \\n\
2166: \ datatype Attribute = ATTRIB of {lhs:Nonterminal,rhsLength:int,num: int }\n\
2167: \\n\
2168: \ val showTerminalClass : Terminal -> string\n\
2169: \ val showTerminalValue: Terminal -> string\n\
2170: \ val showNonterminal : Nonterminal -> string\n\
2171: \ val eqNonterminal : Nonterminal * Nonterminal -> bool\n\
2172: \ val eqTerminal : Terminal * Terminal -> bool\n\
2173: \\n\
2174: \ type Lineno\n\
2175: \ val lineno : Lineno ref\n\
2176: \ val error: string -> Lineno -> unit\n\
2177: \\n\
2178: \ val ErrTermList : Terminal list\n\
2179: \ val preferred_subst : Terminal -> Terminal list\n\
2180: \ val is_keyword : Terminal -> bool\n\
2181: \ val preferred_insert : Terminal -> bool\n\
2182: \ val eof : Terminal\n\
2183: \ val start : Nonterminal\n\
2184: \ end\n\
2185: \\n\
2186: \signature MLY_LR_TABLE =\n\
2187: \ sig\n\
2188: \ structure G : MLY_GRAMMAR\n\
2189: \ \n\
2190: \ type State\n\
2191: \ val initialState: State\n\
2192: \ val showState: State -> string\n\
2193: \\n\
2194: \ datatype Action = SHIFT of State | REDUCE of G.Attribute | ERROR\n\
2195: \ val action: State * G.Terminal -> Action\n\
2196: \ val actionT : (int * Action) list array\n\
2197: \ val goto: State * G.Nonterminal -> State\n\
2198: \ end\n\
2199: \\n\
2200: \signature MLY_ACTIONS = \n\
2201: \ sig \n\
2202: \ type Value\n\
2203: \ val ErrValList : Value list\n\
2204: \ val VOID : Value\n\
2205: \ val rule : (int * Value list) -> (Value * Value list)\n\
2206: \ end\n\
2207: \\n\
2208: \\n\
2209: \signature MLY_PARSER =\n\
2210: \ sig\n\
2211: \ structure A: MLY_GRAMMAR\n\
2212: \ structure B: MLY_ACTIONS\n\
2213: \ val parse: (unit -> A.Terminal * B.Value) -> (int*int) -> B.Value\n\
2214: \ end;\n\
2215: \\n\
2216: \functor ParserGen(structure Lr_Table : MLY_LR_TABLE\n\
2217: \ structure RuleAction: MLY_ACTIONS\n\
2218: \ ) : MLY_PARSER =\n\
2219: \ struct\n\
2220: \ structure A = Lr_Table.G\n\
2221: \ structure B = RuleAction\n\
2222: \ open Lr_Table RuleAction Lr_Table.G\n\
2223: \ exception Error\n\
2224: \ val DEBUG = false\n\
2225: \\n\
2226: \ \n\
2227: \\n\
2228: \ exception Joinlists\n\
2229: \\n\
2230: \ val TestLexVList = \n\
2231: \ let fun f(a::a',b::b',r) = f(a',b',(a,b)::r)\n\
2232: \ | f(nil,nil,r) = rev r\n\
2233: \ | f _ = raise Joinlists\n\
2234: \ in f(ErrTermList,ErrValList,nil)\n\
2235: \ end\n\
2236: \\n\
2237: \ type Element = { term : G.Terminal, value : Value, stack : State list,\n\
2238: \ def_reduces : G.Attribute list, lineno : G.Lineno}\n\
2239: \\n\
2240: \ local \n\
2241: \ val print = output std_out\n\
2242: \ val println = fn s => (print s; print \"\\n\")\n\
2243: \ in\n\
2244: \ fun printStack(stack: State list, n: int) =\n\
2245: \ case stack\n\
2246: \ of (state) :: rest =>\n\
2247: \ (print(\" \" ^ makestring n ^ \": \");\n\
2248: \ println(showState state);\n\
2249: \ printStack(rest, n+1)\n\
2250: \ )\n\
2251: \ | nil => ()\n\
2252: \ \n\
2253: \ fun prAction(stack as (state) :: _, next, action) =\n\
2254: \ (println \"Parse: state stack:\";\n\
2255: \ printStack(stack, 0);\n\
2256: \ print(\" state=\"\n\
2257: \ ^ showState state \n\
2258: \ ^ \" next=\"\n\
2259: \ ^ showTerminalClass next\n\
2260: \ ^ \" action=\"\n\
2261: \ );\n\
2262: \ case action\n\
2263: \ of SHIFT state' =>\n\
2264: \ println(\"SHIFT \" ^ showState state')\n\
2265: \ | REDUCE(ATTRIB{lhs, ...}) =>\n\
2266: \ println(\"REDUCE \" ^ showNonterminal lhs)\n\
2267: \ | ERROR =>\n\
2268: \ println \"ERROR\";\n\
2269: \ action\n\
2270: \ )\n\
2271: \ | prAction (_,_,action) = action\n\
2272: \ end\n\
2273: \\n\
2274: \ \n\
2275: \\n\
2276: \ val pr_errln = error\n\
2277: \ val pr_err = error\n\
2278: \ \n\
2279: \\n\
2280: \ \n\
2281: \\n\
2282: \ fun parse lexer (MaxLookAhead,Size) = \n\
2283: \ let exception Remove\n\
2284: \ val MaxLookAhead = max(0,MaxLookAhead) \n\
2285: \ val Size = max(0,Size)\n\
2286: \\n\
2287: \ val ls = (ref nil) : ((Terminal * Value) * Lineno) list ref\n\
2288: \\n\
2289: \ val lexer = fn () =>\n\
2290: \ case (!ls) of\n\
2291: \ nil => (lexer(),!lineno)\n\
2292: \ | a::b => (ls := b; a)\n\
2293: \\n\
2294: \ \n\
2295: \\n\
2296: \ fun print_lookahead () = \n\
2297: \ (app (fn ((a:Terminal,_),_) => (print (showTerminalClass a); print \" \")) (!ls);\n\
2298: \ print \"\\n\")\n\
2299: \\n\
2300: \ fun remove (0,s) = s\n\
2301: \ | remove (n,a::b) = remove(n-1,b)\n\
2302: \ | remove _ = raise Remove\n\
2303: \\n\
2304: \ exception ParseStep\n\
2305: \ val FixError = ParseStep\n\
2306: \ exception psRemoveBind\n\
2307: \\n\
2308: \ exception Reduce\n\
2309: \\n\
2310: \ fun reduce(l,vs) =\n\
2311: \ fold (fn (ATTRIB{rhsLength,num,...},vs) =>\n\
2312: \ let val (nv,vs) = rule (num,vs)\n\
2313: \ in nv::vs\n\
2314: \ end) l vs\n\
2315: \\n\
2316: \\n\
2317: \ \n\
2318: \\n\
2319: \ fun fix_error(ss as (topstate :: _ ) : State list ,\n\
2320: \ (vs,oss) : (Value list * State list),\n\
2321: \ queue as (x,y) : (Element list * Element list),\n\
2322: \ reductions : G.Attribute list,\n\
2323: \ lexv as ((term,value),lineno),\n\
2324: \ c : int,\n\
2325: \ min_advance : int,\n\
2326: \ max_advance : int) =\n\
2327: \ let\n\
2328: \\n\
2329: \ val _ = pr_errln(\"syntax error found at \" ^\n\
2330: \ (showTerminalClass term)) lineno\n\
2331: \\n\
2332: \ val min_delta = 3\n\
2333: \\n\
2334: \ \n\
2335: \\n\
2336: \ val toklist = x@(rev ({term=term,value=value,lineno=lineno,\n\
2337: \ stack=oss,def_reduces=nil}::y))\n\
2338: \\n\
2339: \ \n\
2340: \\n\
2341: \ datatype Oper = INSERT | DELETE | SUBST of Terminal\n\
2342: \ datatype Change = CHANGE of {pos : int, distance : int,\n\
2343: \ term : Terminal, value : Value,\n\
2344: \ oper : Oper,lineno : Lineno}\n\
2345: \\n\
2346: \ val print_change = fn (CHANGE {pos,distance,term,value,oper,lineno}) =>\n\
2347: \ (print (\"{ pos= \" ^ (makestring pos));\n\
2348: \ print (\" dis= \" ^ (makestring distance));\n\
2349: \ print (\" term = \" ^ (showTerminalClass term));\n\
2350: \ print (\"oper= \" ^ (case oper\n\
2351: \ of INSERT => \"INSERT \"\n\
2352: \ | SUBST _ => \"SUBST \"\n\
2353: \ | DELETE => \"DELETE \"));\n\
2354: \\n\
2355: \ print \"}\\n\")\n\
2356: \\n\
2357: \ val print_cl = map print_change\n\
2358: \\n\
2359: \ \n\
2360: \\n\
2361: \ val ExtraTokens =\n\
2362: \ let fun f (t,0) = rev t\n\
2363: \ | f (t,n) =\n\
2364: \ let val (lexval as ((term,_),_)) = lexer()\n\
2365: \ in f(lexval::t,\n\
2366: \ if eqTerminal(term,eof) then 0 else n-1)\n\
2367: \ end\n\
2368: \ in f(nil,max_advance)\n\
2369: \ end\n\
2370: \\n\
2371: \ \n\
2372: \ \n\
2373: \\n\
2374: \ val LexValueList =\n\
2375: \ (map (fn ({term, value,lineno, ...} : Element) =>\n\
2376: \ ((term,value),lineno))\n\
2377: \ toklist) @ (ExtraTokens)\n\
2378: \\n\
2379: \ val TermList = map (fn ((a,_),l) => (a,l)) LexValueList\n\
2380: \\n\
2381: \ \n\
2382: \\n\
2383: \ exception parseTest\n\
2384: \ exception parseRemoveBind\n\
2385: \\n\
2386: \ fun parse (ss as (s :: _),tokenlist) =\n\
2387: \ (case tokenlist\n\
2388: \ of nil => 0\n\
2389: \ | (e as (a, _ ))::b => \n\
2390: \ (case Lr_Table.action(s,a)\n\
2391: \ of ERROR => length tokenlist\n\
2392: \ | (SHIFT s) => parse(s::ss,b)\n\
2393: \ | (REDUCE (ATTRIB {lhs,rhsLength, ...})) =>\n\
2394: \\n\
2395: \ \n\
2396: \\n\
2397: \ if eqNonterminal(lhs,start) then ~1\n\
2398: \ else case remove(rhsLength,ss)\n\
2399: \ of (ns as (ts :: _ )) =>\n\
2400: \ parse(goto(ts,lhs)::ns,e::b)\n\
2401: \ | _ => raise parseRemoveBind\n\
2402: \ )\n\
2403: \ )\n\
2404: \ | parse _ = raise parseTest\n\
2405: \\n\
2406: \ exception Rev_queue_fold\n\
2407: \\n\
2408: \ \n\
2409: \\n\
2410: \ fun rev_queue_fold (queue : 'b list,toklist : 'c list)\n\
2411: \ (g : (int * 'a * 'b list * 'c list) -> 'a)\n\
2412: \ (start : 'a) =\n\
2413: \\n\
2414: \ let fun f(count,results,nil,_) = results\n\
2415: \ | f(count,results,queue as (q :: q'),toklist as (t :: t')) = \n\
2416: \ f(count+1,g(count,results,queue,toklist),q',t')\n\
2417: \ | f _ = raise Rev_queue_fold\n\
2418: \ in f(0,start,queue,toklist)\n\
2419: \ end\n\
2420: \\n\
2421: \\n\
2422: \ \n\
2423: \\n\
2424: \ fun test (new_token_list :\n\
2425: \ (Terminal * Lineno) * ((Terminal * Lineno) list) ->\n\
2426: \ ((Terminal * Lineno) list),\n\
2427: \ oper : Oper) =\n\
2428: \ let fun test' (count,results, ({stack, ...} : Element) :: _,\n\
2429: \ tl as ((_,lineno) :: _)) =\n\
2430: \ List.fold (fn ((a,v),r) =>\n\
2431: \ let val tokens_left = parse(stack,new_token_list((a,lineno),tl))\n\
2432: \ in if tokens_left > (max_advance - min_advance) then r\n\
2433: \ else (CHANGE {pos=count,term=a,value=v,distance=tokens_left,\n\
2434: \ oper = oper,lineno=lineno})::r\n\
2435: \ end) TestLexVList results\n\
2436: \ in rev_queue_fold (toklist,TermList) test' nil\n\
2437: \ end\n\
2438: \ \n\
2439: \ val SubstChanges =\n\
2440: \ let fun test (count,results,({stack, term, ...} : Element) :: _,\n\
2441: \ (_,lineno) :: rest) =\n\
2442: \ let val max_left = max_advance - min_advance\n\
2443: \ in List.fold (fn ((a,v),r) =>\n\
2444: \ let val tokens_left = parse(stack,(a,lineno)::rest)\n\
2445: \ in if tokens_left > max_left then r\n\
2446: \ else (CHANGE {pos=count,term=a,value=v,distance=tokens_left,\n\
2447: \ oper=SUBST term,lineno=lineno})::r\n\
2448: \ end) TestLexVList results\n\
2449: \ end\n\
2450: \ in rev_queue_fold (toklist,TermList) test nil\n\
2451: \ end\n\
2452: \\n\
2453: \ val DeleteChanges = \n\
2454: \ let fun test(count,results,({term,value,stack, ...} : Element) :: _,\n\
2455: \ termlist as ((_,lineno) :: rest)) =\n\
2456: \ let val tokens_left = parse(stack,rest)\n\
2457: \ in if tokens_left > (max_advance - min_advance) then\n\
2458: \ results\n\
2459: \ else (CHANGE {pos=count,distance=tokens_left,term=term,\n\
2460: \ value=value,oper=DELETE,lineno=lineno}) :: results\n\
2461: \ end\n\
2462: \ in rev_queue_fold (toklist,TermList) test nil\n\
2463: \ end\n\
2464: \\n\
2465: \ val InsertChanges =\n\
2466: \ test ((fn (a,rest) => a::rest),INSERT)\n\
2467: \\n\
2468: \\n\
2469: \\n\
2470: \ local\n\
2471: \\n\
2472: \ fun sieve(a as (CHANGE {distance, ...}),b as (min,results)) =\n\
2473: \ if min>distance then (distance,[a])\n\
2474: \ else if min=distance then (min,a::results)\n\
2475: \ else b\n\
2476: \\n\
2477: \ fun sieve_list l = List.fold sieve l (max_advance,nil)\n\
2478: \\n\
2479: \ in\n\
2480: \\n\
2481: \ val (min1,DeleteChanges) = sieve_list DeleteChanges\n\
2482: \ val (min2,SubstChanges) = sieve_list SubstChanges\n\
2483: \ val (min3,InsertChanges) = sieve_list InsertChanges\n\
2484: \\n\
2485: \ val min0 = min(min(min1,min2),min3)\n\
2486: \\n\
2487: \ val DeleteChanges = if min1>min0 then nil else DeleteChanges\n\
2488: \ val SubstChanges = if min2>min0 then nil else SubstChanges\n\
2489: \ val InsertChanges = if min3>min0 then nil else InsertChanges\n\
2490: \\n\
2491: \ end\n\
2492: \\n\
2493: \ val _ = if DEBUG then\n\
2494: \ (print_cl InsertChanges; print_cl DeleteChanges;\n\
2495: \ print_cl SubstChanges; ())\n\
2496: \ else ()\n\
2497: \\n\
2498: \\n\
2499: \\n\
2500: \ val (InsertChanges,t) =\n\
2501: \ List.fold (fn (a as (CHANGE {term, ...}),(r,t)) => \n\
2502: \ if preferred_insert term then \n\
2503: \ if t then (a::r,t) else ([a],true)\n\
2504: \ else if t then (r,t) else (a::r,t)\n\
2505: \ ) InsertChanges (nil,false)\n\
2506: \\n\
2507: \ val (SubstChanges,t') =\n\
2508: \ List.fold (fn (a as (CHANGE {term=term,oper=SUBST t', ...}),(r,t)) =>\n\
2509: \ if List.exists (fn a=>eqTerminal(a,term)) (preferred_subst t') then\n\
2510: \ if t then (a::r,t) else ([a],true)\n\
2511: \ else if t then (r,t) else (a::r,t)\n\
2512: \ | (a,(r,t)) => (a::r,t) \n\
2513: \ ) SubstChanges (nil,false)\n\
2514: \\n\
2515: \\n\
2516: \\n\
2517: \ local val max_tokens = max_advance - (min_advance+min_delta)\n\
2518: \\n\
2519: \ val remove_keywords = fn l =>\n\
2520: \ List.fold (fn (a as (CHANGE {term,distance,...}),r) =>\n\
2521: \ if (is_keyword term) andalso (distance > max_tokens) then\n\
2522: \ r\n\
2523: \ else a::r) l nil\n\
2524: \\n\
2525: \ in\n\
2526: \\n\
2527: \ val InsertChanges =\n\
2528: \ if t then InsertChanges else remove_keywords InsertChanges\n\
2529: \ \n\
2530: \ val DeleteChanges = remove_keywords DeleteChanges\n\
2531: \\n\
2532: \ val SubstChanges =\n\
2533: \ if t' then SubstChanges else remove_keywords SubstChanges\n\
2534: \\n\
2535: \ end\n\
2536: \ val MinChanges =\n\
2537: \ let val ic = length InsertChanges\n\
2538: \ and dc = length DeleteChanges\n\
2539: \ and sc = length SubstChanges\n\
2540: \ in if ic=1 then SOME InsertChanges\n\
2541: \ else if dc=1 then SOME DeleteChanges\n\
2542: \ else if sc=1 then SOME SubstChanges\n\
2543: \ else if (min0 > (max_advance-(min_advance+min_delta))\n\
2544: \ orelse (ic+dc+sc)=0)\n\
2545: \ then NONE\n\
2546: \ else SOME (InsertChanges @ DeleteChanges @ SubstChanges)\n\
2547: \ end\n\
2548: \\n\
2549: \\n\
2550: \in case MinChanges \n\
2551: \ of (SOME l) =>\n\
2552: \ let fun print_msg (CHANGE {term, oper, lineno, ...}) =\n\
2553: \\n\
2554: \ let val s = \n\
2555: \ case oper\n\
2556: \ of DELETE => \"deleting \"\n\
2557: \ | INSERT => \"inserting \"\n\
2558: \ | SUBST t => \"replacing \" ^ (showTerminalClass t) ^\n\
2559: \ \" with \"\n\
2560: \ in pr_errln (s ^ (showTerminalClass term)) lineno\n\
2561: \ end\n\
2562: \ \n\
2563: \ val a = \n\
2564: \ if (length l > 1)\n\
2565: \ then (\n\
2566: \ if DEBUG then\n\
2567: \ (pr_errln \"multiple fixes possible: could fix it by\" lineno;\n\
2568: \ map print_msg l;\n\
2569: \ pr_errln \"fixing it with\" lineno\n\
2570: \ )\n\
2571: \ else ();\n\
2572: \ print_msg (hd l);\n\
2573: \ (hd l))\n\
2574: \ else (print_msg (hd l); (hd l))\n\
2575: \\n\
2576: \ val pos = (fn (CHANGE {pos, ...}) => pos) a\n\
2577: \ \n\
2578: \ fun f(0,q,termlist,rq',CHANGE {oper,term,value, lineno,\n\
2579: \ ...}) =\n\
2580: \ let val ({stack, ...} : Element) = hd(q)\n\
2581: \ in\n\
2582: \ (case oper\n\
2583: \ of DELETE =>\n\
2584: \ if eqTerminal(term,eof) then\n\
2585: \ (pr_errln \"EOF encountered: goodbye!\" lineno;\n\
2586: \ raise FixError)\n\
2587: \ else ls := (tl termlist) @ (!ls)\n\
2588: \ | (SUBST _) =>\n\
2589: \ ls := (((term,value),lineno)::(tl termlist)) @ (!ls)\n\
2590: \ | INSERT =>\n\
2591: \ ls := (((term,value),lineno)::termlist) @ (!ls));\n\
2592: \ parse_step(stack,(vs,stack),(rev rq',nil),nil,lexer(),\n\
2593: \ Size-pos)\n\
2594: \ end\n\
2595: \ | f(n,e :: r, _ :: termlist, rq',change) =\n\
2596: \ f(n-1,r,termlist,e::rq',change)\n\
2597: \ in f(pos,toklist,LexValueList,nil,a)\n\
2598: \ end\n\
2599: \ | NONE => if eqTerminal(term,eof) then\n\
2600: \ (pr_errln \"EOF encountered: goodbye!\" lineno;\n\
2601: \ raise FixError)\n\
2602: \ else\n\
2603: \ (raise FixError\n\
2604: \\n\
2605: \)\n\
2606: \ end\n\
2607: \\n\
2608: \ | fix_error _ = raise FixError\n\
2609: \ \n\
2610: \ and parse_step(ss as (topstate :: _ ),\n\
2611: \ v as (vs,oss),queue as (x,y),reductions,\n\
2612: \ lexv as ((term,value),lineno),c) =\n\
2613: \ (case (if DEBUG then prAction(ss, term,\n\
2614: \ Lr_Table.action (topstate,term))\n\
2615: \ else Lr_Table.action (topstate,term))\n\
2616: \ of SHIFT s =>\n\
2617: \ let val ss = s::ss\n\
2618: \ val ny = {value=value,def_reduces=reductions,\n\
2619: \ term=term,stack=oss,lineno=lineno}::y\n\
2620: \\n\
2621: \ in if c > 0 then\n\
2622: \ parse_step(ss,(vs,ss),(x,ny),nil,lexer(),c-1)\n\
2623: \ else (case x of nil =>\n\
2624: \ let val ({value,def_reduces, ...}::nx) = rev ny\n\
2625: \ in parse_step(ss,(value::(reduce(def_reduces,vs)),ss),\n\
2626: \ (nx,nil),nil, lexer(),c)\n\
2627: \ end\n\
2628: \ | ({value,def_reduces, ...}::b) =>\n\
2629: \ parse_step(ss,(value::(reduce(def_reduces,vs)),ss),\n\
2630: \ (b,ny),nil,lexer(),c))\n\
2631: \ end\n\
2632: \ | REDUCE (r as (ATTRIB {lhs,rhsLength , ...})) =>\n\
2633: \ if eqNonterminal(lhs,start) then\n\
2634: \ hd(reduce(r::reductions,\n\
2635: \ fold (fn ({value,def_reduces, ...} : Element,vs) =>\n\
2636: \ value::(reduce(def_reduces,vs))) (y@(rev x)) vs))\n\
2637: \ else (\n\
2638: \ case (remove(rhsLength,ss)) \n\
2639: \ of (ss as (ts :: _)) =>\n\
2640: \ (\n\
2641: \\n\
2642: \ parse_step(goto(ts,lhs)::ss,v,queue,\n\
2643: \ r::reductions,lexv,c)\n\
2644: \ )\n\
2645: \ | _ => raise psRemoveBind\n\
2646: \ )\n\
2647: \ \n\
2648: \ | ERROR => fix_error(ss,v,queue,reductions,lexv,c,1,MaxLookAhead))\n\
2649: \ | parse_step _ = raise ParseStep\n\
2650: \ in parse_step([initialState],(nil,[initialState]),\n\
2651: \ (nil,nil),nil,lexer(),Size) \n\
2652: \ end\n\
2653: \end\n\
2654: \"
2655: end
2656: structure Misc =
2657: struct
2658: structure G : V2_LR_GRAMMAR =
2659: struct
2660: datatype Terminal = T of int
2661: and Nonterminal = NT of int
2662:
2663: datatype Symbol = TERM of Terminal
2664: | NONTERM of Nonterminal
2665:
2666: datatype Attribute = ATTRIB of { lhs : Nonterminal,
2667: rhsLength : int,
2668: num : int
2669: }
2670: datatype Rule = RULE of {lhs : Nonterminal,
2671: rhs : Symbol list,
2672: attribute : Attribute,
2673: precedence : int option
2674: }
2675:
2676: val termHash = fn (T i) => i
2677: val nontermHash = fn (NT i) => i
2678: val eqTerminal = fn ((T i),(T i')) => i = i'
2679: val eqNonterminal = fn ((NT i),(NT i')) => i = i'
2680:
2681: val gtTerminal = fn ((T i),(T i')) => i > i'
2682: val gtNonterminal = fn ((NT i),(NT i')) => i > i'
2683: end
2684:
2685: structure MakeTable = V2_TableGen(structure G = G)
2686:
2687: type Lineno = int
2688: val lineno = ref 1
2689: val infile = ref "";
2690:
2691: val error = fn t => fn (l : Lineno) =>
2692: (output std_out ((!infile) ^ ", line " ^
2693: (makestring l) ^ ": " ^ t ^ "\n"))
2694:
2695: datatype LexValue = LEFT | RIGHT | NONASSOC
2696:
2697: type symbol = string
2698: type constr = string
2699: type ty = string list option
2700: type constr_data = {ty: ty,num : int}
2701:
2702: structure PrecSet = FullSet(struct
2703: type elem = (symbol * (int*LexValue))
2704: val gt = fn ((a:string,_),(a',_)) => a > a'
2705: val eq = fn ((a:string,_),(a',_)) => a = a'
2706: end
2707: )
2708:
2709: structure ConstrSet = FullSet(struct
2710: type elem = (constr * {ty : ty, num : int})
2711: val gt = fn ((a:string,_),(a',_)) => a > a'
2712: val eq = fn ((a:string,_),(a',_)) => a = a'
2713: end)
2714:
2715: type decl_data = {start : symbol option,
2716: prec : { d : PrecSet.set,
2717: h : int} option,
2718: nonterm : ConstrSet.set option,
2719: term : ConstrSet.set option,
2720: eof : symbol option,
2721: prefer : (symbol*symbol) list,
2722: iprefer : symbol list,
2723: keyword : symbol list,
2724: structure' : symbol option,
2725: verbose : bool}
2726:
2727: type rhs_data = {rhs:symbol list, code:string, prec: symbol option} list
2728: type rule = { lhs : symbol, rhs : symbol list,
2729: code : string, prec : symbol option }
2730:
2731: val out = ref std_out;
2732:
2733: val len = ref 0
2734: val indent = ref 0
2735: val tw = 4
2736: val inc_margin = fn () => indent := (!indent)+tw
2737: val dec_margin = fn () => indent := (!indent)-tw
2738: val reset_margin = fn () => indent := tw
2739: val err_flag = ref false
2740: (* The next line is bogus, it gets the wrong value of lineno *)
2741: val errmsg = fn x => (err_flag := true; error x (!lineno))
2742: val errln = errmsg
2743:
2744: val say = fn x => output (!out) x
2745:
2746: fun newln () =
2747: let fun f i = if i > 0 then (say " "; f (i-1)) else ()
2748: in (say "\n"; len := (!indent); f(!indent))
2749: end
2750:
2751: val sayln = fn (x : string) =>
2752: let val wl = size x
2753: val new_count = !len + wl
2754: in if (!len = 0 orelse new_count < 78)
2755: then (say x; newln())
2756: else (newln(); say x; newln())
2757: end
2758:
2759: val saywd = fn x : string =>
2760: let val wl = size x
2761: val new_count = !len + wl
2762: in if (!len = 0 orelse new_count < 78)
2763: then (len := new_count; say x)
2764: else (newln(); len := (!len) + wl; say x)
2765: end
2766:
2767: local
2768: fun add_nums(nil,i) = nil
2769: | add_nums ((c,{ty=t, ...} : constr_data)::r,i) =
2770: (c,{ty=t,num=i}) :: add_nums(r,i+1)
2771: in
2772: fun make_tok_dict (l as (_ :: _)) = SOME (ConstrSet.make_set (add_nums(l,0)))
2773: | make_tok_dict nil = NONE
2774: end
2775:
2776: fun save_prec (l as (_::_),parity) =
2777: SOME {d= PrecSet.make_set (map (fn a => (a,(1,parity))) l), h=3}
2778: | save_prec _ = NONE
2779:
2780: fun join_decls {start=a, prec=b, nonterm=c, term=d,eof=e,
2781: iprefer=f,prefer=g,keyword=h,structure'=k,verbose=verbose}
2782: {start=a',prec=b',nonterm=c',term=d',eof=e',
2783: iprefer=f',prefer=g',keyword=h',structure'=k',
2784: verbose=verbose'} =
2785:
2786: let fun j (f,NONE,NONE) = NONE
2787: | j (f,a,NONE) = a
2788: | j (f,NONE,a) = a
2789: | j (f,SOME i,SOME j) = f(i,j)
2790:
2791: fun join e = fn(i,j) =>
2792: (errln ("ignoring duplicate "^e^" declaration"); SOME i)
2793:
2794: fun join_prec({d=t,h=h},{d=t',h=h'}) =
2795: let fun f ((e as (a,(_,p))),t) =
2796: if (PrecSet.exists e t) then
2797: (errln ("ignoring duplicate %prec definition of" ^ a); t)
2798: else (PrecSet.insert (a,(h+1,p)) t)
2799: in SOME {d = PrecSet.setfold f t' t,h=h+3}
2800: end
2801:
2802: in {start= j (join "start",a,a'),
2803: prec=j (join_prec,b,b'),
2804: term = j (join "%term",d,d'),
2805: nonterm = j (join "%nonterm",c,c'),
2806: eof = j (join "%eof",e,e'),
2807: iprefer=f'@f,
2808: prefer=g'@g,
2809: keyword=h'@h,
2810: structure' = j (join "%structure",k,k'),
2811: verbose = verbose orelse verbose'}
2812: end
2813:
2814: local fun print_bool_case (l : string list) =
2815: (sayln "fn t => ";
2816: sayln "case t";
2817: saywd "of ";
2818: List.app (fn s => (saywd s; sayln " => true"; saywd " | ")) l;
2819: sayln "_ => false"
2820: )
2821:
2822: in fun print_is_keyword_func (l : string list) =
2823: (sayln "val is_keyword =";
2824: print_bool_case l)
2825:
2826: and print_preferred_insert_func (l : string list) =
2827: (sayln "val preferred_insert =";
2828: print_bool_case l)
2829:
2830: and print_preferred_subst_func (l : (string*(string list)) list) =
2831: (sayln "val preferred_subst = fn t =>";
2832: sayln "case t";
2833: saywd "of ";
2834: List.app (fn (a,l') =>
2835: (saywd a; saywd " => ";
2836: List.app (fn s => (saywd s; saywd "::")) l';
2837: sayln "nil"; saywd "| "
2838: )
2839: ) l;
2840: sayln " _ => nil"
2841: )
2842: end
2843:
2844: fun printConstrSet(constr_set,name,only_with_values) =
2845: let val _ = (inc_margin(); inc_margin(); inc_margin();
2846: saywd ("datatype " ^ name ^ " = "))
2847: val printed_something =
2848: ConstrSet.revsetfold (fn ((s,{ty=d,...}),result) =>
2849: (if only_with_values then
2850: (case d
2851: of NONE => result
2852: | SOME t =>
2853: (if result then saywd " | " else ();
2854: saywd s;
2855: saywd " of ";
2856: List.app saywd t;
2857: true
2858: )
2859: )
2860: else
2861: (if result then saywd " | " else ();
2862: saywd s;
2863: case d
2864: of NONE => ()
2865: | SOME t => (saywd " of "; List.app saywd t);
2866: true
2867: )
2868: )
2869: ) constr_set false;
2870: in (dec_margin(); dec_margin(); dec_margin(); sayln "";
2871: printed_something)
2872: end
2873:
2874: fun PrConstructors(n,t) =
2875: (saywd ("datatype "^n^ " = ");
2876: ConstrSet.revsetfold( fn ((s,_),r) =>
2877: (if r then saywd " | " else (); saywd s; true)) t false;
2878: newln())
2879:
2880: val make_parser = fn (HEADER : string, MPC_DECLS : decl_data,
2881: TRULELIST : rule list) =>
2882: (let exception SemanticError
2883: in let val ({start=start,prec=p,nonterm=nt,term=t,eof=eof,
2884: prefer=prefer,iprefer=iprefer,keyword=keyword,
2885: structure'=structure',verbose=verbose}) = MPC_DECLS
2886:
2887: val p = case p of NONE => PrecSet.empty | SOME {d,h} => d
2888:
2889: val _ = (let val f = fn d => errln("missing "^d^" definition")
2890: in (case t of NONE => f "%term" | _ => ();
2891: case nt of NONE => f "%nonterm" | _ => ())
2892: end);
2893:
2894: val nonterms =
2895: case nt of SOME i => i
2896: | NONE => raise SemanticError
2897:
2898: val terms = case t of SOME i => i
2899: | NONE => raise SemanticError
2900:
2901: val dummy_data = {ty = NONE,num = 0}
2902: val is_term = fn a => ConstrSet.exists (a,dummy_data) terms
2903: val is_nonterm = fn a => ConstrSet.exists (a,dummy_data) nonterms
2904:
2905: exception Get_type
2906: val get_type = fn (a,terms,nonterms) =>
2907: case (ConstrSet.find (a,dummy_data) terms)
2908: of NONE =>
2909: (case (ConstrSet.find (a,dummy_data) nonterms)
2910: of SOME (_,{ty=t,...}) => t
2911: | _ => raise Get_type)
2912: | SOME (_,{ty=t,...}) => t
2913:
2914: val get_prec = fn a =>
2915: case PrecSet.find (a,(0,LEFT)) p
2916: of NONE => NONE
2917: | SOME (_,(a,_)) => SOME a
2918:
2919: val _ = PrecSet.app
2920: (fn (s,_) =>
2921: if is_term s then ()
2922: else errln (s^" in %prec is not defined as a token")
2923: ) p
2924:
2925: val start =
2926: case start
2927: of NONE => start
2928: | SOME i =>
2929: if is_nonterm i then start
2930: else (errln
2931: (i ^ " in %start is not defined as a nonterminal"); NONE)
2932:
2933: val eof = case eof
2934: of NONE =>(errln ("missing %eof definition"); "")
2935: | SOME i =>
2936: if is_term i then i
2937: else (errln (i ^ " in %eof is not defined as a nonterminal"); "")
2938:
2939: fun make_unique_id s =
2940: if (is_term s) orelse (is_nonterm s) then make_unique_id (s ^ "'")
2941: else s
2942: val void = make_unique_id "mlyVOID"
2943:
2944: local
2945: val dummy_start = make_unique_id "mlySTART"
2946: val nontermlist = rev (map (fn {lhs=lhs : symbol,...} => lhs) TRULELIST)
2947: val start = case start of NONE => (hd nontermlist) | SOME a => a
2948: val dummy_type = get_type(start,terms,nonterms)
2949: val code = case dummy_type of NONE => "" | _ => start
2950: in
2951: val nonterms = ConstrSet.insert (dummy_start,
2952: {ty=dummy_type,num=ConstrSet.card nonterms}) nonterms
2953: val is_nonterm = fn a => ConstrSet.exists (a,dummy_data) nonterms
2954: val TRULELIST={lhs=dummy_start,rhs=[start],code=code,prec=NONE}::
2955: TRULELIST
2956: val start=dummy_start
2957: end
2958:
2959: val (keyword, iprefer) =
2960: let val f = fn x =>
2961: fn (a,r) =>
2962: if (is_term a) then a::r
2963: else (errln (a^" in "^x^" is not defined as a terminal"); r)
2964: in (List.fold (f "%keyword") keyword nil,
2965: List.fold (f "%insert_prefer") iprefer nil)
2966: end
2967:
2968: val prefer =
2969: let val print_err =
2970: fn s => errln (s^" in %prefer is not defined as a terminal")
2971: val f = fn (pair as (a,a'),r) =>
2972: let val flag =
2973: if (is_term a) then false else (print_err a; true)
2974: val flag' =
2975: if (is_term a') then false else (print_err a'; true)
2976: in if (flag orelse flag') then r else (pair::r)
2977: end
2978: in List.fold f prefer nil
2979: end
2980:
2981: (* prefer_map : take list of (sym,sym') where sym is a preferred
2982: substitution for sym', make list of (sym,[ ... syms]) where
2983: elements in the list are all the preferred substitutions for some
2984: sym *)
2985:
2986: val prefer_map =
2987: let
2988: (* take prefer list, second elem of pair, return list of elems
2989: in prefer list w/ same second elem, prefer list - list of
2990: elems *)
2991:
2992: fun g (prefer_list,second_elem) =
2993: List.fold (fn (e as (f,s),(same,differ)) =>
2994: if s=second_elem then (f::same,differ) else (same,e::differ))
2995: prefer_list (nil,nil)
2996:
2997: fun f(nil,prefer_map) = prefer_map
2998: | f(l as (e as (_,s):: _),prefer_map) =
2999: let val (same,differ) = g(l,s)
3000: in f(differ,(s,same)::prefer_map)
3001: end
3002:
3003: in f(prefer,nil)
3004: end
3005:
3006: val _ =
3007: ConstrSet.app (fn (s,_) =>
3008: if is_term s andalso is_nonterm s
3009: then errln (s ^ " is defined as a nonterminal and a terminal")
3010: else ()) terms
3011:
3012: val both = ConstrSet.union(terms,nonterms)
3013:
3014: val _ =
3015: let fun undef s =
3016: if (is_term s orelse is_nonterm s) then ()
3017: else (errln (s ^" is not defined as a terminal or nonterminal"))
3018:
3019: fun undef' s =
3020: if is_nonterm s then ()
3021: else (errln (s ^ " is not defined as a nonterminal"))
3022:
3023: fun check_rule {lhs,rhs,code,prec} = (map undef rhs; undef' lhs)
3024:
3025: in map check_rule TRULELIST
3026: end
3027:
3028: in if (!err_flag = false) then
3029: (MLY_MAKE_PARSER.print_parser say;
3030: reset_margin();
3031: sayln ("structure " ^
3032: (case structure'
3033: of NONE => "C"
3034: | SOME i => i) ^
3035: " = ");
3036: inc_margin();
3037: sayln "struct";
3038: inc_margin();
3039:
3040: (* print HDR structure *)
3041:
3042: sayln "structure HDR =";
3043: inc_margin();
3044: sayln "struct";
3045: say HEADER;
3046: dec_margin();
3047: sayln "";
3048: dec_margin();
3049: sayln "end";
3050:
3051: (* print V structure *)
3052:
3053: inc_margin();
3054: sayln "structure V =";
3055: inc_margin();
3056: sayln "struct";
3057: sayln "open HDR;";
3058:
3059: (* printConstrSet returns true if it printed at least
3060: one constructor *)
3061:
3062: if (printConstrSet(both,"Value",true)=true)
3063: then say " | "
3064: else ();
3065: sayln void;
3066: dec_margin();
3067: sayln "";
3068: dec_margin();
3069: sayln "end";
3070:
3071: (* print LexValue structure *)
3072:
3073: inc_margin();
3074: sayln "structure LexValue =";
3075: inc_margin();
3076: sayln "struct";
3077: sayln "open HDR;";
3078: printConstrSet(terms,"V",false);
3079: dec_margin();
3080: sayln "";
3081: dec_margin();
3082: sayln "end";
3083:
3084: (* print G (the grammar) structure *)
3085:
3086: inc_margin();
3087: sayln "structure G =";
3088: inc_margin();
3089: sayln "struct";
3090: sayln
3091: "\tdatatype Terminal = T of int\n\
3092: \\tand Nonterminal = NT of int\n\
3093: \\n\
3094: \\tval eqTerminal = fn ((T i),(T i')) => i = i'\n\
3095: \\tval eqNonterminal = fn ((NT i),(NT i')) => i = i'";
3096:
3097: saywd "datatype Symbol = TERM of Terminal | ";
3098: sayln "NONTERM of Nonterminal";
3099: newln();
3100:
3101: let fun showSymbol(s,t,constr) =
3102: (sayln ("fun "^s^" t = ");
3103: sayln "case t"; saywd "of ";
3104: ConstrSet.app
3105: (fn (nt,{num,...}) =>
3106: ( say constr;
3107: say (makestring num);
3108: say " => ";
3109: sayln ("\""^nt^"\"");
3110: say " | "
3111: )
3112: ) t;
3113: sayln "_ => \"bogus\"";
3114: newln)
3115: in (showSymbol ("showTerminalClass",terms,"T ");
3116: showSymbol ("showNonterminal",nonterms,"NT "))
3117: end;
3118:
3119: sayln "fun showTerminalValue t = showTerminalClass t";
3120: newln();
3121:
3122: sayln "type Lineno = HDR.Lineno";
3123: sayln "val lineno = HDR.lineno";
3124: sayln "val error = HDR.error";
3125:
3126: saywd "datatype Attribute = ATTRIB of {lhs: Nonterminal,";
3127: sayln "rhsLength: int, num: int }";
3128: newln();
3129: saywd "fun showAttribute(ATTRIB{lhs,...}) =" =
3130: sayln "showNonterminal lhs";
3131: newln();
3132: saywd "datatype Rule = RULE of {lhs:Nonterminal,";
3133: saywd "rhs: Symbol list,";
3134: saywd "attribute : Attribute,";
3135: sayln "precedence : int option }";
3136: newln() ;
3137: saywd "val ErrTermList=";
3138: ConstrSet.app
3139: (fn (x,{ty=NONE,num}) =>
3140: if x=eof then ()
3141: else saywd ("(T " ^ (makestring num) ^ ")::")
3142: | _ => ()) terms;
3143: sayln "nil";
3144:
3145: (* invoke Table generator *)
3146:
3147: let
3148: exception TermNum
3149: exception NontermNum
3150: exception SymbolNum
3151:
3152: val get_term_num = fn t =>
3153: case ConstrSet.find (t,dummy_data) terms
3154: of NONE => raise TermNum
3155: | SOME (_,{num=num,...}) => num
3156:
3157: val get_nonterm_num = fn nt =>
3158: case ConstrSet.find (nt,dummy_data) nonterms
3159: of NONE => raise NontermNum
3160: | SOME (_,{num=num,...}) => num
3161:
3162: val get_symbol = fn s =>
3163: (G.TERM (G.T (get_term_num s)) handle TermNum =>
3164: (G.NONTERM (G.NT (get_nonterm_num s)))
3165: handle NontermNum => raise SymbolNum
3166: )
3167:
3168: val numTerminals = ConstrSet.card terms
3169: val numNonterminals = ConstrSet.card nonterms
3170:
3171: val showTerminalClass =
3172: let val b = array(numTerminals,"bogus")
3173: val f = fn (s,{num=num,...}:constr_data) =>
3174: update(b,num,s)
3175: val _ = ConstrSet.app f terms
3176: in fn (G.T i) => ((b sub i) handle _ => "bogus")
3177: end
3178:
3179: val showNonterminal =
3180: let val b = array(numNonterminals,"bogus")
3181: val f = fn (s,{num=num,...}:constr_data) =>
3182: update(b,num,s)
3183: val _ = ConstrSet.app f nonterms
3184: in fn (G.NT i) => ((b sub i) handle _ => "bogus")
3185: end
3186:
3187: val _ =
3188: (let val get_term_string = fn a =>
3189: "(T " ^ (makestring (get_term_num a)) ^ ")"
3190: in print_is_keyword_func (map get_term_string keyword);
3191: print_preferred_insert_func
3192: (map get_term_string iprefer);
3193: print_preferred_subst_func
3194: (map (fn (a,b) => ((get_term_string a),
3195: map get_term_string b))
3196: prefer_map);
3197: sayln ("val eof = " ^ (get_term_string eof))
3198: end;
3199: sayln ("val start = NT "^(makestring (get_nonterm_num start)));
3200: dec_margin();
3201: sayln "end"
3202: )
3203:
3204: val showTerminalValue = showTerminalClass
3205:
3206: val showAttribute = fn (G.ATTRIB {lhs,rhsLength,num}) =>
3207: showNonterminal lhs
3208:
3209: val eof = G.T (get_term_num eof)
3210: val start = G.NT (get_nonterm_num start)
3211:
3212: val termPrecedence =
3213: let val b = array(numTerminals,NONE)
3214: val f = fn (tk,(j:int,p)) =>
3215: let val prec =
3216: SOME (case p of NONASSOC => j
3217: | RIGHT => j+1
3218: | LEFT => j-1)
3219: in update(b,get_term_num tk,prec)
3220: end
3221: val _ = PrecSet.app f p
3222: in fn (G.T i) => b sub i
3223: end
3224:
3225: val (_,rules) =
3226: List.fold (fn ({lhs=lhs,rhs=rhs,code=_,prec},(n,r)) =>
3227: (let val newlhs = G.NT (get_nonterm_num lhs)
3228: val newrhs = map get_symbol rhs
3229: val newattrib =
3230: G.ATTRIB {lhs=newlhs,
3231: rhsLength=List.length rhs,
3232: num = n
3233: }
3234: val newprec =
3235: let fun f (a::b) =
3236: if (is_nonterm a) then f b else get_prec a
3237: | f nil = NONE
3238: in case prec
3239: of NONE => f (rev rhs)
3240: | SOME i => get_prec i
3241: end
3242: in (n+1,(G.RULE {lhs=newlhs,rhs=newrhs,
3243: attribute=newattrib,
3244: precedence=newprec})::r)
3245: end
3246: )) TRULELIST (0,nil)
3247:
3248: in MakeTable.mktable (!out)
3249: {rules=rules,verbose=verbose,
3250: eof = eof, start = start,
3251: termPrecedence = termPrecedence,
3252: showTerminalClass = showTerminalClass,
3253: showTerminalValue = showTerminalValue,
3254: showNonterminal = showNonterminal,
3255: showAttribute = showAttribute,
3256: numTerminals = numTerminals,
3257: numNonterminals = numNonterminals}
3258: end;
3259:
3260: (* Print R structure - actions for rules *)
3261:
3262: sayln "structure R = ";
3263: inc_margin();
3264: sayln "struct";
3265: saywd "val ErrValList = ";
3266: ConstrSet.app (fn (x,{ty=NONE,...}) =>
3267: if x=eof then ()
3268: else saywd ("(V." ^ void ^ ")::") | _ => ()) terms;
3269: sayln "nil";
3270:
3271: sayln "exception mlyRULE of int";
3272: sayln "fun rule(i,vl) =";
3273: sayln "let open HDR";
3274: sayln " val rule_array = arrayoflist(";
3275:
3276: let fun getconstr s =
3277: case (get_type(s,terms,nonterms))
3278: of NONE => NONE
3279: | SOME _ => SOME ("V."^s)
3280:
3281: (* prlist : print list of arguments for a function for a rule *)
3282:
3283: fun prlist rhs =
3284:
3285:
3286: (* f: list of symbols for rhs, list of pairs of (symbol,last # used)
3287: Takes a rhs symbol, finds the correct variable name (eg. the number
3288: to attach to it, and whether or not to have a variable w/o a number
3289: if the rhs symbol is used only once)
3290: *)
3291:
3292: let fun f(nil,l) = ()
3293: | f(t::rhs,l) =
3294:
3295: let
3296:
3297: fun g((e as (a,i))::b,r) =
3298: if a=t then ((a,i+1)::(b@r),t^(makestring (i+1)))
3299: else g(b,e::r)
3300: | g(nil,r) =
3301: if (List.exists (fn a=>a=t) rhs) then
3302: ((t,1)::r,"("^t^"1)")
3303: else ((t,1)::r,"("^t^" as "^t^"1)")
3304:
3305: val (newlist,var) = g(l,nil)
3306:
3307: in
3308:
3309: (f(rhs,newlist);
3310: saywd ("(" ^
3311: (case (getconstr t)
3312: of NONE => "_"
3313: | SOME i => ("(" ^ i ^ " " ^ var ^ ")")
3314: ) ^
3315: ")");
3316: saywd "::"
3317: )
3318: end
3319:
3320: in
3321: (f(rhs,nil); saywd "r672")
3322: end
3323:
3324: in
3325: List.fold (fn ({lhs,rhs,code,prec},n) =>
3326: ( saywd "(fn (";
3327: prlist rhs;
3328: saywd ") => ((";
3329:
3330: let val constr = getconstr lhs
3331: in case constr
3332: of SOME i => saywd i
3333: | NONE => ();
3334: saywd "(";
3335: saywd code;
3336: saywd ")";
3337: case constr
3338: of SOME i => ()
3339: | NONE => (saywd "; ";
3340: saywd ("V."^void)
3341: );
3342: sayln "),r672)";
3343: if (List.length rhs > 0) then
3344: (saywd " | _ => raise mlyRULE ";
3345: saywd (makestring (n:int))
3346: )
3347: else ();
3348: sayln ")"
3349: end; saywd "::"; n+1)) TRULELIST 0
3350: end;
3351: sayln "nil)";
3352: dec_margin();
3353: sayln "in (rule_array sub i) vl end";
3354: dec_margin();
3355: sayln "type Value = V.Value";
3356: say "val VOID = V.";
3357: sayln void;
3358: sayln "end";
3359: dec_margin();
3360:
3361: (* print P structure - contains parsing function *)
3362:
3363: sayln "structure P = ParserGen(structure Lr_Table = Lr_Table";
3364: dec_margin();
3365: sayln " structure RuleAction = R)";
3366: sayln "fun parse (lex : unit -> (LexValue.V)) i= ";
3367: inc_margin();
3368: saywd "(fn (";
3369: case (ConstrSet.find (start,dummy_data) nonterms) of
3370: SOME (_,{ty=SOME _,...})
3371: => (saywd "V."; saywd start; sayln " a) => a)")
3372: | _ => sayln "_) => ())";
3373: sayln "(P.parse (fn () => ";
3374: inc_margin();
3375: sayln "(case lex() of ";
3376: ConstrSet.setfold (fn ((x,{ty=constr,num}),result) =>
3377: (if result then () else saywd " | ";
3378: say "(LexValue."; say x;
3379: case constr
3380: of NONE => (say ") => (G.T ";
3381: say (makestring num);
3382: sayln ("," ^ "V." ^ void ^")"))
3383: | _ => (say " a) => (G.T ";
3384: say (makestring num);
3385: sayln ("," ^ "V." ^ x ^ " a)"));
3386: false))
3387: terms true;
3388: dec_margin(); dec_margin();
3389: sayln ")) i)";
3390: sayln "end";
3391: ()
3392: )
3393: else ()
3394: end handle SemanticError => ()
3395: end)
3396: end
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.