![[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.