Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /sml/trunk/src/ml-yacc/src/lalr.sml
ViewVC logotype

View of /sml/trunk/src/ml-yacc/src/lalr.sml

Parent Directory Parent Directory | Revision Log Revision Log

Revision 250 - (download) (annotate)
Sat Apr 17 18:57:03 1999 UTC (21 years, 2 months ago) by monnier
File size: 14907 byte(s)
This commit was generated by cvs2svn to compensate for changes in r249,
which included commits to RCS files with non-trunk default branches.
(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi 
 * $Log$
 * Revision  1999/04/17 18:56:12  monnier
 * version 110.16
 * Revision  1997/01/14 01:38:05  george
 *   Version 109.24
 * Revision 1.3  1996/10/03  03:37:12  jhr
 * Qualified identifiers that are no-longer top-level (quot, rem, min, max).
 * Revision 1.2  1996/02/26  15:02:35  george
 *    print no longer overloaded.
 *    use of makestring has been removed and replaced with Int.toString ..
 *    use of IO replaced with TextIO
 * Revision  1996/01/31  16:01:45  george
 * Version 109

functor mkLalr ( structure IntGrammar : INTGRAMMAR
		structure Core : CORE
		structure Graph : LRGRAPH
		structure Look: LOOK
		sharing Graph.Core = Core
		sharing Graph.IntGrammar = Core.IntGrammar =
			Look.IntGrammar = IntGrammar) : LALR_GRAPH =
	open Array List
	infix 9 sub
	open IntGrammar.Grammar IntGrammar Core Graph Look
	structure Graph = Graph
	structure Core = Core
	structure Grammar = IntGrammar.Grammar
	structure IntGrammar = IntGrammar

	datatype tmpcore = TMPCORE of (item * term list ref) list * int
	datatype lcore = LCORE of (item * term list) list * int

	 val prLcore =
	  fn a as (SymbolToString,nontermToString,termToString,print) =>
	    let val printItem = prItem (SymbolToString,nontermToString,print)
		val printLookahead = prLook(termToString,print)
	    in fn (LCORE (items,state)) =>
		(print "\n";
		 print "state ";
		 print (Int.toString state);
		 print " :\n\n";
		 List.app (fn (item,lookahead) =>
			(print "{";
			 printItem item;
			 print ",";
			 printLookahead lookahead;
			 print "}\n")) items)

	exception Lalr of int

	structure ItemList = ListOrdSet
		   type elem = item * term list ref
		   val eq = fn ((a,_),(b,_)) => eqItem(a,b)
		   val gt = fn ((a,_),(b,_)) => gtItem(a,b)

	structure NontermSet = ListOrdSet
		   type elem = nonterm
		   val gt = gtNonterm
		   val eq = eqNonterm

(* NTL: nonterms with lookahead *)

	structure NTL = RbOrdSet
		   type elem = nonterm * term list
		   val gt = fn ((i,_),(j,_)) => gtNonterm(i,j)
		   val eq = fn ((i,_),(j,_)) => eqNonterm(i,j)

	val DEBUG = false

	val addLookahead  = fn {graph,nullable,first,eop,
				print,termToString,nontermToString} =>

		val eop = Look.make_set eop

		val symbolToString = fn (TERM t) => termToString t
				      | (NONTERM t) => nontermToString t

		val print = if DEBUG then print
			    else fn _ => ()

		val prLook = if DEBUG then prLook (termToString,print)
			     else fn _ => ()

		val prNonterm = print o nontermToString

		val prRule = if DEBUG
			      then prRule(symbolToString,nontermToString,print)
			      else fn _ => ()

		val printInt = print o (Int.toString : int -> string)

		val printItem = prItem(symbolToString,nontermToString,print)

(* look_pos: position in the rhs of a rule at which we should start placing
   lookahead ref cells, i.e. the minimum place at which A -> x .B y, where
   B is a nonterminal and y =*=> epsilon, or A -> x. is true.  Positions are
   given by the number of symbols before the place.  The place before the first
   symbol is 0, etc. *)

	     val look_pos =
		 let val positions = array(length rules,0)

(* rule_pos: calculate place in the rhs of a rule at which we should start
   placing lookahead ref cells *)

		      val rule_pos = fn (RULE {rhs,...}) =>
			case (rev rhs)
			  of nil => 0
			   | (TERM t) :: r => length rhs
			   | (l as (NONTERM n) :: r) =>

			      (* f assumes that everything after n in the
				 rule has proven to be nullable so far.
				 Remember that the rhs has been reversed,
				 implying that this is true initially *)
					(* A -> .z t B y, where y is nullable *)

			      let fun f (NONTERM b :: (r as (TERM _ :: _))) =
					(length r)

					(* A -> .z B C y *)

				    | f (NONTERM c :: (r as (NONTERM b :: _))) =
					 if nullable c then f r
					 else (length r)

					(* A -> .B y, where y is nullable *)

				    | f (NONTERM b :: nil) = 0 
			      in  f l
		 	val check_rule = fn (rule as RULE {num,...}) =>
			    let val pos = rule_pos rule
			    in (print "look_pos: ";
			 	prRule rule;
				print " = ";
				printInt pos;
				print "\n";
				update(positions,num,rule_pos rule))
		   in app check_rule rules;
		    fn RULE{num,...} => (positions sub num)

(* rest_is_null: true for items of the form A -> x .B y, where y is nullable *)

	     val rest_is_null =
		 fn (ITEM{rule,dot, rhsAfter=NONTERM _ :: _}) =>
			 dot >= (look_pos rule)
		  | _ => false

(* map core to a new core including only items of the form A -> x. or
   A -> x. B y, where y =*=> epsilon.  It also adds epsilon productions to the
   core. Each item is given a ref cell to hold the lookahead nonterminals for

	      val map_core =
		let val f = fn (item as ITEM {rhsAfter=nil,...},r) =>
				(item,ref nil) :: r
			     | (item,r) =>
				 if (rest_is_null item)
				    then (item,ref nil)::r
				    else r
		in fn (c as CORE (items,state)) =>
		   let val epsItems =
			   map  (fn rule=>(ITEM{rule=rule,dot=0,rhsAfter=nil},
					   ref (nil : term list))
				) (epsProds c)
		   in TMPCORE(ItemList.union(List.foldr f [] items,epsItems),state)

	      val new_nodes = map map_core (nodes graph)

	      exception Find

(* findRef: state * item -> lookahead ref cell for item *)

	      val findRef = 
		let val states = Array.fromList new_nodes
		    val dummy = ref nil
		in fn (state,item) =>
		    let val TMPCORE (l,_) = states sub state
		    in case ItemList.find((item,dummy),l)
				   of SOME (_,look_ref) => look_ref
				    | NONE => (print "find failed: state ";
					       printInt state;
					       print "\nitem =\n";
					       printItem item;
					       print "\nactual items =\n";
					       app (fn (i,_) => (printItem i;
						    print "\n")) l;
						raise Find)

(* findRuleRefs: state -> rule -> lookahead refs for rule. *)
	       val findRuleRefs =
		 let val shift = shift graph
		 in fn state =>
			(* handle epsilon productions *)
		  fn (rule as RULE {rhs=nil,...}) => 
		   | (rule as RULE {rhs=sym::rest,...}) =>
		   let	val pos = Int.max(look_pos rule,1)
			fun scan'(state,nil,pos,result) =
						   rhsAfter=nil}) :: result
			  | scan'(state,rhs as sym::rest,pos,result) =
				scan'(shift(state,sym), rest, pos+1,
