parser2.sml

这是我们参加06年全国开源软件的竞赛作品

		      of (nonterm,value,stack as (state,_) :: _) =>
		         parseStep(lexPair,(goto(state,nonterm),value)::stack,
				 queue,distance)
		      | _ => raise (ParseImpossible 240))
		 | ERROR => (lexPair,stack,queue,distance,SOME nextAction)
		 | ACCEPT => (lexPair,stack,queue,distance,SOME nextAction)
	      end
	   | parseStep _ = raise (ParseImpossible 242)
	in parseStep : ('_a,'_b) distanceParse 
	end

(* mkFixError: function to create fixError function which adjusts parser state
   so that parse may continue in the presence of an error *)

fun mkFixError({is_keyword,terms,errtermvalue,
	      preferred_change,noShift,
	      showTerminal,error,...} : ('_a,'_b) ecRecord,
	     distanceParse : ('_a,'_b) distanceParse,
	     minAdvance,maxAdvance) 

            (lexv as (TOKEN (term,value as (_,leftPos,_)),_),stack,queue) =
    let val _ = if DEBUG2 then
			error("syntax error found at " ^ (showTerminal term),
			      leftPos,leftPos)
		else ()

        fun tokAt(t,p) = TOKEN(t,(errtermvalue t,p,p))

	val minDelta = 3

	(* pull all the state * lexv elements from the queue *)

	val stateList = 
	   let fun f q = let val (elem,newQueue) = Fifo.get q
			 in elem :: (f newQueue)
			 end handle Fifo.Empty => nil
	   in f queue
	   end

	(* now number elements of stateList, giving distance from
	   error token *)

	val (_, numStateList) =
	      List.foldr (fn (a,(num,r)) => (num+1,(a,num)::r)) (0, []) stateList

	(* Represent the set of potential changes as a linked list.

	   Values of datatype Change hold information about a potential change.

	   oper = oper to be applied
	   pos = the # of the element in stateList that would be altered.
	   distance = the number of tokens beyond the error token which the
	     change allows us to parse.
	   new = new terminal * value pair at that point
	   orig = original terminal * value pair at the point being changed.
	 *)

	datatype ('a,'b) change = CHANGE of
	   {pos : int, distance : int, leftPos: 'b, rightPos: 'b,
	    new : ('a,'b) lexv list, orig : ('a,'b) lexv list}


         val showTerms = concat o map (fn TOKEN(t,_) => " " ^ showTerminal t)

	 val printChange = fn c =>
	  let val CHANGE {distance,new,orig,pos,...} = c
	  in (print ("{distance= " ^ (Int.toString distance));
	      print (",orig ="); print(showTerms orig);
	      print (",new ="); print(showTerms new);
	      print (",pos= " ^ (Int.toString pos));
	      print "}\n")
	  end

	val printChangeList = app printChange

(* parse: given a lexPair, a stack, and the distance from the error
   token, return the distance past the error token that we are able to parse.*)

	fun parse (lexPair,stack,queuePos : int) =
	    case distanceParse(lexPair,stack,Fifo.empty,queuePos+maxAdvance+1)
             of (_,_,_,distance,SOME ACCEPT) => 
		        if maxAdvance-distance-1 >= 0 
			    then maxAdvance 
			    else maxAdvance-distance-1
	      | (_,_,_,distance,_) => maxAdvance - distance - 1

