1(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi *)
2
3(* drt (12/15/89) -- the functor should be used during development work,
4   but it is wastes space in the release version.
5   
6functor ParserGen(structure LrTable : LR_TABLE
7		  structure Stream : STREAM) : LR_PARSER =
8*)
9
10structure LrParser :> LR_PARSER =
11 struct
12     val print = fn s => output(std_out,s)
13     val println = fn s => (print s; print "\n")
14     structure LrTable = LrTable
15     structure Stream = Stream
16     structure Token : TOKEN =
17	struct
18	    structure LrTable = LrTable
19	    datatype ('a,'b) token = TOKEN of LrTable.term * ('a * 'b * 'b)
20	    val sameToken = fn (TOKEN (t,_),TOKEN(t',_)) => t=t'
21	end
22     
23
24     open LrTable 
25     open Token
26
27     val DEBUG = false
28     exception ParseError
29
30      type ('a,'b) elem = (state * ('a * 'b * 'b))
31      type ('a,'b) stack = ('a,'b) elem list
32
33      val showState = fn (STATE s) => ("STATE " ^ (makestring s))
34
35      fun printStack(stack: ('a,'b) elem list, n: int) =
36         case stack
37           of (state, _) :: rest =>
38                 (print("          " ^ makestring n ^ ": ");
39                  println(showState state);
40                  printStack(rest, n+1)
41                 )
42            | nil => ()
43
44      val parse = fn {arg : 'a,
45		      table : LrTable.table,
46		      lexer : ('_b,'_c) token Stream.stream,
47		      saction : int * '_c * ('_b,'_c) stack * 'a ->
48				nonterm * ('_b * '_c * '_c) * ('_b,'_c) stack,
49		      void : '_b,
50		      ec = {is_keyword,preferred_change,
51			    errtermvalue,showTerminal,
52			    error,terms,noShift},
53		      lookahead} =>
54 let fun prAction(stack as (state, _) :: _, 
55		  next as (TOKEN (term,_),_), action) =
56             (println "Parse: state stack:";
57              printStack(stack, 0);
58              print("       state="
59                         ^ showState state	
60                         ^ " next="
61                         ^ showTerminal term
62                         ^ " action="
63                        );
64              case action
65                of SHIFT s => println ("SHIFT " ^ showState s)
66                 | REDUCE i => println ("REDUCE " ^ (makestring i))
67                 | ERROR => println "ERROR"
68		 | ACCEPT => println "ACCEPT";
69              action)
70        | prAction (_,_,action) = action
71
72      val action = LrTable.action table
73      val goto = LrTable.goto table
74
75      fun parseStep(next as (TOKEN (terminal, value as (_,leftPos,_)),lexer) :
76			('_b,'_c) token * ('_b,'_c) token Stream.stream,
77		    stack as (state,_) :: _ : ('_b ,'_c) stack) =
78         case (if DEBUG then prAction(stack, next,action(state, terminal))
79               else action(state, terminal))
80              of SHIFT s => parseStep(Stream.get lexer, (s,value) :: stack)
81               | REDUCE i =>
82		    let val (nonterm,value,stack as (state,_) :: _ ) =
83					 saction(i,leftPos,stack,arg)
84		    in parseStep(next,(goto(state,nonterm),value)::stack)
85		    end
86               | ERROR => let val (_,leftPos,rightPos) = value
87		          in error("syntax error\n",leftPos,rightPos);
88			     raise ParseError
89			  end
90  	       | ACCEPT => let val (_,(topvalue,_,_)) :: _ = stack
91			       val (token,restLexer) = next
92			   in (topvalue,Stream.cons(token,lexer))
93			   end
94      val next as (TOKEN (terminal,(_,leftPos,_)),_) = Stream.get lexer
95   in parseStep(next,[(initialState table,(void,leftPos,leftPos))])
96   end
97end;
98
99