(* find first item of the form A -> x .B y, where y =*=> epsilon and
   x is not epsilon, or A -> x.  use scan' to pick up all refs after this
   point *)

			 fun scan(state,nil,_) =
			   | scan(state,rhs,0) = scan'(state,rhs,pos,nil)
			   | scan(state,sym::rest,place) =

		  in scan(shift(state,sym),rest,pos-1)


(* function to compute for some nonterminal n the set of nonterminals A added
   through the closure of nonterminal n such that n =c*=> .A x, where x is
   nullable *)

	      val nonterms_w_null = fn nt =>
		  let val collect_nonterms = fn n =>
		    List.foldr (fn (rule as RULE {rhs=rhs as NONTERM n :: _,...},r) =>
			     (rest_is_null(ITEM {dot=0,rhsAfter=rhs,rule=rule}))
				 of true => n :: r
				  | false => r)
			   | (_,r) => r) [] (produces n)
		       fun dfs(a as (n,r)) =
			 if (NontermSet.exists a) then r 
			 else List.foldr dfs (NontermSet.insert(n,r))
				(collect_nonterms n)
		  in dfs(nt,NontermSet.empty)

		val nonterms_w_null =
		   let val data = array(nonterms,NontermSet.empty)
		       fun f n = if n=nonterms then ()
				 else (update(data,n,nonterms_w_null (NT n));
				       f (n+1))
		   in (f 0; fn (NT nt) => data sub nt)