(* catList: concatenate results of scanning list *)

	fun catList l f = List.foldr (fn(a,r)=> f a @ r) [] l

        fun keywordsDelta new = if List.exists (fn(TOKEN(t,_))=>is_keyword t) new
	               then minDelta else 0

        fun tryChange{lex,stack,pos,leftPos,rightPos,orig,new} =
	     let val lex' = List.foldr (fn (t',p)=>(t',Stream.cons p)) lex new
		 val distance = parse(lex',stack,pos+length new-length orig)
	      in if distance >= minAdvance + keywordsDelta new 
		   then [CHANGE{pos=pos,leftPos=leftPos,rightPos=rightPos,
				distance=distance,orig=orig,new=new}] 
		   else []
	     end


(* tryDelete: Try to delete n terminals.
              Return single-element [success] or nil.
	      Do not delete unshiftable terminals. *)


    fun tryDelete n ((stack,lexPair as (TOKEN(term,(_,l,r)),_)),qPos) =
	let fun del(0,accum,left,right,lexPair) =
	          tryChange{lex=lexPair,stack=stack,
			    pos=qPos,leftPos=left,rightPos=right,
			    orig=rev accum, new=[]}
	      | del(n,accum,left,right,(tok as TOKEN(term,(_,_,r)),lexer)) =
		   if noShift term then []
		   else del(n-1,tok::accum,left,r,Stream.get lexer)
         in del(n,[],l,r,lexPair)
        end

(* tryInsert: try to insert tokens before the current terminal;
       return a list of the successes  *)

        fun tryInsert((stack,lexPair as (TOKEN(_,(_,l,_)),_)),queuePos) =
	       catList terms (fn t =>
		 tryChange{lex=lexPair,stack=stack,
			   pos=queuePos,orig=[],new=[tokAt(t,l)],
			   leftPos=l,rightPos=l})
			      
(* trySubst: try to substitute tokens for the current terminal;
       return a list of the successes  *)

        fun trySubst ((stack,lexPair as (orig as TOKEN (term,(_,l,r)),lexer)),
		      queuePos) =
	      if noShift term then []
	      else
		  catList terms (fn t =>
		      tryChange{lex=Stream.get lexer,stack=stack,
				pos=queuePos,
				leftPos=l,rightPos=r,orig=[orig],
				new=[tokAt(t,r)]})

     (* do_delete(toks,lexPair) tries to delete tokens "toks" from "lexPair".
         If it succeeds, returns SOME(toks',l,r,lp), where
	     toks' is the actual tokens (with positions and values) deleted,
	     (l,r) are the (leftmost,rightmost) position of toks', 
	     lp is what remains of the stream after deletion 
     *)
        fun do_delete(nil,lp as (TOKEN(_,(_,l,_)),_)) = SOME(nil,l,l,lp)
          | do_delete([t],(tok as TOKEN(t',(_,l,r)),lp')) =
	       if t=t'
		   then SOME([tok],l,r,Stream.get lp')
                   else NONE
          | do_delete(t::rest,(tok as TOKEN(t',(_,l,r)),lp')) =
	       if t=t'
		   then case do_delete(rest,Stream.get lp')
                         of SOME(deleted,l',r',lp'') =>
			       SOME(tok::deleted,l,r',lp'')
			  | NONE => NONE
		   else NONE
			     
        fun tryPreferred((stack,lexPair),queuePos) =
	    catList preferred_change (fn (delete,insert) =>
	       if List.exists noShift delete then [] (* should give warning at
						 parser-generation time *)
               else case do_delete(delete,lexPair)
                     of SOME(deleted,l,r,lp) => 
			    tryChange{lex=lp,stack=stack,pos=queuePos,
				      leftPos=l,rightPos=r,orig=deleted,
				      new=map (fn t=>(tokAt(t,r))) insert}
		      | NONE => [])

	val changes = catList numStateList tryPreferred @
	                catList numStateList tryInsert @
			  catList numStateList trySubst @
			    catList numStateList (tryDelete 1) @
			      catList numStateList (tryDelete 2) @
			        catList numStateList (tryDelete 3)

	val findMaxDist = fn l => 
	  foldr (fn (CHANGE {distance,...},high) => Int.max(distance,high)) 0 l

(* maxDist: max distance past error taken that we could parse *)

	val maxDist = findMaxDist changes

(* remove changes which did not parse maxDist tokens past the error token *)

        val changes = catList changes 
	      (fn(c as CHANGE{distance,...}) => 
		  if distance=maxDist then [c] else [])

      in case changes 
	  of (l as change :: _) =>
	      let fun print_msg (CHANGE {new,orig,leftPos,rightPos,...}) =
		  let val s = 
		      case (orig,new)
			  of (_::_,[]) => "deleting " ^ (showTerms orig)
	                   | ([],_::_) => "inserting " ^ (showTerms new)
			   | _ => "replacing " ^ (showTerms orig) ^
				 " with " ^ (showTerms new)
		  in error ("syntax error: " ^ s,leftPos,rightPos)
		  end
		   
		  val _ = 
		      (if length l > 1 andalso DEBUG2 then
			   (print "multiple fixes possible; could fix it by:\n";
			    app print_msg l;
			    print "chosen correction:\n")
		       else ();
		       print_msg change)

		  (* findNth: find nth queue entry from the error
		   entry.  Returns the Nth queue entry and the  portion of
		   the queue from the beginning to the nth-1 entry.  The
		   error entry is at the end of the queue.

		   Examples:

		   queue = a b c d e
		   findNth 0 = (e,a b c d)
		   findNth 1 =  (d,a b c)
		   *)

		  val findNth = fn n =>
		      let fun f (h::t,0) = (h,rev t)
			    | f (h::t,n) = f(t,n-1)
			    | f (nil,_) = let exception FindNth
					  in raise FindNth
					  end
		      in f (rev stateList,n)
		      end
		
		  val CHANGE {pos,orig,new,...} = change
		  val (last,queueFront) = findNth pos
		  val (stack,lexPair) = last

		  val lp1 = foldl(fn (_,(_,r)) => Stream.get r) lexPair orig
		  val lp2 = foldr(fn(t,r)=>(t,Stream.cons r)) lp1 new

		  val restQueue = 
		      Fifo.put((stack,lp2),
			       foldl Fifo.put Fifo.empty queueFront)

		  val (lexPair,stack,queue,_,_) =
		      distanceParse(lp2,stack,restQueue,pos)

	      in (lexPair,stack,queue)
	      end
	| nil => (error("syntax error found at " ^ (showTerminal term),
			leftPos,leftPos); raise ParseError)
    end

   val parse = fn {arg,table,lexer,saction,void,lookahead,
		   ec=ec as {showTerminal,...} : ('_a,'_b) ecRecord} =>
	let val distance = 15   (* defer distance tokens *)
	    val minAdvance = 1  (* must parse at least 1 token past error *)
	    val maxAdvance = Int.max(lookahead,0)(* max distance for parse check *)
	    val lexPair = Stream.get lexer
	    val (TOKEN (_,(_,leftPos,_)),_) = lexPair
	    val startStack = [(initialState table,(void,leftPos,leftPos))]
	    val startQueue = Fifo.put((startStack,lexPair),Fifo.empty)
	    val distanceParse = distanceParse(table,showTerminal,saction,arg)
	    val fixError = mkFixError(ec,distanceParse,minAdvance,maxAdvance)
	    val ssParse = ssParse(table,showTerminal,saction,fixError,arg)
	    fun loop (lexPair,stack,queue,_,SOME ACCEPT) =
		   ssParse(lexPair,stack,queue)
	      | loop (lexPair,stack,queue,0,_) = ssParse(lexPair,stack,queue)
	      | loop (lexPair,stack,queue,distance,SOME ERROR) =
		 let val (lexPair,stack,queue) = fixError(lexPair,stack,queue)
		 in loop (distanceParse(lexPair,stack,queue,distance))
		 end
	      | loop _ = let exception ParseInternal
			 in raise ParseInternal
			 end
	in loop (distanceParse(lexPair,startStack,startQueue,distance))
	end
 end;

(* drt (12/15/89) -- needed only when the code above is functorized

structure LrParser = ParserGen(structure LrTable=LrTable
			     structure Stream=Stream);
*)