1(* Modified by sweeks@acm.org on 2000-8-24. 2 * Ported to MLton. 3 *) 4type int = Int.int 5 6(* ML-Yacc Parser Generator (c) 1989, 1990 Andrew W. Appel, David R. Tarditi 7 * 8 * $Log$ 9 * Revision 1.1 2006/06/22 07:40:27 michaeln 10 * Add a MoscowML compilable implementation of MLyacc, using the MLton sources 11 * as the base. 12 * 13 * Revision 1.1.1.1 1998/04/08 18:40:17 george 14 * Version 110.5 15 * 16 * Revision 1.2 1997/07/25 16:01:29 jhr 17 * Fixed bug with long constructor names (#1237). 18 * 19# Revision 1.1.1.1 1997/01/14 01:38:06 george 20# Version 109.24 21# 22 * Revision 1.3 1996/05/30 18:05:09 dbm 23 * Made changes to generate code that conforms to the value restriction by 24 * lifting lets to locals in the code generated to define errtermvalue and action. 25 * 26 * Revision 1.2 1996/02/26 15:02:40 george 27 * print no longer overloaded. 28 * use of makestring has been removed and replaced with Int.toString .. 29 * use of IO replaced with TextIO 30 * 31 * Revision 1.1.1.1 1996/01/31 16:01:48 george 32 * Version 109 33 * 34 *) 35 36functor ParseGenFun(structure ParseGenParser : PARSE_GEN_PARSER 37 structure MakeTable : MAKE_LR_TABLE 38 structure Verbose : VERBOSE 39 structure PrintStruct : PRINT_STRUCT 40 41 sharing MakeTable.LrTable = PrintStruct.LrTable 42 sharing MakeTable.Errs = Verbose.Errs 43 44 structure Absyn : ABSYN 45 ) : PARSE_GEN = 46 struct 47 open Array List 48 infix 9 sub 49 structure Grammar = MakeTable.Grammar 50 structure Header = ParseGenParser.Header 51 52 open Header Grammar 53 54 (* approx. maximum length of a line *) 55 56 val lineLength: int = 70 57 58 (* record type describing names of structures in the program being 59 generated *) 60 61 datatype names = NAMES 62 of {miscStruct : string, (* Misc{n} struct name *) 63 tableStruct : string, (* LR table structure *) 64 tokenStruct : string, (* Tokens{n} struct name *) 65 actionsStruct : string, (* Actions structure *) 66 valueStruct: string, (* semantic value structure *) 67 ecStruct : string, (* error correction structure *) 68 arg: string, (* user argument for parser *) 69 tokenSig : string, (* TOKENS{n} signature *) 70 miscSig :string, (* Signature for Misc structure *) 71 dataStruct:string, (* name of structure in Misc *) 72 (* which holds parser data *) 73 dataSig:string (* signature for this structure *) 74 75 } 76 77 val DEBUG = true 78 exception Semantic 79 80 (* common functions and values used in printing out program *) 81 82 datatype values = VALS 83 of {say : string -> unit, 84 saydot : string -> unit, 85 sayln : string -> unit, 86 pureActions: bool, 87 pos_type : string, 88 arg_type : string, 89 ntvoid : string, 90 termvoid : string, 91 start : Grammar.nonterm, 92 hasType : Grammar.symbol -> bool, 93 94 (* actual (user) name of terminal *) 95 96 termToString : Grammar.term -> string, 97 symbolToString : Grammar.symbol -> string, 98 99 (* type symbol comes from the HDR structure, 100 and is now abstract *) 101 102 term : (Header.symbol * ty option) list, 103 nonterm : (Header.symbol * ty option) list, 104 terms : Grammar.term list, 105 106 (* tokenInfo is the user inserted spec in 107 the *_TOKEN sig*) 108 tokenInfo : string option} 109 110 structure SymbolHash = Hash(type elem = string 111 val gt = (op >) : string*string -> bool) 112 113 structure TermTable = Table(type key = Grammar.term 114 val gt = fn (T i,T j) => i > j) 115 116 structure SymbolTable = Table( 117 type key = Grammar.symbol 118 val gt = fn (TERM(T i),TERM(T j)) => i>j 119 | (NONTERM(NT i),NONTERM(NT j)) => i>j 120 | (NONTERM _,TERM _) => true 121 | (TERM _,NONTERM _) => false) 122 123 (* printTypes: function to print the following types in the LrValues 124 structure and a structure containing the datatype svalue: 125 126 type svalue -- it holds semantic values on the parse 127 stack 128 type pos -- the type of line numbers 129 type result -- the type of the value that results 130 from the parse 131 132 The type svalue is set equal to the datatype svalue declared 133 in the structure named by valueStruct. The datatype svalue 134 is declared inside the structure named by valueStruct to deal 135 with the scope of constructors. 136 *) 137 138 val printTypes = fn (VALS {say,sayln,term,nonterm,symbolToString,pos_type, 139 arg_type, 140 termvoid,ntvoid,saydot,hasType,start, 141 pureActions,...}, 142 NAMES {valueStruct,...},symbolType) => 143 let val prConstr = fn (symbol,SOME s) => 144 say (" | " ^ (symbolName symbol) ^ " of " ^ 145 (if pureActions then "" else "unit -> ") ^ 146 " (" ^ tyName s ^ ")" 147 ) 148 | _ => () 149 in sayln "local open Header in"; 150 sayln ("type pos = " ^ pos_type); 151 sayln ("type arg = " ^ arg_type); 152 sayln ("structure " ^ valueStruct ^ " = "); 153 sayln "struct"; 154 say ("datatype svalue = " ^ termvoid ^ " | " ^ ntvoid ^ " of" ^ 155 (if pureActions then "" else " unit -> ") ^ " unit"); 156 app prConstr term; 157 app prConstr nonterm; 158 sayln "\nend"; 159 sayln ("type svalue = " ^ valueStruct ^ ".svalue"); 160 say "type result = "; 161 case symbolType (NONTERM start) 162 of NONE => sayln "unit" 163 | SOME t => (say (tyName t); sayln ""); 164 sayln "end" 165 end 166 167 (* function to print Tokens{n} structure *) 168 169 val printTokenStruct = 170 fn (VALS {say, sayln, termToString, hasType,termvoid,terms, 171 pureActions,tokenInfo,...}, 172 NAMES {miscStruct,tableStruct,valueStruct, 173 tokenStruct,tokenSig,dataStruct,...}) => 174 (sayln ("structure " ^ tokenStruct ^ " : " ^ tokenSig ^ " ="); 175 sayln "struct"; 176 (case tokenInfo of 177 NONE => () 178 | _ => sayln ("open "^dataStruct^".Header")); 179 sayln ("type svalue = " ^ dataStruct ^ ".svalue"); 180 sayln "type ('a,'b) token = ('a,'b) Token.token"; 181 let val f = fn term as T i => 182 (say "fun "; say (termToString term); 183 say " ("; 184 if (hasType (TERM term)) then say "i," else (); 185 say "p1,p2) = Token.TOKEN ("; 186 say (dataStruct ^ "." ^ tableStruct ^ ".T "); 187 say (Int.toString i); 188 say ",("; 189 say (dataStruct ^ "." ^ valueStruct ^ "."); 190 if (hasType (TERM term)) then 191 (say (termToString term); 192 if pureActions then say " i" 193 else say " (fn () => i)") 194 else say termvoid; 195 say ","; 196 sayln "p1,p2))") 197 in app f terms 198 end; 199 sayln "end") 200 201 (* function to print signatures out - takes print function which 202 does not need to insert line breaks *) 203 204 val printSigs = fn (VALS {term,tokenInfo,...}, 205 NAMES {tokenSig,tokenStruct,miscSig, 206 dataStruct, dataSig, ...}, 207 say) => 208 say ("signature " ^ tokenSig ^ " =\nsig\n"^ 209 (case tokenInfo of NONE => "" | SOME s => (s^"\n"))^ 210 "type ('a,'b) token\ntype svalue\n" ^ 211 (List.foldr (fn ((s,ty),r) => String.concat [ 212 "val ", symbolName s, 213 (case ty 214 of NONE => ": " 215 | SOME l => ": (" ^ (tyName l) ^ ") * "), 216 " 'a * 'a -> (svalue,'a) token\n", r]) "" term) ^ 217 "end\nsignature " ^ miscSig ^ 218 "=\nsig\nstructure Tokens : " ^ tokenSig ^ 219 "\nstructure " ^ dataStruct ^ ":" ^ dataSig ^ 220 "\nsharing type " ^ dataStruct ^ 221 ".Token.token = Tokens.token\nsharing type " ^ 222 dataStruct ^ ".svalue = Tokens.svalue\nend\n") 223 224 (* function to print structure for error correction *) 225 226 val printEC = fn (keyword : term list, 227 preferred_change : (term list * term list) list, 228 noshift : term list, 229 value : (term * string) list, 230 VALS {termToString, say,sayln,terms,saydot,hasType, 231 termvoid,pureActions,...}, 232 NAMES {ecStruct,tableStruct,valueStruct,...}) => 233 let 234 235 val sayterm = fn (T i) => (say "(T "; say (Int.toString i); say ")") 236 237 val printBoolCase = fn ( l : term list) => 238 (say "fn "; 239 app (fn t => (sayterm t; say " => true"; say " | ")) l; 240 sayln "_ => false") 241 242 val printTermList = fn (l : term list) => 243 (app (fn t => (sayterm t; say " :: ")) l; sayln "nil") 244 245 fun printChange () = 246 (sayln "val preferred_change = "; 247 app (fn (d,i) => 248 (say"("; printTermList d; say ","; printTermList i; 249 sayln ")::" 250 ) 251 ) preferred_change; 252 sayln "nil") 253 254 val printErrValues = fn (l : (term * string) list) => 255 (sayln "local open Header in"; 256 sayln "val errtermvalue="; 257 say "fn "; 258 app (fn (t,s) => 259 (sayterm t; say " => "; 260 saydot valueStruct; say (termToString t); 261 say "("; 262 if pureActions then () else say "fn () => "; 263 say "("; say s; say "))"; 264 sayln " | " 265 ) 266 ) l; 267 say "_ => "; 268 say (valueStruct ^ "."); 269 sayln termvoid; sayln "end") 270 271 272 val printNames = fn () => 273 let val f = fn term => ( 274 sayterm term; say " => "; 275 sayln (String.concat["\"", termToString term, "\""]); 276 say " | ") 277 in (sayln "val showTerminal ="; 278 say "fn "; 279 app f terms; 280 sayln "_ => \"bogus-term\"") 281 end 282 283 val ecTerms = 284 List.foldr (fn (t,r) => 285 if hasType (TERM t) orelse exists (fn (a,_)=>a=t) value 286 then r 287 else t::r) 288 [] terms 289 290 in say "structure "; 291 say ecStruct; 292 sayln "="; 293 sayln "struct"; 294 say "open "; 295 sayln tableStruct; 296 sayln "val is_keyword ="; 297 printBoolCase keyword; 298 printChange(); 299 sayln "val noShift = "; 300 printBoolCase noshift; 301 printNames (); 302 printErrValues value; 303 say "val terms = "; 304 printTermList ecTerms; 305 sayln "end" 306 end 307 308val printAction = fn (rules, 309 VALS {hasType,say,sayln,termvoid,ntvoid, 310 symbolToString,saydot,start,pureActions,...}, 311 NAMES {actionsStruct,valueStruct,tableStruct,arg,...}) => 312let val printAbsynRule = Absyn.printRule(say,sayln) 313 val is_nonterm = fn (NONTERM i) => true | _ => false 314 val numberRhs = fn r => 315 List.foldl (fn (e,(r,table)) => 316 let val num = case SymbolTable.find(e,table) 317 of SOME i => i 318 | NONE => 1 319 in ((e,num,hasType e orelse is_nonterm e)::r, 320 SymbolTable.insert((e,num+1),table)) 321 end) (nil,SymbolTable.empty) r 322 323 val saySym = symbolToString 324 325 val printCase = fn (i:int, r as {lhs=lhs as (NT lhsNum),prec, 326 rhs,code,rulenum}) => 327 328 (* mkToken: Build an argument *) 329 330 let open Absyn 331 val mkToken = fn (sym,num : int,typed) => 332 let val symString = symbolToString sym 333 val symNum = symString ^ (Int.toString num) 334 in PTUPLE[WILD, 335 PTUPLE[if not (hasType sym) then 336 (if is_nonterm sym then 337 PAPP(valueStruct^"."^ntvoid, 338 PVAR symNum) 339 else WILD) 340 else 341 PAPP(valueStruct^"."^symString, 342 if num=1 andalso pureActions 343 then AS(PVAR symNum,PVAR symString) 344 else PVAR symNum), 345 if num=1 then AS(PVAR (symString^"left"), 346 PVAR(symNum^"left")) 347 else PVAR(symNum^"left"), 348 if num=1 then AS(PVAR(symString^"right"), 349 PVAR(symNum^"right")) 350 else PVAR(symNum^"right")]] 351 end 352 353 val numberedRhs = #1 (numberRhs rhs) 354 355 (* construct case pattern *) 356 357 val pat = PTUPLE[PINT i,PLIST(map mkToken numberedRhs @ 358 [PVAR "rest671"])] 359 360 (* remove terminals in argument list w/o types *) 361 362 val argsWithTypes = 363 List.foldr (fn ((_,_,false),r) => r 364 | (s as (_,_,true),r) => s::r) nil numberedRhs 365 366 (* construct case body *) 367 368 val defaultPos = EVAR "defaultPos" 369 val resultexp = EVAR "result" 370 val resultpat = PVAR "result" 371 val code = CODE code 372 val rest = EVAR "rest671" 373 374 val body = 375 LET([VB(resultpat, 376 EAPP(EVAR(valueStruct^"."^ 377 (if hasType (NONTERM lhs) 378 then saySym(NONTERM lhs) 379 else ntvoid)), 380 if pureActions then code 381 else if argsWithTypes=nil then FN(WILD,code) 382 else 383 FN(WILD, 384 let val body = 385 LET(map (fn (sym,num:int,_) => 386 let val symString = symbolToString sym 387 val symNum = symString ^ Int.toString num 388 in VB(if num=1 then 389 AS(PVAR symString,PVAR symNum) 390 else PVAR symNum, 391 EAPP(EVAR symNum,UNIT)) 392 end) (rev argsWithTypes), 393 code) 394 in if hasType (NONTERM lhs) then 395 body else SEQ(body,UNIT) 396 end)))], 397 ETUPLE[EAPP(EVAR(tableStruct^".NT"),EINT(lhsNum)), 398 case rhs 399 of nil => ETUPLE[resultexp,defaultPos,defaultPos] 400 | r =>let val (rsym,rnum,_) = hd(numberedRhs) 401 val (lsym,lnum,_) = hd(rev numberedRhs) 402 in ETUPLE[resultexp, 403 EVAR (symbolToString lsym ^ 404 Int.toString lnum ^ "left"), 405 EVAR (symbolToString rsym ^ 406 Int.toString rnum ^ "right")] 407 end, 408 rest]) 409 in printAbsynRule (RULE(pat,body)) 410 end 411 412 val prRules = fn () => 413 (sayln "fn (i392:int,defaultPos,stack,"; 414 say " ("; say arg; sayln "):arg) =>"; 415 sayln "case (i392,stack)"; 416 say "of "; 417 app (fn (rule as {rulenum,...}) => 418 (printCase(rulenum,rule); say "| ")) rules; 419 sayln "_ => raise (mlyAction i392)") 420 421 in say "structure "; 422 say actionsStruct; 423 sayln " ="; 424 sayln "struct "; 425 sayln "type int = Int.int"; 426 sayln "exception mlyAction of int"; 427 sayln "local open Header in"; 428 sayln "val actions = "; 429 prRules(); 430 sayln "end"; 431 say "val void = "; 432 saydot valueStruct; 433 sayln termvoid; 434 say "val extract = "; 435 say "fn a => (fn "; 436 saydot valueStruct; 437 if hasType (NONTERM start) 438 then say (symbolToString (NONTERM start)) 439 else say "ntVOID"; 440 sayln " x => x"; 441 sayln "| _ => let exception ParseInternal"; 442 say "\tin raise ParseInternal end) a "; 443 sayln (if pureActions then "" else "()"); 444 sayln "end" 445 end 446 447 val make_parser = fn ((header, 448 DECL {eop,change,keyword,nonterm,prec, 449 term, control,value} : declData, 450 rules : rule list),spec,error : pos -> string -> unit, 451 wasError : unit -> bool) => 452 let 453 val verbose = List.exists (fn VERBOSE=>true | _ => false) control 454 val defaultReductions = not (List.exists (fn NODEFAULT=>true | _ => false) control) 455 val pos_type = 456 let fun f nil = NONE 457 | f ((POS s)::r) = SOME s 458 | f (_::r) = f r 459 in f control 460 end 461 val start = 462 let fun f nil = NONE 463 | f ((START_SYM s)::r) = SOME s 464 | f (_::r) = f r 465 in f control 466 end 467 val name = 468 let fun f nil = NONE 469 | f ((PARSER_NAME s)::r) = SOME s 470 | f (_::r) = f r 471 in f control 472 end 473 val header_decl = 474 let fun f nil = NONE 475 | f ((FUNCTOR s)::r) = SOME s 476 | f (_::r) = f r 477 in f control 478 end 479 480 val token_sig_info_decl = 481 let fun f nil = NONE 482 | f ((TOKEN_SIG_INFO s)::_) = SOME s 483 | f (_::r) = f r 484 in f control 485 end 486 487 val arg_decl = 488 let fun f nil = ("()","unit") 489 | f ((PARSE_ARG s)::r) = s 490 | f (_::r) = f r 491 in f control 492 end 493 494 val noshift = 495 let fun f nil = nil 496 | f ((NSHIFT s)::r) = s 497 | f (_::r) = f r 498 in f control 499 end 500 501 val pureActions = 502 let fun f nil = false 503 | f ((PURE)::r) = true 504 | f (_::r) = f r 505 in f control 506 end 507 508 val term = 509 case term 510 of NONE => (error 1 "missing %term definition"; nil) 511 | SOME l => l 512 513 val nonterm = 514 case nonterm 515 of NONE => (error 1 "missing %nonterm definition"; nil) 516 | SOME l => l 517 518 val pos_type = 519 case pos_type 520 of NONE => (error 1 "missing %pos definition"; "") 521 | SOME l => l 522 523 524 val termHash = 525 List.foldr (fn ((symbol,_),table) => 526 let val name = symbolName symbol 527 in if SymbolHash.exists(name,table) then 528 (error (symbolPos symbol) 529 ("duplicate definition of " ^ name ^ " in %term"); 530 table) 531 else SymbolHash.add(name,table) 532 end) SymbolHash.empty term 533 534 val isTerm = fn name => SymbolHash.exists(name,termHash) 535 536 val symbolHash = 537 List.foldr (fn ((symbol,_),table) => 538 let val name = symbolName symbol 539 in if SymbolHash.exists(name,table) then 540 (error (symbolPos symbol) 541 (if isTerm name then 542 name ^ " is defined as a terminal and a nonterminal" 543 else 544 "duplicate definition of " ^ name ^ " in %nonterm"); 545 table) 546 else SymbolHash.add(name,table) 547 end) termHash nonterm 548 549 fun makeUniqueId s = 550 if SymbolHash.exists(s,symbolHash) then makeUniqueId (s ^ "'") 551 else s 552 553 val _ = if wasError() then raise Semantic else () 554 555 val numTerms = SymbolHash.size termHash 556 val numNonterms = SymbolHash.size symbolHash - numTerms 557 558 val symError = fn sym => fn err => fn symbol => 559 error (symbolPos symbol) 560 (symbolName symbol^" in "^err^" is not defined as a " ^ sym) 561 562 val termNum : string -> Header.symbol -> term = 563 let val termError = symError "terminal" 564 in fn stmt => 565 let val stmtError = termError stmt 566 in fn symbol => 567 case SymbolHash.find(symbolName symbol,symbolHash) 568 of NONE => (stmtError symbol; T ~1) 569 | SOME i => T (if i<numTerms then i 570 else (stmtError symbol; ~1)) 571 end 572 end 573 574 val nontermNum : string -> Header.symbol -> nonterm = 575 let val nontermError = symError "nonterminal" 576 in fn stmt => 577 let val stmtError = nontermError stmt 578 in fn symbol => 579 case SymbolHash.find(symbolName symbol,symbolHash) 580 of NONE => (stmtError symbol; NT ~1) 581 | SOME i => if i>=numTerms then NT (i-numTerms) 582 else (stmtError symbol;NT ~1) 583 end 584 end 585 586 val symbolNum : string -> Header.symbol -> Grammar.symbol = 587 let val symbolError = symError "symbol" 588 in fn stmt => 589 let val stmtError = symbolError stmt 590 in fn symbol => 591 case SymbolHash.find(symbolName symbol,symbolHash) 592 of NONE => (stmtError symbol; NONTERM (NT ~1)) 593 | SOME i => if i>=numTerms then NONTERM(NT (i-numTerms)) 594 else TERM(T i) 595 end 596 end 597 598(* map all symbols in the following values to terminals and check that 599 the symbols are defined as terminals: 600 601 eop : symbol list 602 keyword: symbol list 603 prec: (lexvalue * (symbol list)) list 604 change: (symbol list * symbol list) list 605*) 606 607 val eop = map (termNum "%eop") eop 608 val keyword = map (termNum "%keyword") keyword 609 val prec = map (fn (a,l) => 610 (a,case a 611 of LEFT => map (termNum "%left") l 612 | RIGHT => map (termNum "%right") l 613 | NONASSOC => map (termNum "%nonassoc") l 614 )) prec 615 val change = 616 let val mapTerm = termNum "%prefer, %subst, or %change" 617 in map (fn (a,b) => (map mapTerm a, map mapTerm b)) change 618 end 619 val noshift = map (termNum "%noshift") noshift 620 val value = 621 let val mapTerm = termNum "%value" 622 in map (fn (a,b) => (mapTerm a,b)) value 623 end 624 val (rules,_) = 625 let val symbolNum = symbolNum "rule" 626 val nontermNum = nontermNum "rule" 627 val termNum = termNum "%prec tag" 628 in List.foldr 629 (fn (RULE {lhs,rhs,code,prec},(l,n)) => 630 ( {lhs=nontermNum lhs,rhs=map symbolNum rhs, 631 code=code,prec=case prec 632 of NONE => NONE 633 | SOME t => SOME (termNum t), 634 rulenum=n}::l,n-1)) 635 (nil,length rules-1) rules 636 end 637 638 val _ = if wasError() then raise Semantic else () 639 640 (* termToString: map terminals back to strings *) 641 642 val termToString = 643 let val data = array(numTerms,"") 644 val unmap = fn (symbol,_) => 645 let val name = symbolName symbol 646 in update(data, 647 case SymbolHash.find (name,symbolHash) of 648 NONE => raise Fail "termToString" 649 | SOME i => i, 650 name) 651 end 652 val _ = app unmap term 653 in fn T i => 654 if DEBUG andalso (i<0 orelse i>=numTerms) 655 then "bogus-num" ^ (Int.toString i) 656 else data sub i 657 end 658 659 val nontermToString = 660 let val data = array(numNonterms,"") 661 val unmap = fn (symbol,_) => 662 let val name = symbolName symbol 663 in update(data, 664 case SymbolHash.find (name,symbolHash) of 665 NONE => raise Fail "nontermToString" 666 | SOME i => i-numTerms, 667 name) 668 end 669 val _ = app unmap nonterm 670 in fn NT i => 671 if DEBUG andalso (i<0 orelse i>=numNonterms) 672 then "bogus-num" ^ (Int.toString i) 673 else data sub i 674 end 675 676(* create functions mapping terminals to precedence numbers and rules to 677 precedence numbers. 678 679 Precedence statements are listed in order of ascending (tighter binding) 680 precedence in the specification. We receive a list composed of pairs 681 containing the kind of precedence (left,right, or assoc) and a list of 682 terminals associated with that precedence. The list has the same order as 683 the corresponding declarations did in the specification. 684 685 Internally, a tighter binding has a higher precedence number. We give 686 precedences using multiples of 3: 687 688 p+2 = right associative (force shift of symbol) 689 p+1 = precedence for rule 690 p = left associative (force reduction of rule) 691 692 Nonassociative terminals are given also given a precedence of p+1. The 693table generator detects when the associativity of a nonassociative terminal 694is being used to resolve a shift/reduce conflict by checking if the 695precedences of the rule and the terminal are equal. 696 697 A rule is given the precedence of its rightmost terminal *) 698 699 val termPrec = 700 let val precData = array(numTerms, NONE : int option) 701 val addPrec = fn termPrec => fn term as (T i) => 702 case precData sub i 703 of SOME _ => 704 error 1 ("multiple precedences specified for terminal " ^ 705 (termToString term)) 706 | NONE => update(precData,i,termPrec) 707 val termPrec = fn ((LEFT,_) ,i) => i 708 | ((RIGHT,_),i) => i+2 709 | ((NONASSOC,l),i) => i+1 710 val _ = List.foldl (fn (args as ((_,l),i)) => 711 (app (addPrec (SOME (termPrec args))) l; i+3)) 712 0 prec 713 in fn (T i) => 714 if DEBUG andalso (i < 0 orelse i >= numTerms) then 715 NONE 716 else precData sub i 717 end 718 719 val elimAssoc = fn i => (i - (i mod 3) + 1) 720 val rulePrec = 721 let fun findRightTerm (nil,r) = r 722 | findRightTerm (TERM t :: tail,r) = 723 findRightTerm(tail,SOME t) 724 | findRightTerm (_ :: tail,r) = findRightTerm(tail,r) 725 in fn rhs => 726 case findRightTerm(rhs,NONE) 727 of NONE => NONE 728 | SOME term => 729 case termPrec term 730 of SOME i => SOME (elimAssoc i) 731 | a => a 732 end 733 734 val grammarRules = 735 let val conv = fn {lhs,rhs,code,prec,rulenum} => 736 {lhs=lhs,rhs =rhs,precedence= 737 case prec 738 of SOME t => (case termPrec t 739 of SOME i => SOME(elimAssoc i) 740 | a => a) 741 | _ => rulePrec rhs, 742 rulenum=rulenum} 743 in map conv rules 744 end 745 746 (* get start symbol *) 747 748 val start = 749 case start 750 of NONE => #lhs (hd grammarRules) 751 | SOME name => 752 nontermNum "%start" name 753 754 val symbolType = 755 let val data = array(numTerms+numNonterms,NONE : ty option) 756 val unmap = 757 fn (symbol,ty) => 758 update (data, 759 case SymbolHash.find(symbolName symbol,symbolHash) of 760 NONE => raise Fail "unmap" 761 | SOME i => i, 762 ty) 763 val _ = (app unmap term; app unmap nonterm) 764 in fn NONTERM(NT i) => 765 if DEBUG andalso (i<0 orelse i>=numNonterms) 766 then NONE 767 else data sub (i+numTerms) 768 | TERM (T i) => 769 if DEBUG andalso (i<0 orelse i>=numTerms) 770 then NONE 771 else data sub i 772 end 773 774 val symbolToString = 775 fn NONTERM i => nontermToString i 776 | TERM i => termToString i 777 778 val grammar = GRAMMAR {rules=grammarRules, 779 terms=numTerms,nonterms=numNonterms, 780 eop = eop, start=start,noshift=noshift, 781 termToString = termToString, 782 nontermToString = nontermToString, 783 precedence = termPrec} 784 785 (* Debugging output added by sweeks@acm.org. *) 786 val _ = 787 if false 788 then 789 (List.foldl 790 (fn ({lhs, rhs, rulenum, ...}, i) => 791 (print (String.concat [Int.toString rulenum, ": ", 792 nontermToString lhs, " ->"]) 793 ; List.app (fn s => (print (String.concat 794 [" ", symbolToString s]))) rhs 795 ; print "\n" 796 ; i + 1)) 797 0 grammarRules 798 ; ()) 799 else () 800 801 val name' = case name 802 of NONE => "" 803 | SOME s => symbolName s 804 805 val names = NAMES {miscStruct=name' ^ "LrValsFun", 806 valueStruct="MlyValue", 807 tableStruct="LrTable", 808 tokenStruct="Tokens", 809 actionsStruct="Actions", 810 ecStruct="EC", 811 arg= #1 arg_decl, 812 tokenSig = name' ^ "_TOKENS", 813 miscSig = name' ^ "_LRVALS", 814 dataStruct = "ParserData", 815 dataSig = "PARSER_DATA"} 816 817 val (table,stateErrs,corePrint,errs) = 818 MakeTable.mkTable(grammar,defaultReductions) 819 820 val entries = ref 0 (* save number of action table entries here *) 821 822 in let val result = TextIO.openOut (spec ^ ".sml") 823 val sigs = TextIO.openOut (spec ^ ".sig") 824 val pos = ref 0 825 val trailing_space = ref false 826 val pr = fn s => TextIO.output(result,s) 827 fun say s = let 828 val l = String.size s 829 val sspace = l > 0 andalso Char.isSpace (String.sub(s,l - 1)) 830 val s = 831 if sspace then 832 Substring.string(Substring.dropr Char.isSpace (Substring.full s)) 833 else s 834 val newPos = (!pos) + size s 835 in 836 if 0 < l then 837 (if newPos > lineLength then (pr "\n"; pos := l) 838 else if !trailing_space then (pr " "; pos := newPos + 1) 839 else (pos := newPos); 840 trailing_space := sspace; 841 pr s) 842 else () 843 end 844 val saydot = fn s => (say (s ^ ".")) 845 val sayln = fn t => (say t; pr "\n"; pos := 0; trailing_space := false) 846 val termvoid = makeUniqueId "VOID" 847 val ntvoid = makeUniqueId "ntVOID" 848 val hasType = fn s => case symbolType s 849 of NONE => false 850 | _ => true 851 val terms = let fun f n = if n=numTerms then nil 852 else (T n) :: f(n+1) 853 in f 0 854 end 855 val values = VALS {say=say,sayln=sayln,saydot=saydot, 856 termvoid=termvoid, ntvoid = ntvoid, 857 hasType=hasType, pos_type = pos_type, 858 arg_type = #2 arg_decl, 859 start=start,pureActions=pureActions, 860 termToString=termToString, 861 symbolToString=symbolToString,term=term, 862 nonterm=nonterm,terms=terms, 863 tokenInfo=token_sig_info_decl} 864 865 val (NAMES {miscStruct,tableStruct,dataStruct,tokenSig,tokenStruct,dataSig,...}) = names 866 in case header_decl 867 of NONE => (say "functor "; say miscStruct; 868 sayln "(structure Token : TOKEN)"; 869 say " : sig structure "; 870 say dataStruct; 871 say " : "; sayln dataSig; 872 say " structure "; 873 say tokenStruct; say " : "; sayln tokenSig; 874 sayln " end") 875 | SOME s => say s; 876 sayln " = "; 877 sayln "struct"; 878 sayln ("structure " ^ dataStruct ^ "="); 879 sayln "struct"; 880 sayln "structure Header = "; 881 sayln "struct"; 882 sayln header; 883 sayln "end"; 884 sayln "structure LrTable = Token.LrTable"; 885 sayln "structure Token = Token"; 886 sayln "local open LrTable in "; 887 entries := PrintStruct.makeStruct{table=table,print=pr, 888 name = "table", 889 verbose=verbose}; 890 sayln "end"; 891 printTypes(values,names,symbolType); 892 printEC (keyword,change,noshift,value,values,names); 893 printAction(rules,values,names); 894 sayln "end"; 895 printTokenStruct(values,names); 896 sayln "end"; 897 printSigs(values,names,fn s => TextIO.output(sigs,s)); 898 TextIO.closeOut sigs; 899 TextIO.closeOut result; 900 MakeTable.Errs.printSummary (fn s => TextIO.output(TextIO.stdOut,s)) errs 901 end; 902 if verbose then 903 let val f = TextIO.openOut (spec ^ ".desc") 904 val say = fn s=> TextIO.output(f,s) 905 val printRule = 906 let val rules = Array.fromList grammarRules 907 in fn say => 908 let val prRule = fn {lhs,rhs,precedence,rulenum} => 909 ((say o nontermToString) lhs; say " : "; 910 app (fn s => (say (symbolToString s); say " ")) rhs) 911 in fn i => prRule (rules sub i) 912 end 913 end 914 in Verbose.printVerbose 915 {termToString=termToString,nontermToString=nontermToString, 916 table=table, stateErrs=stateErrs,errs = errs,entries = !entries, 917 print=say, printCores=corePrint,printRule=printRule}; 918 TextIO.closeOut f 919 end 920 else () 921 end 922 923 val parseGen = fn spec => 924 let val (result,inputSource) = ParseGenParser.parse spec 925 in make_parser(getResult result,spec,Header.error inputSource, 926 errorOccurred inputSource) 927 end 928end; 929