(* look_info: for some nonterminal n the set of nonterms A added
   through the closure of the nonterminal such that n =c+=> .Ax and the
   lookahead accumlated for each nonterm A *)

		val look_info = fn nt =>
		   let val collect_nonterms = fn n =>
		      List.foldr (fn (RULE {rhs=NONTERM n :: t,...},r) =>
			     (case NTL.find ((n,nil),r)
			      of SOME (key,data) =>
			         NTL.insert((n,Look.union(data,first t)),r)
			       | NONE => NTL.insert ((n,first t),r))
			     | (_,r) => r)
		            NTL.empty (produces n)
			fun dfs(a as ((key1,data1),r)) =
			  case (NTL.find a)
			   of SOME (_,data2) =>
			    | NONE => NTL.fold dfs (collect_nonterms key1)
						   (NTL.insert a)
		    in dfs((nt,nil),NTL.empty)

		val look_info = 
		  if not DEBUG then look_info
		  else fn nt =>
		       (print "look_info of "; prNonterm nt; print "=\n";
			let val info = look_info nt
			in (NTL.app (fn (nt,lookahead) =>
				    (prNonterm nt; print ": "; prLook lookahead;
				     print "\n\n")) info;

(* prop_look: propagate lookaheads for nonterms added in the closure of a
   nonterm.  Lookaheads must be propagated from each nonterminal m to
   all nonterminals { n | m =c+=> nx, where x=*=>epsilon} *)

		  val prop_look = fn ntl =>
		    let val upd_lookhd = fn new_look => fn (nt,r) =>
			  case NTL.find ((nt,new_look),r)
			  of SOME (_,old_look) =>
			     NTL.insert((nt, Look.union(new_look,old_look)),r)
			   | NONE => raise (Lalr 241)
		         val upd_nonterm = fn ((nt,look),r) =>
			   NontermSet.fold (upd_lookhd look)
					   (nonterms_w_null nt) r
		     in NTL.fold upd_nonterm ntl ntl

		val prop_look = 
		  if not DEBUG then prop_look
		  else fn ntl =>
		    (print "prop_look =\n";
		     let val info = prop_look ntl
		     in (NTL.app (fn (nt,lookahead) =>
				    (prNonterm nt;
				     print ": ";
				     prLook lookahead;
				     print "\n\n")) info; info)

(* now put the information from these functions together.  Create a function
   which takes a nonterminal n and returns a list of triplets of
	 (a nonterm added through closure,
	  the lookahead for the nonterm,
	  whether the nonterm should include the lookahead for the nonterminal
	  whose closure is being taken (i.e. first(y) for an item j of the
	  form A -> x .n y and lookahead(j) if y =*=> epsilon)

		 val closure_nonterms =
		   let val data =
			  array(nonterms,nil: (nonterm * term list * bool) list)
		       val do_nonterm = fn i =>
			let val nonterms_followed_by_null =
				nonterms_w_null i
			    val nonterms_added_through_closure = 
			      NTL.make_list (prop_look (look_info i))
			    val result =
			    map (fn (nt,l) =>
			 (nt,l,NontermSet.exists (nt,nonterms_followed_by_null))
				) nonterms_added_through_closure
			 in if DEBUG then
			       (print "closure_nonterms = ";
				prNonterm i;
				print "\n";
				app (fn (nt,look,nullable) =>
				  (prNonterm nt;
				   print ":";
				   prLook look;
				   case nullable
				     of false => print "(false)\n"
				      | true => print "(true)\n")) result;
				print "\n")
			     else ();
		        fun f i =
			  if i=nonterms then ()
			  else (update(data,i,do_nonterm (NT i)); f (i+1))
			val _ = f 0
		    in fn (NT i) => data sub i

(* add_nonterm_lookahead: Add lookahead to all completion items for rules added
   when the closure of a given nonterm in some state is taken.  It returns
   a list of lookahead refs to which the given nonterm's lookahead should
   be propagated.   For each rule, it must trace the shift/gotos in the LR(0)
   graph to find all items of the form A-> x .B y where y =*=> epsilon or
   A -> x.

		val add_nonterm_lookahead = fn (nt,state) =>
		  let val f = fn ((nt,lookahead,nullable),r) =>
			let val refs = map (findRuleRefs state) (produces nt)
			    val refs = List.concat refs
			    val _ = app (fn r =>
				     r := (Look.union (!r,lookahead))) refs
			in if nullable then refs @ r else r
		 in List.foldr f [] (closure_nonterms nt)

(* scan_core: Scan a core for all items of the form A -> x .B y.  Applies
   add_nonterm_lookahead to each such B, and then merges first(y) into
   the list of refs returned by add_nonterm_lookahead.  It returns
   a list of ref * ref list for all the items where y =*=> epsilon *)

		val scan_core = fn (CORE (l,state)) =>
		  let fun f ((item as ITEM{rhsAfter= NONTERM b :: y,
					   dot,rule})::t,r) =
			(case (add_nonterm_lookahead(b,state))
			  of nil => r
			   | l =>
			    let val first_y = first y
			        val newr  = if dot >= (look_pos rule)
					then (findRef(state,item),l)::r
					else r
			    in (app (fn r =>
					 r := Look.union(!r,first_y)) l;
			        f (t,newr))
			| f (_ :: t,r) = f (t,r)
			| f (nil,r) = r
		  in f (l,nil)

(* add end-of-parse symbols to set of items consisting of all items
   immediately derived from the start symbol *)

		val add_eop = fn (c as CORE (l,state),eop) =>
		  let fun f (item as ITEM {rule,dot,...}) =
		    let val refs = findRuleRefs state rule

(* first take care of kernal items.  Add the end-of-parse symbols to
   the lookahead sets for these items.  Epsilon productions of the
   start symbol do not need to be handled specially because they will
   be in the kernal also *)

		       app (fn r => r := Look.union(!r,eop)) refs;

(* now take care of closure items.  These are all nonterminals C which
   have a derivation S =+=> .C x, where x is nullable *)

		       if dot >= (look_pos rule) then
		       	  case item
			  of ITEM{rhsAfter=NONTERM b :: _,...} =>
			     (case add_nonterm_lookahead(b,state)
			      of nil => ()
			       | l => app (fn r => r := Look.union(!r,eop)) l)
			   | _ => ()
		       else ()
		  in app f l

		val iterate = fn l =>
		   let fun f lookahead (nil,done) = done
			 | f lookahead (h::t,done) =
			    let val old = !h
			    in h := Look.union (old,lookahead);
			       if (length (!h)) <> (length old)
					 then f lookahead (t,false)
					 else f lookahead(t,done)
		       fun g ((from,to)::rest,done) =
			let val new_done = f (!from) (to,done)
			in g (rest,new_done)
			 | g (nil,done) = done
		       fun loop true = ()
			 | loop false = loop (g (l,true))
		   in loop false

		val lookahead = List.concat (map scan_core (nodes graph))

(* used to scan the item list of a TMPCORE and remove the items not
   being reduced *)

		val create_lcore_list =
			fn ((item as ITEM {rhsAfter=nil,...},ref l),r) =>
				(item,l) :: r
			 | (_,r) => r

	in  add_eop(Graph.core graph 0,eop);
	    iterate lookahead;
	    map (fn (TMPCORE (l,state)) =>
		       LCORE (List.foldr create_lcore_list [] l, state)) new_nodes

ViewVC Help
Powered by ViewVC 1.0.0