Google
 

Trailing-Edge - PDP-10 Archives - CFS_TSU04_19910205_1of1 - update/t20src/diupar.bli
There are 4 other files named diupar.bli in the archive. Click here to see a list.
MODULE DIUPAR (ident = '253'
               %REQUIRE ('DIUPATSWITCH')
		) =
BEGIN

!++
!	COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1986.
!	ALL RIGHTS RESERVED.
!
!	THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY  BE  USED  AND
!	COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
!	THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE.   THIS  SOFTWARE  OR
!	ANY  OTHER  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
!	AVAILABLE TO ANY OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE
!	SOFTWARE IS HEREBY TRANSFERRED.
!
!	THE INFORMATION IN THIS SOFTWARE IS  SUBJECT  TO  CHANGE  WITHOUT
!	NOTICE  AND  SHOULD  NOT  BE CONSTRUED AS A COMMITMENT BY DIGITAL
!	EQUIPMENT CORPORATION.
!
!	DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF
!	ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
!
! FACILITY:	PAT Parser
!
! ABSTRACT:
!
! 	PATPARSER.BLI is the parser.
!
! ENVIRONMENT:	VAX/VMS user mode
!
! AUTHORS:  C. Mitchell, H. Alcabes, CREATION DATE:  25-Feb-80
!
! ACKNOWLEDGEMENT: The local error recovery algorithm used in this module
!	is based in part on an algorithm developed by Dr. Gerald Fisher as part
!	of the Ada project at the Courant Institute at New York Univerisity.
!
! MODIFIED BY:
!
!	Charlie Mitchell, 02-Nov-1981 : VERSION x2-001
! 001 -	Final packaging and modification to use PATDATA.
! 002 - (11/83) Fix bug that gave bad "when expecting" symbols in
!	global error recovery message.  Minor mod to eliminate
!	warning from BLISS V4.
! 003 - (12/83) Add BASIC bug fix.  Reset LATEST_TOKEN_PTR after
!	global error recovery.
! 004 - Remove VMS dependencies.  C. Richardson 29-May-84
!
!  253  Rename file to DIUPAR.
!       Gregory A. Scott 1-Jul-86
!
!--
!
! INCLUDE FILES:
!

require 'DIUPATPROLOG';

library 'BLI:XPORT';

library 'DIUPATPARSER';

library 'DIUPATDATA';                   ! DIUPAT interface

library 'DIUPATLANGSP';                 ! Language Specific functions

library 'DIUPATERROR';                  ! Error recovery

library 'DIUPATTOKEN';

library 'DIUPATLRTUNE';

library 'DIUDEB';                       ! Debugging

library 'DIUPATDEB';                    ! Parser debugging
!
! TABLE OF CONTENTS OF INTERNAL ROUTINES:
!

forward routine
    ERROR_RECOVERY : novalue,			! Main error recovery driver
    PARSE;					! PAT parser

%if PATBLSEXT_LOCAL_RECOVERY
%then

forward routine
    DOWN_CASE : novalue,			! Convert string to lowercase
    FIND_BACKUP_ORDER,				! Determine order of corrections
    LOCAL_RECOVERY,				! Local/scope recovery driver
    MERGE_TOKENS,				! What do tokens merge to
    NEVER_INSERT_BEFORE,			! When not to insert a token
    PARSE_AHEAD,				! Try parsing ahead
    PARSE_AHEAD_INIT : novalue,			! Initialize for parse ahead
    RESTORE_STATE : novalue,			! Restore parse state
    SAVE_STATE : novalue,			! Save parse state
    SCOPE_RECOVERY,				! Try insertions to close scope
    STRONG_LOCAL_RECOVERY,			! Strong local error recovery
    SYNTHESIZE_TOKEN,				! Create synthetic token
    TRY_CORRECT_SPELLING,			! Try correcting spelling
    TRY_DELETE,					! Try deleting a token
    TRY_EOL_CORRECTION,				! End Of Line correction
    TRY_INSERT,					! Try inserting a token
    TRY_MERGE,					! Try merging tokens
    TRY_SUBSTITUTE,				! Try substituting new token
    WEAK_LOCAL_RECOVERY;			! Weak local error recovery

%fi
! MACROS:

macro
    CLEAR (START, BYTES) =
!	ZEROBYTE (BYTES, START) %;
	begin
	    incr counter from 0 to (bytes-1) do start [.counter] = 0
	end %;

macro
    BLOCK_COPY (SRC, DST, BYTES) =
	begin

	bind
	    SBV = SRC : bitvector [],					! [004]
	    DBV = DST : bitvector [];					! [004]

	incr OFFSET from 0 to (BYTES - 1) do
	    DBV [.OFFSET] = .SBV [.OFFSET];
	end
    %;

macro
    COUNT (START, BITS) =
	begin

	local
	    TOT;

	TOT = 0;
	incr LOOP_INDEX from 0 to (BITS - 1) do
	    if .START [.LOOP_INDEX] then TOT = .TOT + 1;
	.TOT
	end
    %;

macro
    BLOCK_AND (SRC1, SRC2, DST, BYTES) =
	begin

	bind
	    SBV1 = SRC1 : bitvector [],				! 004
	    SBV2 = SRC2 : bitvector [],				! 004
	    DBV = DST : bitvector [];				! 004

	incr OFFSET from 0 to (BYTES - 1) do
	    DBV [.OFFSET] = .SBV1 [.OFFSET] and .SBV2 [.OFFSET];
	end
    %;

macro
    WHICH_TERM (START, BITS) =
	begin
	incr LOOP_INDEX from 0 to (BITS - 1) do
	    if .START [.LOOP_INDEX] then exitloop .LOOP_INDEX
	end
    %;
macro
    MOVE_TOKEN (SRC, DST) =
	begin

	bind
	    srctok = (src): block [PATSTK_STR_SIZE/%upval]
		field (PATSTK_FIELDS),
	    dsttok = (dst): block [PATSTK_STR_SIZE/%upval]
		field (PATSTK_FIELDS);

	dsttok [PATSTK_LOCATOR]		= .srctok [PATSTK_LOCATOR];
	%if PATBLSEXT_EXTRA_STACK_FIELD
	%then
	dsttok [PATSTK_EXTRA_INFO]	= .srctok [PATSTK_EXTRA_INFO];
	%fi
	dsttok [PATSTK_SYMBOL]		= .srctok [PATSTK_SYMBOL];
	dsttok [PATSTK_TOKEN]		= .srctok [PATSTK_TOKEN];
	dsttok [PATSTK_ERRORMARK]	= .srctok [PATSTK_ERRORMARK];
	dsttok [PATSTK_STATE]		= .srctok [PATSTK_STATE];
	end
%;
! EQUATED SYMBOLS:

literal
!    NUM_BYTES = ((PAT$DATA_NUM_TERM + (%bpval - 1))/%bpval)*%upval,
    NUM_BYTES = PAT$DATA_NUM_TERM,
    NO_MERGE = -1,
    NO_INITIAL_SYMBOL = -4,
    VALUE_TO_BE_IGNORED = -99,
    MAX_NUM_SYN_TOKS = 10;
! OWN STORAGE:

%if PATBLSEXT_LOCAL_RECOVERY
%then

own
    SAVED_PAR_LOOKAHEAD_F,
    SAVED_STACK_PTR,
    SAVED_REDUCTION_CODE,
    LOCAL_ATTEMPT_STATUS,
    SYN_TOK_STORAGE : blockvector [MAX_NUM_SYN_TOKS, LS_TKN_SIZE],
    NEXT_SYN_TOK_INDEX;

%fi

global
    PAT$STACK_P : ref PATSTK_STR;

own
    CURRENT_SYMBOL,
    CURRENT_SYMBOL_IS_TERMINAL,
    PAR_LOOKAHEAD_F,
    STACK_PTR,
    REDUCTION_CODE,
    REF_PARSE_STACK : ref PATSTK_STR,
    PREV_STACK_PTR,
    PREV_STACK_RECORD : block [PATSTK_STR_SIZE/%upval] field (PATSTK_FIELDS),
    PREV_STATUS,
    PREV_WILL_BE_VALID,
    VALID_PREV : initial (FALSE),
    VALID_PREV_PREV : initial (FALSE),
    GLOBAL_MSG_STATUS,
    GLOBAL_MSG_SYMBOL,
    GLOBAL_MSG_INIT_STATE,
    HAVE_INITIAL_SYMBOL,
    INITIAL_SYMBOL,
    LATEST_TOKEN_PTR,
    PRIOR_TOKEN_PTR,
    ORIGINAL_STACK_PTR;

%if PATBLSEXT_LOCAL_RECOVERY
%then

own
    REF_ALT_PARSE_STACK : ref PATSTK_STR,
    PREV_PREV_STACK_PTR,
    PREV_PREV_STACK_RECORD : block [PATSTK_STR_SIZE/%upval] field (PATSTK_FIELDS),
    PREV_PREV_STATUS;

%fi

ENUMERATION ('backup_order', 1, ORDER_A,
    ORDER_B,
    ORDER_BC);

literal
    MAX_BUFFERED_TOKENS = 12;

external routine lex_init: novalue;
global routine PAT$PARSER (STARTING_TOKEN_PTR, ANNOUNCE_ABBREVIATIONS,
	RESULT, SYNTAX_ONLY, file) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	PAT$PARSER is the parser.
!
! FORMAL PARAMETERS:
!
!	STARTING_TOKEN_PTR	- Pointer to initial token; if NULL
!				  then initial token is to be obtained
!				  from the lexical analyzer
!
!	ANNOUNCE_ABBREVIATIONS	- TRUE iff an error message should be
!				  printed when an abbreviation is corrected
!				  during error recovery.
!
!	RESULT			- Address where action routine should place
!				  root of tree
!
!	SYNTAX_ONLY		- TRUE if parse is for syntax only (build no
!				  structures)
!
!	FILE			- Address of an XPORT IOB for the file
!				  containing the input to be parsed.  The file
!				  should already be open, and should be closed
!				  by the caller of PAT$PARSER.
!
! IMPLICIT INPUTS:
!
!	NONE
!
! IMPLICIT OUTPUTS:
!
!	NONE
!
! ROUTINE VALUE:
!
!	TRUE	- A compilation unit was parsed.
!	FALSE	- A compilation unit wasn't parsed.  At end of file.
!
! SIDE EFFECTS:
!
!	PAT$PARSER calls the lexical analyzer which reads the source
!	file.  PAR_ABST is called to build the abstract syntax tree.
!
!--

    begin

    LS_PARSE_STACK_DECL				! Normally expands to local
	PARSE_STACK : PATSTK_STR;		! Normal parse stack

%if PATBLSEXT_LOCAL_RECOVERY
%then
    local
	ALT_PARSE_STACK : PATSTK_STR;		! Alternate parse stack used for local error recovery
%fi

! Initialize the lexical machine to read the input file to be parsed:

    LEX_INIT (.file);

! Initialize own and local variables

    PAR_LOOKAHEAD_F = FALSE;
    PREV_STATUS = SAVED_INFO_NOT_VALID;
    PREV_WILL_BE_VALID = FALSE;
    GLOBAL_MSG_STATUS = SAVED_INFO_NOT_VALID;
    LATEST_TOKEN_PTR = NULL;
    PRIOR_TOKEN_PTR = NULL;
    CURRENT_SYMBOL_IS_TERMINAL = TRUE;
    PAT$TOKEN_INIT_BUFFER ();
    REF_PARSE_STACK = PARSE_STACK;

%if PATBLSEXT_LOCAL_RECOVERY
%then
    PREV_PREV_STATUS = SAVED_INFO_NOT_VALID;
    REF_ALT_PARSE_STACK = ALT_PARSE_STACK;
%fi

    if .STARTING_TOKEN_PTR eql NULL
    then
	begin					! Read in initial token
	PAT$TOKEN_GET (TRUE);
%if PATBLSEXT_DEBUGGING
%then
	PAT$DEB_TOKEN (TRUE);
%fi
	end
    else
	PAT$TOKEN_CURRENT_PTR = .STARTING_TOKEN_PTR;	! Called with initial token

    if ls_lex_term (PAT$TOKEN_CURRENT_PTR) eqlu T_EOF	! Nothing here but EOF
	then return FALSE;
    LATEST_TOKEN_PTR = .PAT$TOKEN_CURRENT_PTR;
    CURRENT_SYMBOL = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);
						! Current symbol comes from the current lexical token
    REDUCTION_CODE = -1;			! Haven't done a reduction
    PAT$STACK_P = PARSE_STACK;			! Point at normal parse stack

%if PATBLSEXT_EXTRA_STACK_FIELD
%then

    incr I from 0 to LS_PARSE_STACK_SIZE - 1 do
	PARSE_STACK [.I, PATSTK_EXTRA_INFO] = 0;	! Clear extra info field

%fi

    STACK_PTR = 0;				! Set parse stack pointer and
    PAT$STACK_P [.STACK_PTR, PATSTK_STATE] = 0;	! stack initial state

%if PATBLSEXT_LOCAL_RECOVERY
%then

! Initialize scope recovery

    SCOPE_RECOVERY (TRUE);
%fi

    while TRUE do
	begin
	if PARSE (.result, .syntax_only)
	then
	    begin
	    DEB_EVENT ('PAR_RECOVERY_INFO',
		PUT_MSG_EOL ('Compilation unit successfully parsed.'),
		PUT_EOL ());
	    return TRUE;			! Have parsed a compilation unit
	    end
	else 					! Invoke parser error recovery
	    ERROR_RECOVERY (.ANNOUNCE_ABBREVIATIONS);
	end

    end;					! Of routine PAT$PARSER
routine PARSE (result, syntax_only) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Does the actual work of parsing.
!
! FORMAL PARAMETERS:
!
!	result		Address where action routine should place root
!			of tree.
!
!	syntax_only	TRUE if parse is for syntax only (build no
!			structures).
!
! IMPLICIT INPUTS:
!
!	PAT$STACK_P
!	STACK_PTR
!	PREV_WILL_BE_VALID
!	CURRENT_SYMBOL
!
! IMPLICIT OUTPUTS:
!
!	Same as inputs.
!
! ROUTINE VALUE:
!
!	Returns TRUE if parsed input until finding the STOP-PARSING non-
!	terminal.  Returns FALSE if a parse error or parse stack overflow.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    local
	R,
	STATUS,
	ACTION_CODE,
	ACTION_ROUTINE_ALLOWS_BACKUP,
	RIGHT_TOKEN_PTR,
	LHS_SYMBOL,
	RHS_COUNT,
	SEMACT,
	NEW_PTR;
    while TRUE do
	begin

%if PATBLSEXT_DEBUGGING
%then
	PAT$DEB_STATE (.PAT$STACK_P [.STACK_PTR, PATSTK_STATE], TRUE);
%fi

! If this is the STOP_PARSING non-terminal, we are done.

	if .CURRENT_SYMBOL eql LS_STOP_PARSING_NT then return TRUE;

! Determine what to do based on the current action:

	ACTION_CODE = PAT$DATA_MOVE_ACTION (.PAT$STACK_P [.STACK_PTR, PATSTK_STATE], .CURRENT_SYMBOL);
	if PAT$DATA_ACTION_IS (.ACTION_CODE, 'ERROR')
	then
	    return FALSE
	else
	    begin

	    if PAT$DATA_ACTION_IS (.ACTION_CODE, 'SHIFT')	! Shift
	    then
		begin

		! Save the symbol that was found on the stack and push the
		! new state on the stack.

		PAT$STACK_P [.STACK_PTR, PATSTK_SYMBOL] = .CURRENT_SYMBOL;

		if .CURRENT_SYMBOL_IS_TERMINAL
		then
		    begin
		    STATUS = CONSUME_TERM_ON_SHIFT;
		    PREV_WILL_BE_VALID = TRUE;

%if PATBLSEXT_EXTRA_STACK_FIELD
%then
		    PAT$STACK_P [.STACK_PTR, PATSTK_EXTRA_INFO] = LS_LEX_EXTRA_INFO (PAT$TOKEN_CURRENT_PTR);
%fi

		    PAT$STACK_P [.STACK_PTR, PATSTK_LOCATOR] = LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR);
		    end
		else if not .VALID_PREV
		    then begin
		    move_token (PAT$STACK_P [.STACK_PTR, PATSTK_BASE],
			PREV_STACK_RECORD [PATSTK_BASE]);
		    prev_status = CONSUME_NONTERM_ON_SHIFT;
		    prev_stack_ptr = .stack_ptr;
		    valid_prev = TRUE;
		    prev_will_be_valid = FALSE;
		    end;

		if .STACK_PTR geq (LS_PARSE_STACK_SIZE - 1)
		then
		    begin
		    LS_ERROR_PARSE_STACK_OVERFLOW (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR));
		    return FALSE
		    end
		else
		    begin
		    STACK_PTR = .STACK_PTR + 1;
		    PAT$STACK_P [.STACK_PTR, PATSTK_STATE] = PAT$DATA_AC_TO_SHIFT_STATE (.ACTION_CODE);
						! Now this is the current state
		    end;

		CURRENT_SYMBOL = PAT$TOKEN_GET_CONSUME;
		if .PAT$TOKEN_CURRENT_PTR neq .LATEST_TOKEN_PTR
		then

		! A token has been read that was not read (for a look
		! ahead reduction) earlier. Keep track of the new token
		! and the one read prior to it for use by local error
		! recovery backup.

		    begin
		    PRIOR_TOKEN_PTR = .LATEST_TOKEN_PTR;
		    LATEST_TOKEN_PTR = .PAT$TOKEN_CURRENT_PTR;
		    end;

%if PATBLSEXT_DEBUGGING
%then
		PAT$DEB_TOKEN (TRUE);
%fi

		CURRENT_SYMBOL_IS_TERMINAL = TRUE;
		end
	    else 				! action is reduce or look-ahead
		begin

		if PAT$DATA_ACTION_IS (.ACTION_CODE, 'LOOK_AHEAD')
		then

		! This is a look ahead reduction.

		    begin

		    if .CURRENT_SYMBOL_IS_TERMINAL
		    then
			begin

%if PATBLSEXT_EXTRA_STACK_FIELD
%then
			PAT$STACK_P [.STACK_PTR, PATSTK_EXTRA_INFO] = 0;
%fi

			PAT$STACK_P [.STACK_PTR, PATSTK_LOCATOR] = LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR);
			end;

		    RIGHT_TOKEN_PTR = .PRIOR_TOKEN_PTR;
		    REDUCTION_CODE = PAT$DATA_AC_TO_LA_PRODUCTION_NO (.ACTION_CODE);
		    PAT$DATA_GET_REDUCTION_INFO (.REDUCTION_CODE, LHS_SYMBOL, RHS_COUNT, SEMACT);
		    PAR_LOOKAHEAD_F = TRUE;
		    PAT$TOKEN_SAVE_PERMANENT (.PAT$TOKEN_CURRENT_PTR);
		    NEW_PTR = .STACK_PTR - .RHS_COUNT;

		    if .RHS_COUNT eql 0 then R = .NEW_PTR else R = .NEW_PTR + .RHS_COUNT - 1;

		    end
		else 				! action is reduce
		    begin
		    PAT$STACK_P [.STACK_PTR, PATSTK_SYMBOL] = .CURRENT_SYMBOL;
						! Save the right-most symbol on the rhs

		    if .CURRENT_SYMBOL_IS_TERMINAL
		    then
			begin
			PREV_WILL_BE_VALID = TRUE;
			STATUS = CONSUME_TERM_ON_REDUCTION;

%if PATBLSEXT_EXTRA_STACK_FIELD
%then
			PAT$STACK_P [.STACK_PTR, PATSTK_EXTRA_INFO] = LS_LEX_EXTRA_INFO (PAT$TOKEN_CURRENT_PTR
			);
%fi

			PAT$STACK_P [.STACK_PTR, PATSTK_LOCATOR] = LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR);
			end;

		    RIGHT_TOKEN_PTR = .PAT$TOKEN_CURRENT_PTR;
		    REDUCTION_CODE = PAT$DATA_AC_TO_PRODUCTION_NO (.ACTION_CODE);
		    PAT$DATA_GET_REDUCTION_INFO (.REDUCTION_CODE, LHS_SYMBOL, RHS_COUNT, SEMACT);
		    PAR_LOOKAHEAD_F = FALSE;
		    NEW_PTR = .STACK_PTR - .RHS_COUNT + 1;
		    R = .NEW_PTR + .RHS_COUNT - 1;
		    end;

%if PATBLSEXT_DEBUGGING
%then
		PAT$DEB_REDUCE (.LHS_SYMBOL, .SEMACT, TRUE);
%fi

		if .SEMACT eql PAT$DATA_NULL_SEMACT
		then
		    ACTION_ROUTINE_ALLOWS_BACKUP = (if .RHS_COUNT gtr 1 then LS_REDUCE_NO_ACTION (.NEW_PTR,
			    .R) else TRUE)
		else
		    ACTION_ROUTINE_ALLOWS_BACKUP = LS_REDUCE_ACTION (.SEMACT, .NEW_PTR, .R,
			.PAT$STACK_P [.NEW_PTR, PATSTK_LOCATOR], .RIGHT_TOKEN_PTR);

		CURRENT_SYMBOL = .LHS_SYMBOL;
		REDUCTION_CODE = -1;

		if (.NEW_PTR lss .PREV_STACK_PTR) or ( not .ACTION_ROUTINE_ALLOWS_BACKUP)
		then 				! May not back up past this point
		    begin

		    if .PREV_STATUS neq REDUCT_AFTER_BACKUP_NOT_ALLOWED or
			.STATUS eql CONSUME_TERM_ON_REDUCTION
		    then

		    ! This code saves information to be used (only) for the
		    ! global error message.  It is executed the first time
		    ! a reduction that can not be backed up over occurs
		    ! after a terminal has been consumed.  Its purpose
		    ! is to save enough info so that the list of symbols
		    ! that were expected before the reduction could be
		    ! reconstructed.  If a terminal is actually being
		    ! consumed (as opposed to being seen by look ahead)
		    ! then the state of the parse when it was consumed is
		    ! saved.  Otherwise the state when the last terminal
		    ! was consumed is saved.

			if .CURRENT_SYMBOL_IS_TERMINAL and not .PAR_LOOKAHEAD_F
			then
			    begin
			    GLOBAL_MSG_STATUS = CONSUME_TERM_ON_REDUCTION;
			    GLOBAL_MSG_SYMBOL = .CURRENT_SYMBOL;
			    GLOBAL_MSG_INIT_STATE = .PAT$STACK_P [.STACK_PTR, PATSTK_STATE];
			    end
			else
			    begin
			    GLOBAL_MSG_STATUS = .PREV_STATUS;
			    GLOBAL_MSG_SYMBOL = .PREV_STACK_RECORD [PATSTK_SYMBOL];
			    GLOBAL_MSG_INIT_STATE = .PREV_STACK_RECORD [PATSTK_STATE];
			    end;

		    PREV_WILL_BE_VALID = TRUE;
		    PREV_STATUS = SAVED_INFO_NOT_VALID;
		    STATUS = REDUCT_AFTER_BACKUP_NOT_ALLOWED;
		    end
		else

%if PATBLSEXT_LOCAL_RECOVERY
%then

		    if .NEW_PTR lss .PREV_PREV_STACK_PTR then PREV_PREV_STATUS = SAVED_INFO_NOT_VALID;

%else
		FALSE;
%fi

		STACK_PTR = .NEW_PTR;	! Now the current state is .PAT$STACK_P [.STACK_PTR, PATSTK_STATE]
		PAT$STACK_P [.STACK_PTR, PATSTK_SYMBOL] = .CURRENT_SYMBOL;	! The lhs symbol
		CURRENT_SYMBOL_IS_TERMINAL = FALSE;
		if (.stack_ptr lss .prev_stack_ptr) or
		    (not .action_routine_allows_backup)
		    then begin
		    valid_prev = FALSE;
		    valid_prev_prev = FALSE;
		    prev_will_be_valid = FALSE;
		    end
		else
		    if .stack_ptr lss .prev_prev_stack_ptr
			then valid_prev_prev = FALSE;
		end;

	    end;
	if .PREV_WILL_BE_VALID
	then
	    begin

%if PATBLSEXT_LOCAL_RECOVERY
%then
	    PREV_PREV_STATUS = .PREV_STATUS;

	    if .PREV_PREV_STATUS neq SAVED_INFO_NOT_VALID
	    then
		begin
		PREV_PREV_STACK_PTR = .PREV_STACK_PTR;
		move_token (prev_stack_record [PATSTK_BASE],
		    prev_prev_stack_record [PATSTK_BASE]);
		end;
	    valid_prev_prev = .valid_prev;
%fi

	    PREV_STATUS = .STATUS;
	    PREV_STACK_PTR = .STACK_PTR;
	    move_token (pat$stack_p [.stack_ptr, PATSTK_BASE],
		prev_stack_record [PATSTK_BASE]);
	    valid_prev = TRUE;
	    PREV_WILL_BE_VALID = FALSE;
	    end;

	end;

    return FALSE;
    end;					! Of routine PARSE
routine ERROR_RECOVERY (ANNOUNCE_ABBREVIATIONS) : novalue =

!++
! FUNCTIONAL DESCRIPTION:
!
!	ERROR_RECOVERY causes parser error recovery to occur.
!	It is called when a parse error has been
!	encountered.  It uses information about the state of the parse
!	to recover from the error, but the only data items that may be
!	altered are the token buffer and the stack pointer.
!	One of the macros LS_LOCAL_RECOVERY_INFORM or
!	LS_GLOBAL_RECOVERY_INFORM will be called to make any other
!	adjustments that are required by the recovery.	Thus the parse
!	can be resumed after this routine resumes by reading from the
!	token buffer (which the parser does anyway).
!
! FORMAL PARAMETERS:
!
!	ANNOUNCE_ABBREVIATIONS	- TRUE iff an error message should be printed
!				  when an abbreviation is corrected.
!
! IMPLICIT INPUTS:
!
!	Token buffer
!
!	Stack pointer
!
!	Parse stack
!
!	State information
!
! IMPLICIT OUTPUTS:
!
!	Token buffer
!
!	Stack pointer
!
! ROUTINE VALUE:
!
!	NONE
!
! SIDE EFFECTS:
!
!	The token buffer will be altered to correct the error.
!	LS_*_RECOVERY_INFORM may cause other side effects.
!
!--

    begin

    local
	SUCCESS;

    DEB_EVENT ('PAR_RECOVERY_START',
	PUT_MSG_EOL ('Starting parser error recovery')

%if PATBLSEXT_LOCAL_RECOVERY
%then
    ,
	PAT$DUMP_BACKUP_INFO ()
%fi

    );
    LS_SAVE_TOKEN (.PAT$TOKEN_CURRENT_PTR);	! Save the error token
    ORIGINAL_STACK_PTR = .STACK_PTR;

%if PATBLSEXT_LOCAL_RECOVERY
%then
    SUCCESS = LOCAL_RECOVERY (.ANNOUNCE_ABBREVIATIONS);
%else
    SUCCESS = FALSE;
%fi

    if not .SUCCESS
    then
	begin
	PAT$ERROR_GLOBAL_RECOVERY (
	! Input parameters
	    PREV_STACK_RECORD,
	    .PREV_STATUS,
	    .GLOBAL_MSG_STATUS,
	    .GLOBAL_MSG_SYMBOL,
	    .GLOBAL_MSG_INIT_STATE,
	    LS_RETURN_SAVED_TOKEN,
	! Output parameters
	    STACK_PTR, CURRENT_SYMBOL);
	LS_GLOBAL_RECOVERY_INFORM (.STACK_PTR, .ORIGINAL_STACK_PTR);

	!   When global error recovery occurs, reset LATEST_TOKEN_PTR
	!   to the current pointer, since its old value is no
	!   longer valid.

	LATEST_TOKEN_PTR = .PAT$TOKEN_CURRENT_PTR;

	end;

    PREV_STATUS = SAVED_INFO_NOT_VALID;

%if PATBLSEXT_LOCAL_RECOVERY
%then
    PREV_PREV_STATUS = SAVED_INFO_NOT_VALID;
%fi

    DEB_EVENT ('PAR_RECOVERY_END',
	PUT_MSG ('Ending parser error recovery.  Resume parse on:  '),
	PUT_STRING (PAT$DATA_SYMBOL_TEXT (.CURRENT_SYMBOL)),
	PUT_EOL (),
	PUT_EOL ());
    end;					! Of routine ERROR_RECOVERY
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine LOCAL_RECOVERY (ANNOUNCE_ABBREVIATIONS) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	LOCAL_RECOVERY is the main driver for local and scope
!	recovery.
!
! FORMAL PARAMETERS:
!
!	ANNOUNCE_ABBREVIATIONS	- TRUE iff an error message should be printed
!				  when an abbreviation is corrected.
!
! IMPLICIT INPUTS:
!
!	Token buffer
!
!	Stack pointer
!
!	Parse stack
!
!	State information
!
! IMPLICIT OUTPUTS:
!
!	Token buffer
!
!	Stack pointer
!
! ROUTINE VALUE:
!
!	NONE
!
! SIDE EFFECTS:
!
!	The token buffer will be altered to correct the error.
!	LS_*_RECOVERY_INFORM may cause other side effects.
!
!--

    begin

    local
	ORDER,
	SUCCESS,
!	error_token_ptr,
!	error_detected_state,
!	error_prev_state,
!	backup_possible,
	SAVED_STACK_RECORD : block [PATSTK_STR_SIZE/%upval] field (PATSTK_FIELDS);
! Set up for local error recovery:

!error_token_ptr = .pat$token_current_ptr;
!error_detected_state = .pat$stack_p [.stack_ptr, PATSTK_STATE];
!error_prev_state =
!    (if .valid_prev
!	then .prev_stack_record [PATSTK_STATE]
!	else .error_detected_state);
!original_stack_ptr = .stack_ptr;
!move_token (pat$stack_p [.stack_ptr, PATSTK_BASE],
!    saved_stack_record [PATSTK_BASE]);
!
! Try recovery from state B:
!
!if .valid_prev and (.prev_status neq CONSUME_NONTERM_ON_SHIFT)
!    then begin		! Try from state B
!    stack_ptr = .prev_stack_ptr;
!    move_token (prev_stack_record [PATSTK_BASE],
!	pat$stack_p [.stack_ptr, PATSTK_BASE]);
!    end;
!local_attempt_status = .prev_status;
!backup_possible = .valid_prev and (.prev_status eql CONSUME_TERM_ON_REDUCTION);
!if .backup_possible
!    then parse_ahead_init (.prev_stack_record [PATSTK_SYMBOL])
!    else parse_ahead_init (NO_INITIAL_SYMBOL);
!deb_event ('PAR_LOCAL_REC_B_S',
!    put_msg_eol ('Begin local error recovery in state B.'));
!success = strong_local_recovery (FALSE, .announce_abbreviations);
!if not .success
!    then success = weak_local_recovery (FALSE);
!if .success
!    then ls_local_recovery_inform (FALSE, TRUE,
!	(.stack_ptr neq .original_stack_ptr), .stack_ptr, .original_stack_ptr);
!deb_event ('PAR_LOCAL_REC_B_E',
!    put_msg_eol ('End local error recovery in state B.'));
!! Try recovery from state C:
!
!if (.valid_prev_prev) and (not .success)
!    then begin		! Try from state C
!    local_attempt_status = .prev_prev_status;
!    pat$token_save (.error_token_ptr, TRUE);	! Save error token in token buffer
!    pat$token_current_ptr = .prior_token_ptr;
!    current_symbol = ls_lex_term (pat$token_current_ptr);
!    stack_ptr = .prev_prev_stack_ptr;
!    move_token (prev_prev_stack_record [PATSTK_BASE],
!	pat$stack_p [.stack_ptr, PATSTK_BASE]);
!    if (.prev_prev_status eql CONSUME_TERM_ON_REDUCTION)
!	then parse_ahead_init (.prev_prev_stack_record [PATSTK_SYMBOL])
!	else parse_ahead_init (NO_INITIAL_SYMBOL);
!    deb_event ('PAR_LOCAL_REC_C_S',
!	put_msg_eol ('Begin local error recovery in state C.'));
!    success = strong_local_recovery (TRUE, .announce_abbreviations);
!    if not .success
!	then success = weak_local_recovery (TRUE);
!    if not .success
!	then pat$token_get (TRUE)	! Remove error token from token list
!	else ls_local_recovery_inform (TRUE, TRUE, TRUE, .stack_ptr,
!	    .original_stack_ptr);
!    deb_event ('PAR_LOCAL_REC_C_E',
!	put_msg_eol ('End local error recovery in state C.'));
!    end;
!! Try recovery from state A:
!
!if (.backup_possible and (not .success))
!    then begin		! Try from state A (no backup, getting default reductions)
!    local_attempt_status = ERROR_ENCOUNTERED;
!    pat$token_current_ptr = .error_token_ptr;
!    current_symbol = ls_lex_term (pat$token_current_ptr);
!    stack_ptr = .original_stack_ptr;
!    move_token (saved_stack_record [PATSTK_BASE],
!	pat$stack_p [.stack_ptr, PATSTK_BASE]);
!    parse_ahead_init (NO_INITIAL_SYMBOL);
!    deb_event ('PAR_LOCAL_REC_A_S',
!	put_msg_eol ('Begin local error recovery in state A.'));
!    success = strong_local_recovery (FALSE, .announce_abbreviations);
!    if not .success
!	then success = weak_local_recovery (FALSE);
!    if .success
!	then ls_local_recovery_inform (FALSE, FALSE, FALSE,
!	    VALUE_TO_BE_IGNORED, VALUE_TO_BE_IGNORED);
!    deb_event ('PAR_LOCAL_REC_A_E',
!	put_msg_eol ('End local error recovery in state A.'));
!    end;
!
!valid_prev = FALSE;
!valid_prev_prev = FALSE;
!
!! Clean up after failure of local recovery:
!
!if not .success
!    then begin
!    stack_ptr = .original_stack_ptr;
!    move_token (saved_stack_record [PATSTK_BASE],
!	pat$stack_p [.stack_ptr, PATSTK_BASE]);
!    end;
!
!return .success;
!end;
    SUCCESS = FALSE;
    ORDER = FIND_BACKUP_ORDER (.PREV_STATUS, .PREV_PREV_STATUS);

    ! Attempt strong local error recovery (types of corrections
    ! that have a strong chance of being correct)

!    selectone .ORDER of
!	set
!
!	[ORDER_A] :
!
!	    ! Start from state A (state when error was encountered--no backup)
!
!	    begin
!	    LOCAL_ATTEMPT_STATUS = ERROR_ENCOUNTERED;
!	    PARSE_AHEAD_INIT (NO_INITIAL_SYMBOL);
!	    SUCCESS = STRONG_LOCAL_RECOVERY (FALSE, .ANNOUNCE_ABBREVIATIONS);
!
!	    if .SUCCESS
!	    then
!		LS_LOCAL_RECOVERY_INFORM (FALSE, FALSE, FALSE, VALUE_TO_BE_IGNORED,
!		    VALUE_TO_BE_IGNORED);
!
!	    end;
!
!	[otherwise] :
!	;
!	tes;
    if not .SUCCESS
    then

	selectone .ORDER of
	    set

	    [ORDER_B, ORDER_BC] :

		! Try from state B (error state, before default reductions)

		begin
		deb_event ('PAR_LOCAL_REC_B_S_S',
		    put_msg_eol ('Begin strong recovery in state B.'));
		LOCAL_ATTEMPT_STATUS = .PREV_STATUS;
		STACK_PTR = .PREV_STACK_PTR;
		move_token (PAT$STACK_P [.STACK_PTR, PATSTK_BASE],
		    SAVED_STACK_RECORD [PATSTK_BASE]);
		move_token (PREV_STACK_RECORD [PATSTK_BASE],
		    PAT$STACK_P [.STACK_PTR, PATSTK_BASE]);

		selectone .PREV_STATUS of
		    set

		    [CONSUME_TERM_ON_REDUCTION, REDUCT_AFTER_BACKUP_NOT_ALLOWED] :
			PARSE_AHEAD_INIT (.PREV_STACK_RECORD [PATSTK_SYMBOL]);

		    [otherwise] :
			PARSE_AHEAD_INIT (NO_INITIAL_SYMBOL);
		    tes;

		SUCCESS = STRONG_LOCAL_RECOVERY (FALSE, .ANNOUNCE_ABBREVIATIONS);

		if .SUCCESS
		then
		    LS_LOCAL_RECOVERY_INFORM (FALSE, TRUE, (.STACK_PTR neq .ORIGINAL_STACK_PTR),
			.STACK_PTR, .ORIGINAL_STACK_PTR)
		else
		    move_token (SAVED_STACK_RECORD [PATSTK_BASE],
			PAT$STACK_P [.STACK_PTR, PATSTK_BASE]);

		deb_event ('PAR_LOCAL_REC_B_S_E',
		    put_msg_eol ('End strong recovery from state B.'));
		end;

	    [otherwise] :
	    ;
	    tes;
    if not .SUCCESS
    then

	selectone .ORDER of
	    set

	    [ORDER_BC] :

		! Try from state C (token before error, before default reductions)

		begin
		deb_event ('PAR_LOCAL_REC_C_S_S',
		    put_msg_eol ('Begin strong local recovery in state C'));
		LOCAL_ATTEMPT_STATUS = .PREV_PREV_STATUS;
		PAT$TOKEN_SAVE (.LATEST_TOKEN_PTR, TRUE);	! Save error token in token buffer
		PAT$TOKEN_CURRENT_PTR = .PRIOR_TOKEN_PTR;
		CURRENT_SYMBOL = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);
		STACK_PTR = .PREV_PREV_STACK_PTR;
		move_token (PAT$STACK_P [.STACK_PTR, PATSTK_BASE],
		    SAVED_STACK_RECORD [PATSTK_BASE]);
		move_token (PREV_PREV_STACK_RECORD [PATSTK_BASE],
		    PAT$STACK_P [.STACK_PTR, PATSTK_BASE]);

		selectone .PREV_PREV_STATUS of
		    set

		    [CONSUME_TERM_ON_REDUCTION, REDUCT_AFTER_BACKUP_NOT_ALLOWED] :
			PARSE_AHEAD_INIT (.PREV_PREV_STACK_RECORD [PATSTK_SYMBOL]);

		    [otherwise] :
			PARSE_AHEAD_INIT (NO_INITIAL_SYMBOL);
		    tes;

		SUCCESS = STRONG_LOCAL_RECOVERY (TRUE, .ANNOUNCE_ABBREVIATIONS);

		if .SUCCESS
		then
		    LS_LOCAL_RECOVERY_INFORM (TRUE, TRUE, TRUE, .STACK_PTR, .ORIGINAL_STACK_PTR)
		else
		    begin
		    move_token (SAVED_STACK_RECORD [PATSTK_BASE],
			PAT$STACK_P [.STACK_PTR, PATSTK_BASE]);
		    PAT$TOKEN_GET (TRUE);	! Get error token back from token buffer
		    end;
		deb_event ('PAR_LOCAL_REC_C_S_E',
		    put_msg_eol ('End strong local recovery in state C.'));

		end;

	    [otherwise] :
	    ;
	    tes;
if not .SUCCESS	! Move this code here.  Always try A afer BC and B!

	then

	    ! Start from state A (state when error was encountered--no backup)

	    begin
	    deb_event ('PAR_LOCAL_REC_A_S_S',
		put_msg_eol ('Begin strong local recovery in state A.'));
	    LOCAL_ATTEMPT_STATUS = ERROR_ENCOUNTERED;
	    PARSE_AHEAD_INIT (NO_INITIAL_SYMBOL);
	    SUCCESS = STRONG_LOCAL_RECOVERY (FALSE, .ANNOUNCE_ABBREVIATIONS);

	    if .SUCCESS
	    then
		LS_LOCAL_RECOVERY_INFORM (FALSE, FALSE, FALSE, VALUE_TO_BE_IGNORED,
		    VALUE_TO_BE_IGNORED);

	    deb_event ('PAR_LOCAL_REC_A_S_E',
		put_msg_eol ('End strong local recovery from state A.'));
	    end;
!    if not .SUCCESS
!    then
!
!    ! Attempt weak local error recovery (types of corrections
!    ! that have a weak chance of being correct)
!
!	selectone .ORDER of
!	    set
!
!	    [ORDER_A] :
!
!		! Start from state A (state when error was encountered--no backup)
!
!		begin
!		LOCAL_ATTEMPT_STATUS = ERROR_ENCOUNTERED;
!		PARSE_AHEAD_INIT (NO_INITIAL_SYMBOL);
!		SUCCESS = WEAK_LOCAL_RECOVERY (FALSE);
!
!		if .SUCCESS
!		then
!		    LS_LOCAL_RECOVERY_INFORM (FALSE, FALSE, FALSE, VALUE_TO_BE_IGNORED,
!			VALUE_TO_BE_IGNORED);
!
!		end;
!
!	    [otherwise] :
!	    ;
!	    tes;
! Attempt weak local error recovery (types of corrections
! that have a weak chance of being correct)

    if not .SUCCESS
    then

	selectone .ORDER of
	    set

	    [ORDER_B, ORDER_BC] :

		! Try from state B (error state, before default reductions)

		begin
		deb_event ('PAR_LOCAL_REC_B_W_S',
		    put_msg_eol ('Begin weak local recovery in state B.'));
		LOCAL_ATTEMPT_STATUS = .PREV_STATUS;
		STACK_PTR = .PREV_STACK_PTR;
		move_token (PAT$STACK_P [.STACK_PTR, PATSTK_BASE],
		    SAVED_STACK_RECORD [PATSTK_BASE]);
		move_token (PREV_STACK_RECORD [PATSTK_BASE],
		    PAT$STACK_P [.STACK_PTR, PATSTK_BASE]);

		selectone .PREV_STATUS of
		    set

		    [CONSUME_TERM_ON_REDUCTION, REDUCT_AFTER_BACKUP_NOT_ALLOWED] :
			PARSE_AHEAD_INIT (.PREV_STACK_RECORD [PATSTK_SYMBOL]);

		    [otherwise] :
			PARSE_AHEAD_INIT (NO_INITIAL_SYMBOL);
		    tes;

		SUCCESS = WEAK_LOCAL_RECOVERY (FALSE);

		if .SUCCESS
		then
		    LS_LOCAL_RECOVERY_INFORM (FALSE, TRUE, (.STACK_PTR neq .ORIGINAL_STACK_PTR),
			.STACK_PTR, .ORIGINAL_STACK_PTR)
		else
		    move_token (SAVED_STACK_RECORD [PATSTK_BASE],
			PAT$STACK_P [.STACK_PTR, PATSTK_BASE]);

		deb_event ('PAR_LOCAL_REC_B_W_E',
		    put_msg_eol ('End weak local recovery in state B.'));
		end;

	    [otherwise] :
	    ;
	    tes;
    if not .SUCCESS
    then

	selectone .ORDER of
	    set

	    [ORDER_BC] :

		! Try from state C (token before error state, before any default reductions)

		begin
		deb_event ('PAR_LOCAL_REC_C_W_S',
		    put_msg_eol ('Begin weak local recovery in state C.'));
		LOCAL_ATTEMPT_STATUS = .PREV_PREV_STATUS;
		PAT$TOKEN_SAVE (.LATEST_TOKEN_PTR, TRUE);	! Save error token in token buffer
		PAT$TOKEN_CURRENT_PTR = .PRIOR_TOKEN_PTR;
		CURRENT_SYMBOL = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);
		STACK_PTR = .PREV_PREV_STACK_PTR;
		move_token (PAT$STACK_P [.STACK_PTR, PATSTK_BASE],
		    SAVED_STACK_RECORD [PATSTK_BASE]);
		move_token (PREV_PREV_STACK_RECORD [PATSTK_BASE],
		    PAT$STACK_P [.STACK_PTR, PATSTK_BASE]);

		selectone .PREV_PREV_STATUS of
		    set

		    [CONSUME_TERM_ON_REDUCTION, REDUCT_AFTER_BACKUP_NOT_ALLOWED] :
			PARSE_AHEAD_INIT (.PREV_PREV_STACK_RECORD [PATSTK_SYMBOL]);

		    [otherwise] :
			PARSE_AHEAD_INIT (NO_INITIAL_SYMBOL);
		    tes;

		SUCCESS = WEAK_LOCAL_RECOVERY (TRUE);

		if .SUCCESS
		then
		    LS_LOCAL_RECOVERY_INFORM (TRUE, TRUE, TRUE, .STACK_PTR, .ORIGINAL_STACK_PTR)
		else
		    begin
		    move_token (SAVED_STACK_RECORD [PATSTK_BASE],
			PAT$STACK_P [.STACK_PTR, PATSTK_BASE]);
		    PAT$TOKEN_GET (TRUE);	! Get error token back from token buffer
		    end;

		deb_event ('PAR_LOCAL_REC_C_W_E',
		    put_msg_eol ('End weak local recovery in state C.'));
		end;

	    [otherwise] :
	    ;
	    tes;
    if not .SUCCESS	! Move this code here.  Always true A after BC and B

    then

		! Start from state A (state when error was encountered--no backup)

		begin
		deb_event ('PAR_LOCAL_REC_A_W_S',
		    put_msg_eol ('Begin weak local recovery in state A.'));
		LOCAL_ATTEMPT_STATUS = ERROR_ENCOUNTERED;
		PARSE_AHEAD_INIT (NO_INITIAL_SYMBOL);
		SUCCESS = WEAK_LOCAL_RECOVERY (FALSE);

		if .SUCCESS
		then
		    LS_LOCAL_RECOVERY_INFORM (FALSE, FALSE, FALSE, VALUE_TO_BE_IGNORED,
			VALUE_TO_BE_IGNORED);

		deb_event ('PAR_LOCAL_REC_A_W_E',
		    put_msg_eol ('End weak local recovery in state A.'));
		end;
    if not .SUCCESS
    then
	begin
	PAT$TOKEN_CURRENT_PTR = .LATEST_TOKEN_PTR;
	CURRENT_SYMBOL = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);
	STACK_PTR = .ORIGINAL_STACK_PTR;
	end;

    return .SUCCESS
    end;					! Of routine LOCAL_RECOVERY
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine PARSE_AHEAD (TOKENS_TO_TRY) =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Try to parse ahead after a trial error recovery.
!
! FORMAL PARAMETERS:
!
!	TOKENS_TO_TRY	Number of tokens to parse ahead.
!
! IMPLICIT INPUTS:
!
!	STACK_PTR
!	INITIAL_SYMBOL
!	PAT$STACK_P
!
! IMPLICIT OUTPUTS:
!
!	None.
!
! ROUTINE VALUE:
!
!	TRUE if parse ahead succeeded; FALSE if produced an error or
!	overflowed the parse stack.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    macro
	RESET_STACK =
	    begin
	    STACK_PTR = .SAVED_STACK_PTR;
	    incr P from 1 to (.STACK_PTR + 1) do
		begin
		ref_alt_parse_stack [.P-1, PATSTK_LOCATOR]
		    = .ref_parse_stack [.P-1, PATSTK_LOCATOR];
		%if PATBLSEXT_EXTRA_STACK_FIELD
		%then
		ref_alt_parse_stack [.P-1, PATSTK_EXTRA_INFO]
		    = .ref_parse_stack [.P-1, PATSTK_EXTRA_INFO];
		%fi
		ref_alt_parse_stack [.P-1, PATSTK_SYMBOL]
		    = .ref_parse_stack [.P-1, PATSTK_SYMBOL];
		ref_alt_parse_stack [.P-1, PATSTK_TOKEN]
		    = .ref_parse_stack [.P-1, PATSTK_TOKEN];
		ref_alt_parse_stack [.P-1, PATSTK_ERRORMARK]
		    = .ref_parse_stack [.P-1, PATSTK_ERRORMARK];
		ref_alt_parse_stack [.P-1, PATSTK_STATE]
		    = .ref_parse_stack [.P-1, PATSTK_STATE];
		end;
	    end%;
    local
	CURRENT_SYMBOL_IS_TERMINAL,
	SAVED_TEMP_HEAD,
	ACTION_CODE,
	TOKENS_TRIED,
	HOLDING_SECOND_TOKEN,
	SECOND_TOKEN_PTR,
	LHS_SYMBOL,
	RHS_COUNT,
	SEMACT,
	NEW_PTR;

    SAVED_TEMP_HEAD = PAT$TOKEN_TEMP_HEAD ();
    TOKENS_TRIED = 0;

    if .HAVE_INITIAL_SYMBOL
    then
	begin
	SECOND_TOKEN_PTR = .PAT$TOKEN_CURRENT_PTR;
	HOLDING_SECOND_TOKEN = TRUE;
	CURRENT_SYMBOL = .INITIAL_SYMBOL;
	CURRENT_SYMBOL_IS_TERMINAL = FALSE;
	end
    else
	begin
	HOLDING_SECOND_TOKEN = FALSE;
	CURRENT_SYMBOL_IS_TERMINAL = TRUE;
	end;

    while (.TOKENS_TO_TRY gtr .TOKENS_TRIED) do
	begin

%if PATBLSEXT_DEBUGGING
%then
	PAT$DEB_STATE (.PAT$STACK_P [.STACK_PTR, PATSTK_STATE], FALSE);
%fi

	if .CURRENT_SYMBOL eql LS_STOP_PARSING_NT
	then 					! Compilation complete
	    begin
	    PAT$TOKEN_SET_TEMP_HEAD (.SAVED_TEMP_HEAD);
	    RESET_STACK;
	    return TRUE;
	    end;

	ACTION_CODE = PAT$DATA_MOVE_ACTION (.PAT$STACK_P [.STACK_PTR, PATSTK_STATE], .CURRENT_SYMBOL);

	if PAT$DATA_ACTION_IS (.ACTION_CODE, 'ERROR')
	then
	    begin
	    PAT$TOKEN_SET_TEMP_HEAD (.SAVED_TEMP_HEAD);
	    RESET_STACK;
	    return FALSE;
	    end
	else
	    begin

	    if PAT$DATA_ACTION_IS (.ACTION_CODE, 'SHIFT')
	    then
		begin

		! Save the symbol that was found on the stack and push the
		! new state on the stack.

		PAT$STACK_P [.STACK_PTR, PATSTK_SYMBOL] = .CURRENT_SYMBOL;

		if .CURRENT_SYMBOL_IS_TERMINAL
		then
		    PAT$STACK_P [.STACK_PTR, PATSTK_LOCATOR] = LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR);

		if .STACK_PTR geq (LS_PARSE_STACK_SIZE - 1)
		then
		    begin

		    ! Stack overflow so parse ahead not successful.

		    PAT$TOKEN_SET_TEMP_HEAD (.SAVED_TEMP_HEAD);
		    RESET_STACK;
		    return FALSE;
		    end
		else
		    begin
		    STACK_PTR = .STACK_PTR + 1;
		    PAT$STACK_P [.STACK_PTR, PATSTK_STATE] = PAT$DATA_AC_TO_SHIFT_STATE (.ACTION_CODE);
						! Now this is the current state
		    end;

		if .HOLDING_SECOND_TOKEN
		then
		    begin
		    PAT$TOKEN_CURRENT_PTR = .SECOND_TOKEN_PTR;
		    CURRENT_SYMBOL = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);
		    HOLDING_SECOND_TOKEN = FALSE;
		    end
		else
		    begin
		    CURRENT_SYMBOL = PAT$TOKEN_GET (FALSE);
		    TOKENS_TRIED = .TOKENS_TRIED + 1;
		    end;

%if PATBLSEXT_DEBUGGING
%then
		PAT$DEB_TOKEN (FALSE);
%fi

		CURRENT_SYMBOL_IS_TERMINAL = TRUE;
		end
	    else 				! action is reduce or look-ahead
		begin

		if PAT$DATA_ACTION_IS (.ACTION_CODE, 'LOOK_AHEAD')
		then

		! This is a look ahead reduction.

		    begin

		    if .CURRENT_SYMBOL_IS_TERMINAL then PAT$STACK_P [.STACK_PTR, PATSTK_LOCATOR] = 0;

		    REDUCTION_CODE = PAT$DATA_AC_TO_LA_PRODUCTION_NO (.ACTION_CODE);
		    PAT$DATA_GET_REDUCTION_INFO (.REDUCTION_CODE, LHS_SYMBOL, RHS_COUNT, SEMACT);
		    PAR_LOOKAHEAD_F = TRUE;
		    DEB_ASSERT (( not .HOLDING_SECOND_TOKEN),
			'Trying to save token while holding second token.');
		    PAT$TOKEN_SAVE (.PAT$TOKEN_CURRENT_PTR, FALSE);
		    TOKENS_TRIED = .TOKENS_TRIED - 1;
		    NEW_PTR = .STACK_PTR - .RHS_COUNT;
		    end
		else 				! action is reduce
		    begin
		    PAT$STACK_P [.STACK_PTR, PATSTK_SYMBOL] = .CURRENT_SYMBOL;
						! Save the right-most symbol on the rhs

		    if .CURRENT_SYMBOL_IS_TERMINAL
		    then
			PAT$STACK_P [.STACK_PTR, PATSTK_LOCATOR] = LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR);

		    REDUCTION_CODE = PAT$DATA_AC_TO_PRODUCTION_NO (.ACTION_CODE);
		    PAT$DATA_GET_REDUCTION_INFO (.REDUCTION_CODE, LHS_SYMBOL, RHS_COUNT, SEMACT);
		    PAR_LOOKAHEAD_F = FALSE;
		    NEW_PTR = .STACK_PTR - .RHS_COUNT + 1;
		    end;

%if PATBLSEXT_DEBUGGING
%then
		PAT$DEB_REDUCE (.LHS_SYMBOL, .SEMACT, FALSE);
%fi

		CURRENT_SYMBOL = .LHS_SYMBOL;
		REDUCTION_CODE = -1;
		STACK_PTR = .NEW_PTR;	! Now the current state is .PAT$STACK_P [.STACK_PTR, PATSTK_STATE]
		PAT$STACK_P [.STACK_PTR, PATSTK_SYMBOL] = .CURRENT_SYMBOL;	! the lhs symbol
		CURRENT_SYMBOL_IS_TERMINAL = FALSE;
		end;

	    end

	end;

    PAT$TOKEN_SET_TEMP_HEAD (.SAVED_TEMP_HEAD);
    RESET_STACK;
    return TRUE
    end;					! Of routine PARSE_AHEAD
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine PARSE_AHEAD_INIT (INIT_SYMBOL) : novalue =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Initialize for parse ahead during error recovery.
!
! FORMAL PARAMETERS:
!
!	INIT_SYMBOL	potential initial token.
!
! IMPLICIT INPUTS:
!
!	INITIAL_SYMBOL
!
! IMPLICIT OUTPUTS:
!
!	None.
!
! ROUTINE VALUE:
!
!	None.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin
    HAVE_INITIAL_SYMBOL = (.INIT_SYMBOL neq NO_INITIAL_SYMBOL);
    if .HAVE_INITIAL_SYMBOL
	then INITIAL_SYMBOL = .INIT_SYMBOL;
    end;					! Of routine PARSE_AHEAD_INIT
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine STRONG_LOCAL_RECOVERY (HAVE_BACKED_UP_OVER_A_TOKEN, ANNOUNCE_ABBREVIATIONS) =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Try corrections that have a strong chance of being correct:
!		End-of-line corrections (if this is first token on a new line)
!		Token merging
!		Spelling corrections
!
! FORMAL PARAMETERS:
!
!	HAVE_BACKED_UP_OVER_A_TOKEN	(not used)
!	ANNOUNCE_ABBREVIATIONS		Parameter to TRY_CORRECT_SPELLING
!
! IMPLICIT INPUTS:
!
!	PAT$STACK_P
!	HAVE_INITIAL_SYMBOL
!	INITIAL_SYMBOL
!
! IMPLICIT OUTPUTS:
!
!	CURRENT_SYMBOL_IS_TERMINAL
!	CURRENT_SYMBOL
!
! ROUTINE VALUE:
!
!	TRUE if error recovery was successful, otherwise FALSE.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    local
	SUCCESS;

    label
	TRYS;

    PAT$TOKEN_SAVE (.PAT$TOKEN_CURRENT_PTR, TRUE);	! Save error token
    SAVE_STATE ();				! Save state of the parse
    PAT$STACK_P = .REF_ALT_PARSE_STACK;		! Use alternate parse stack
    DEB_EVENT ('PAR_RECOVERY_LOCAL',
	PUT_MSG_EOL ('-----------------------------------------------------'),
	PUT_MSG ('Starting strong local recovery - the current state is '),
	PUT_NUMBER (.PAT$STACK_P [.STACK_PTR, PATSTK_STATE]),
	PUT_MSG_EOL ('.'),
	PUT_MSG ('Current symbol is '),
	PUT_STRING (PAT$DATA_SYMBOL_TEXT (.CURRENT_SYMBOL)),
	PUT_MSG_EOL ('.'));
TRYS :
    begin

    if LS_LEX_START_LINE (PAT$TOKEN_CURRENT_PTR)
    then
	begin
	if (SUCCESS = TRY_EOL_CORRECTION ()) then leave TRYS;
	RESTORE_STATE ();
	end;

    if (SUCCESS = TRY_MERGE ()) then leave TRYS;

    RESTORE_STATE ();

    if (SUCCESS = TRY_CORRECT_SPELLING (.ANNOUNCE_ABBREVIATIONS)) then leave TRYS;

    RESTORE_STATE ();
    end;					! Of loop TRYS

    DEB_EVENT ('PAR_RECOVERY_LOCAL',
	PUT_EOL (),

	if .SUCCESS
	then
	    PUT_MSG_EOL ('Strong local error recovery successful')
	else
	    PUT_MSG_EOL ('Strong local error recovery not successful'),

	PUT_MSG_EOL ('-----------------------------------------------------'),
	PUT_EOL ());
    RESTORE_STATE ();
    PAT$STACK_P = .REF_PARSE_STACK;		! Use normal parse stack

    if (.HAVE_INITIAL_SYMBOL and .SUCCESS)
    then
	begin
	CURRENT_SYMBOL = .INITIAL_SYMBOL;
	CURRENT_SYMBOL_IS_TERMINAL = FALSE;
	end
    else
	begin
	CURRENT_SYMBOL = PAT$TOKEN_GET (TRUE);
	CURRENT_SYMBOL_IS_TERMINAL = TRUE;
	end;

    return .SUCCESS
    end;					! Of routine STRONG_LOCAL_RECOVERY
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine WEAK_LOCAL_RECOVERY (HAVE_BACKED_UP_OVER_A_TOKEN) =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Try corrections that have a weak chance of being correct:
!		token substitutions
!		token insertions
!		scope recovery
!		token deletion
!
! FORMAL PARAMETERS:
!
!	HAVE_BACKED_UP_OVER_A_TOKEN	TRUE if have backed up
!					over a token.
!
! IMPLICIT INPUTS:
!
!	PAT$STACK_P
!	INITIAL_SYMBOL
!
! IMPLICIT OUTPUTS:
!
!	CURRENT_SYMBOL
!	CURRENT_SYMBOL_IS_TERMINAL
!
! ROUTINE VALUE:
!
!	TRUE if recovery succeeded, otherwise FALSE.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    local
	SUCCESS;

    label
	TRYS;

    PAT$TOKEN_SAVE (.PAT$TOKEN_CURRENT_PTR, TRUE);	! Save error token
    SAVE_STATE ();				! Save state of the parse
    PAT$STACK_P = .REF_ALT_PARSE_STACK;		! Use alternate parse stack
    DEB_EVENT ('PAR_RECOVERY_LOCAL',
	PUT_MSG_EOL ('-----------------------------------------------------'),
	PUT_MSG ('Starting weak local recovery - the current state is '),
	PUT_NUMBER (.PAT$STACK_P [.STACK_PTR, PATSTK_STATE]),
	PUT_MSG_EOL ('.'),
	PUT_MSG ('Current symbol is '),
	PUT_STRING (PAT$DATA_SYMBOL_TEXT (.CURRENT_SYMBOL)),
	PUT_MSG_EOL ('.'));
TRYS :
    begin

    incr PRIORITY from 1 to 4 do
	begin

	if LR_SUB_PRIORITY eql .PRIORITY
	then
	    begin
	    if (SUCCESS = TRY_SUBSTITUTE ()) then leave TRYS;
	    RESTORE_STATE ()
	    end;

	if LR_INSERT_PRIORITY eql .PRIORITY
	then
	    begin
	    if (SUCCESS = TRY_INSERT ()) then leave TRYS;
	    RESTORE_STATE ()
	    end;

	if (LR_SCOPE_PRIORITY eql .PRIORITY) and not .HAVE_BACKED_UP_OVER_A_TOKEN
	then
	    begin
	    if (SUCCESS = SCOPE_RECOVERY (FALSE)) then leave TRYS;
	    RESTORE_STATE ();
	    end;

	if LR_DELETE_PRIORITY eql .PRIORITY
	then
	    begin
	    if (SUCCESS = TRY_DELETE ()) then leave TRYS;
	    RESTORE_STATE ()
	    end;

	end;

    end;					! Of loop TRYS
    DEB_EVENT ('PAR_RECOVERY_LOCAL',
	PUT_EOL (),

	if .SUCCESS
	then
	    PUT_MSG_EOL ('Weak local error recovery successful')
	else
	    PUT_MSG_EOL ('Weak local error recovery not successful'),

	PUT_MSG_EOL ('-----------------------------------------------------'),
	PUT_EOL ());
    RESTORE_STATE ();
    PAT$STACK_P = .REF_PARSE_STACK;		! Use normal parse stack

    if (.HAVE_INITIAL_SYMBOL and .SUCCESS)
    then
	begin
	CURRENT_SYMBOL = .INITIAL_SYMBOL;
	CURRENT_SYMBOL_IS_TERMINAL = FALSE;
	end
    else
	begin
	CURRENT_SYMBOL = PAT$TOKEN_GET (TRUE);
	CURRENT_SYMBOL_IS_TERMINAL = TRUE;
	end;

    return .SUCCESS
    end;					! Of routine WEAK_LOCAL_RECOVERY
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine TRY_EOL_CORRECTION =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Attempt an end-of-line correction by seeing what happens if the previous
!	text line ends with an end-of-statement token.
!
!   This routine is never called if LS_LEX_START_LINE always returns
!   FALSE.
!
! FORMAL PARAMETERS:
!
!	None.
!
! IMPLICIT INPUTS:
!
!	PAT$TOKEN_CURRENT_PTR
!
! IMPLICIT OUTPUTS:
!
!	CURRENT_SYMBOL
!
! ROUTINE VALUE:
!
!	Returns TRUE if the result parsed, FALSE otherwise.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    local
	NEW_TOKEN,
	ERROR_LOC;

    DEB_ASSERT (LS_LEX_START_LINE (PAT$TOKEN_CURRENT_PTR), '[TRY_EOL_CORRECTION]');
    DEB_EVENT ('PAR_RECOVERY_LOCAL',
	PUT_EOL (),
	PUT_MSG_EOL ('Trying end of line correction'));
    PAT$TOKEN_GET (FALSE);			! Examine error token
    ERROR_LOC = LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR);
    PAT$TOKEN_RESET_BUFFER ();
    NEW_TOKEN = SYNTHESIZE_TOKEN (LS_T_SEMICOLON);
    PAT$TOKEN_CURRENT_PTR = .NEW_TOKEN;
    CURRENT_SYMBOL = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);

    if PARSE_AHEAD (PARSE_AHEAD_EOL)
    then
	begin
	PAT$TOKEN_SAVE (.NEW_TOKEN, TRUE);
	DEB_EVENT ('PAR_RECOVERY_LOCAL',
	    PUT_MSG ('Successful insertion of '),
	    PUT_STRING (PAT$DATA_SYMBOL_TEXT (LS_T_SEMICOLON)),
	    PUT_EOL ());
	LS_ERROR_EOL (.ERROR_LOC);
	return TRUE;
	end;

    return FALSE
    end;					! Of routine TRY_EOL_CORRECTION
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine TRY_MERGE =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Try to correct syntax by merging tokens.  The actual work
!	is done by the MERGE_TOKENS routine.
!
! FORMAL PARAMETERS:
!
!	None.
!
! IMPLICIT INPUTS:
!
!	PAT$TOKEN_CURRENT_PTR
!
! IMPLICIT OUTPUTS:
!
!	CURRENT_SYMBOL
!	PAT$TOKEN_CURRENT_PTR
!
! ROUTINE VALUE:
!
!	Returns TRUE if the result parsed, FALSE otherwise.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    local
	TERM,
	ERROR_LOC,
	NUM_SAVED,
	FIRST_TOKEN_PTR,
	SECOND_TOKEN_PTR,
	NEW_TOKEN;

    DEB_EVENT ('PAR_RECOVERY_LOCAL',
	PUT_EOL (),
	PUT_MSG_EOL ('Trying to merge tokens'));
    NUM_SAVED = PAT$TOKEN_SAVE_BUF (2);
    PAT$TOKEN_GET (FALSE);			! Get first token
    FIRST_TOKEN_PTR = .PAT$TOKEN_CURRENT_PTR;
    PAT$TOKEN_GET (FALSE);			! Get second token
    SECOND_TOKEN_PTR = .PAT$TOKEN_CURRENT_PTR;
    TERM = MERGE_TOKENS (.FIRST_TOKEN_PTR, .SECOND_TOKEN_PTR);
    if .TERM neq NO_MERGE
    then
	begin
	NEW_TOKEN = SYNTHESIZE_TOKEN (.TERM);
	PAT$TOKEN_CURRENT_PTR = .NEW_TOKEN;	! Try replacing 2 tokens with merged token
	CURRENT_SYMBOL = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);

	if PARSE_AHEAD (PARSE_AHEAD_MERGE)
	then
	    begin
	    PAT$TOKEN_GET (TRUE);		! Drop error token for real
	    PAT$TOKEN_GET (TRUE);		! Drop next token for real
	    PAT$TOKEN_SAVE (.NEW_TOKEN, TRUE);	! Insert merged token
	    DEB_EVENT ('PAR_RECOVERY_LOCAL',
		PUT_MSG ('Successful merge of '),
		PUT_STRING (PAT$DATA_SYMBOL_TEXT (LS_LEX_TERM (FIRST_TOKEN_PTR))),

		if LS_IS_IDENTIFIER (LS_LEX_TERM (FIRST_TOKEN_PTR))
		then
		    begin
		    PUT_MSG (' "');
		    PUT_STRING (LS_LEX_TEXT (FIRST_TOKEN_PTR));
		    PUT_MSG ('"');
		    end
	    ,
		PUT_MSG (' and '),
		PUT_STRING (PAT$DATA_SYMBOL_TEXT (LS_LEX_TERM (SECOND_TOKEN_PTR))),

		if LS_IS_IDENTIFIER (LS_LEX_TERM (SECOND_TOKEN_PTR))
		then
		    begin
		    PUT_MSG (' "');
		    PUT_STRING (LS_LEX_TEXT (SECOND_TOKEN_PTR));
		    PUT_MSG ('"');
		    end
	    ,
		PUT_MSG (' to form '),
		PUT_STRING (PAT$DATA_SYMBOL_TEXT (.TERM)),
		PUT_EOL ());
	    ERROR_LOC = LS_LEX_LOCATOR (FIRST_TOKEN_PTR);
	    LS_ERROR_MERGE (.ERROR_LOC, .FIRST_TOKEN_PTR, .SECOND_TOKEN_PTR, .TERM);
	    return TRUE
	    end;

	end;

    PAT$TOKEN_RESTORE_BUF (.NUM_SAVED);
    return FALSE
    end;					! Of routine TRY_MERGE
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine MERGE_TOKENS (FIRST_TOKEN_PTR, SECOND_TOKEN_PTR) =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Does the work for TRY_MERGE.
!
! FORMAL PARAMETERS:
!
!	FIRST_TOKEN_PTR		First token to try merging
!	SECOND_TOKEN_PTR	Second token to try merging
!
! IMPLICIT INPUTS:
!
!	PAT$LR_IDENTIFIER_MERGE_TABLE
!	PAT$LR_SYMBOL_MERGE_TABLE
!
! IMPLICIT OUTPUTS:
!
!	None.
!
! ROUTINE VALUE:
!
!	Returns the merged token if there is one, or NO_MERGE if not.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    map
	FIRST_TOKEN_PTR,
	SECOND_TOKEN_PTR;

    if LS_IS_IDENTIFIER (LS_LEX_TERM (FIRST_TOKEN_PTR))
    then
	begin

	if LS_IS_IDENTIFIER (LS_LEX_TERM (SECOND_TOKEN_PTR))
	then

	    incr COUNTER from 0 to (LR_NUM_IM - 1) do

		if $str_eql (STRING1=LS_LEX_TEXT (FIRST_TOKEN_PTR),	! 004
			STRING2=.PAT$LR_IDENTIFIER_MERGE_TABLE[.COUNTER,! 004
			    LR_IM_FIRST_ID]) and
		    $str_eql (STRING1=LS_LEX_TEXT (SECOND_TOKEN_PTR), 	! 004
			STRING2=.PAT$LR_IDENTIFIER_MERGE_TABLE [.COUNTER, LR_IM_SECOND_ID])	! 004
		then
		    return .PAT$LR_IDENTIFIER_MERGE_TABLE [.COUNTER, LR_IM_MERGED_TERM];

	end
    else

	incr COUNTER from 0 to (LR_NUM_SM - 1) do

	    if (LS_LEX_TERM (FIRST_TOKEN_PTR) eql .PAT$LR_SYMBOL_MERGE_TABLE [.COUNTER, LR_SM_FIRST_TERM]) and
		(LS_LEX_TERM (SECOND_TOKEN_PTR) eql .PAT$LR_SYMBOL_MERGE_TABLE [.COUNTER, LR_SM_SECOND_TERM])
	    then
		return .PAT$LR_SYMBOL_MERGE_TABLE [.COUNTER, LR_SM_MERGED_TERM];

    return NO_MERGE
    end;
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine TRY_CORRECT_SPELLING (ANNOUNCE_ABBREVIATIONS) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Try correcting spelling of the erroneous input.
!	The following types of corrections are tried:
!	1.  Wrong case (not used for some grammars whose lexical machines
!	    convert to all one case).
!	2.  Abbreviation of a reserved word to 2 or more characters, if the
!	    characters in the error token match the start of a reserved
!	    word.
!	3.  One letter wrong for a reserved word.
!	4.  One letter missing in a reserved word.
!	5.  One extra letter in a reserved word.
!	6.  Two adjacent letters transposed in a reserved word.
!
! FORMAL PARAMETERS:
!
!	ANNOUNCE_ABBREVIATIONS	TRUE if a message should tell
!				the user we replaced an abbreviation.
!
! IMPLICIT INPUTS:
!
!	PAT$TOKEN_CURRENT_PTR
!
! IMPLICIT OUTPUTS:
!
!	CURRENT_SYMBOL
!
! ROUTINE VALUE:
!
!	Returns TRUE if the result parsed, FALSE otherwise.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    local
	TERM,
	ERROR_LOC,
	ABBREVIATION,
	CORRECTION,
	NUM_SAVED,
	OFFSET,
	REM_LEN,
	ID_TOKEN_PTR,
	ORIG_IDENTIFIER : ref $STR_DESCRIPTOR (),			! 004
	RESERVED_WORD : ref $STR_DESCRIPTOR (),				! 004
	NEW_TOKEN;

    own
	IDENTIFIER_TEXT : vector [CH$ALLOCATION (132)],			! 004
	IDENTIFIER:$STR_DESCRIPTOR(string=(132,ch$ptr(identifier_text)));! 004
    DEB_EVENT ('PAR_RECOVERY_LOCAL',
	PUT_EOL (),
	PUT_MSG_EOL ('Trying spelling correction'));
    NUM_SAVED = PAT$TOKEN_SAVE_BUF (1);
    CURRENT_SYMBOL = PAT$TOKEN_GET (FALSE);	! Try dropping error token

    if LS_IS_IDENTIFIER (.CURRENT_SYMBOL) and
	( not LS_LEX_SYNTHETIC (PAT$TOKEN_CURRENT_PTR))
    then
	begin
	ERROR_LOC = LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR);
	ID_TOKEN_PTR = .PAT$TOKEN_CURRENT_PTR;
	ORIG_IDENTIFIER = LS_LEX_TEXT (PAT$TOKEN_CURRENT_PTR);
	DOWN_CASE (.ORIG_IDENTIFIER, IDENTIFIER);
	PAT$ERROR_GET_NEXT_TRANS_INIT (.LOCAL_ATTEMPT_STATUS, .PAT$STACK_P [.STACK_PTR, PATSTK_STATE],
	    .PAT$STACK_P [.STACK_PTR, PATSTK_SYMBOL]);
	while (TERM = PAT$ERROR_GET_NEXT_TRANSITION (TRUE)) neq PAT$ERROR_NO_MORE_TRANSITIONS do
	    begin

	    if LS_IS_RESERVED_WORD (.TERM)	! Reserved word
	    then
		begin
		NEW_TOKEN = SYNTHESIZE_TOKEN (.TERM);
		PAT$TOKEN_CURRENT_PTR = .NEW_TOKEN;	! Try inserting reserved word
		CURRENT_SYMBOL = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);

		if PARSE_AHEAD (PARSE_AHEAD_SPELLING)
		then
		    begin
		    ABBREVIATION = FALSE;
		    CORRECTION = FALSE;
		    RESERVED_WORD = PAT$DATA_SYMBOL_TEXT (.TERM);

		    ! Check for same spelling (error could be due to incorrect
		    ! capitalization.

		    if ch$eql (.RESERVED_WORD [STR$H_LENGTH],		! 004
			    .RESERVED_WORD [STR$A_POINTER],		! 004
			    .IDENTIFIER [STR$H_LENGTH],			! 004
			    .IDENTIFIER [STR$A_POINTER])		! 004
		    then
			begin
			CORRECTION = TRUE;
			end
		    else

		    ! Check for abbreviation

			if (.IDENTIFIER [STR$H_LENGTH] gtr 2) and 	! 004
			    (.IDENTIFIER [STR$H_LENGTH] lss .RESERVED_WORD [STR$H_LENGTH]) and 	! 004
			    ch$eql (.IDENTIFIER [STR$H_LENGTH], .RESERVED_WORD [STR$A_POINTER],	! 004
				.IDENTIFIER [STR$H_LENGTH], .IDENTIFIER [STR$A_POINTER])	! 004
			then
			    begin
			    ABBREVIATION = TRUE;
			    CORRECTION = TRUE;
			    end;
!		    if not .CORRECTION and
!			(.RESERVED_WORD [STR$H_LENGTH] + 1) geq (.IDENTIFIER [STR$H_LENGTH])	! 004
!		    then
!			begin
!
!			local
!			    POSSIBILITIES,
!			    MATCHES;
!
!			MATCHES = 0;
!
!			if ch$eql (1, .RESERVED_WORD [STR$A_POINTER], 1, .IDENTIFIER [STR$A_POINTER])	! 004
!			then
!			    MATCHES = .MATCHES + 1;
!
!			incr RW_PTR from .RESERVED_WORD [STR$A_POINTER] to 	! 004
!				(.RESERVED_WORD [STR$A_POINTER] + .RESERVED_WORD [STR$H_LENGTH] - 2) do	! 004
!
!			    incr ID_PTR from .IDENTIFIER [STR$A_POINTER] to 	! 004
!				    (.IDENTIFIER [STR$A_POINTER] + .IDENTIFIER [STR$H_LENGTH] - 2) do	! 004
!
!				if ch$eql (2, .RW_PTR, 2, .ID_PTR) then MATCHES = .MATCHES + 1;
!
!			if ch$eql (1, (.RESERVED_WORD [STR$A_POINTER] + .RESERVED_WORD [STR$H_LENGTH]), 1,	! 004
!				(.IDENTIFIER [STR$A_POINTER] + .IDENTIFIER [STR$H_LENGTH]))	! 004
!			then
!			    MATCHES = .MATCHES + 1;
!
!			POSSIBILITIES = max (.RESERVED_WORD [STR$H_LENGTH], .IDENTIFIER [STR$H_LENGTH]) + 1;	! 004
!
!			if ((.MATCHES*100)/.POSSIBILITIES) gtr 40
!			then
!			    CORRECTION = TRUE;
!
!			end;
! If the identifier is n, n+1, or n-1 characters in length, where n is the
! number of characters in the reserved word, then test for one of the following
! conditions:
! 1.  One letter wrong (length: n)
! 2.  One letter missing (length: n-1)
! 3.  An extra character inserted (length: n+1)
! 4.  Two adjacent characters transposed (length: n)

if (not .correction) and
    (.identifier [str$h_length] geq .reserved_word [str$h_length] - 1)
    and (.identifier [str$h_length] leq .reserved_word [str$h_length] + 1)
    then begin		! Find first invalid character in the identifier
	offset = 0;
	while (.offset leq .reserved_word [str$h_length]) and
	    ch$eql (1, ch$plus (.identifier [str$a_pointer] , .offset),
		1, ch$plus (.reserved_word [str$a_pointer], .offset))
	    do offset = .offset + 1;
	rem_len = .reserved_word [str$h_length] - .offset;
	if (selectone (.identifier [str$h_length] -
	    .reserved_word [str$h_length]) of
	    set

	    [1]:		! Extra character
	    if ch$eql (.rem_len,
		ch$plus (.identifier [str$a_pointer], .offset + 1),
		.rem_len,
		ch$plus (.reserved_word [str$a_pointer], .offset))
		then TRUE else FALSE;

	    [0]:		! Wrong or transposed characters
	    if ch$eql (.rem_len - 1,
		ch$plus (.identifier [str$a_pointer], .offset + 1),
		.rem_len - 1,
		ch$plus (.reserved_word [str$a_pointer], .offset + 1))
		then TRUE	! One wrong character
		else if ch$eql (.rem_len - 2,
		    ch$plus (.identifier [str$a_pointer], .offset + 2),
		    .rem_len - 2,
		    ch$plus (.reserved_word [str$a_pointer], .offset + 2))
		    and
		    ch$eql (1, ch$plus (.identifier [str$a_pointer], .offset),
			1, ch$plus (.reserved_word [str$a_pointer], .offset+1))
		    and
		    ch$eql (1, ch$plus (.identifier [str$a_pointer], .offset+1),
			1, ch$plus (.reserved_word [str$a_pointer], .offset))
		    then TRUE else FALSE;

	    [-1]:		! One missing character
	    if ch$eql (.rem_len - 1,
		ch$plus (.identifier [str$a_pointer], .offset),
		.rem_len - 1,
		ch$plus (.reserved_word [str$a_pointer], .offset + 1))
		then TRUE else FALSE;

	    tes)
	    then begin
		CORRECTION = TRUE;
	    end;
	end;
		    if .CORRECTION
		    then
			begin
			RESTORE_STATE ();
			PAT$TOKEN_GET (TRUE);	! Drop error token
			PAT$TOKEN_SAVE (.NEW_TOKEN, TRUE);

			if .ABBREVIATION
			then
			    begin

			    if .ANNOUNCE_ABBREVIATIONS
			    then
				begin
				DEB_EVENT ('PAR_RECOVERY_LOCAL',
				    PUT_MSG_EOL ('Successful abbreviation correction:'),
				    PUT_MSG ('replaced '),
				    PUT_STRING (.ORIG_IDENTIFIER),
				    PUT_MSG (' with '),
				    PUT_STRING (.RESERVED_WORD),
				    PUT_EOL ());
				LS_ERROR_ABBREV (.ERROR_LOC, .ID_TOKEN_PTR, .NEW_TOKEN);
				end
			    else
				DEB_EVENT ('PAR_RECOVERY_LOCAL',
				    PUT_MSG_EOL ('Successful unannounced abbreviation correction:'),
				    PUT_MSG ('replaced '),
				    PUT_STRING (.ORIG_IDENTIFIER),
				    PUT_MSG (' with '),
				    PUT_STRING (.RESERVED_WORD),
				    PUT_EOL ())

			    end
			else 			! Spelling error
			    begin
			    DEB_EVENT ('PAR_RECOVERY_LOCAL',
				PUT_MSG_EOL ('Successful spelling correction:'),
				PUT_MSG ('replaced '),
				PUT_STRING (.ORIG_IDENTIFIER),
				PUT_MSG (' with '),
				PUT_STRING (.RESERVED_WORD),
				PUT_EOL ());
			    LS_ERROR_SPELL (.ERROR_LOC, .ID_TOKEN_PTR, .NEW_TOKEN);
			    end;

			return TRUE
			end;

		    end;

		end;

	    end;

	end;

    PAT$TOKEN_RESTORE_BUF (.NUM_SAVED);
    return FALSE
    end;					! Of routine TRY_CORRECT_SPELLING
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine TRY_SUBSTITUTE =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Try to get input to parse by substituting tokens.
!
! FORMAL PARAMETERS:
!
!	None.
!
! IMPLICIT INPUTS:
!
!	PAT$TOKEN_CURRENT_PTR
!	PAT$STACK_P
!	PAT$LR_PREFERRED_INSERTIONS
!	PAT$LR_NEVER_SUBSTITUTE_FOR
!
! IMPLICIT OUTPUTS:
!
!	PAT$TOKEN_CURRENT_PTR
!	CURRENT_SYMBOL
!
! ROUTINE VALUE:
!
!	Returns TRUE if the result parsed, FALSE otherwise.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    local
	TERM,
	ERROR_LOC,
	NUM_SUBS,
	NUM_SAVED,
	INITIAL_TOKEN_PTR,
	NEW_TOKEN_PTR,
	POSS_SUBS : bitvector [PAT$DATA_NUM_TERM],
	PREF_SUBS : bitvector [PAT$DATA_NUM_TERM];
    DEB_EVENT ('PAR_RECOVERY_LOCAL',
	PUT_EOL (),
	PUT_MSG_EOL ('Trying token substitution'));
    NUM_SAVED = PAT$TOKEN_SAVE_BUF (1);
    CLEAR (POSS_SUBS, NUM_BYTES);
    PAT$TOKEN_GET (FALSE);			! Find type of error token
    INITIAL_TOKEN_PTR = .PAT$TOKEN_CURRENT_PTR;
    PAT$TOKEN_RESET_BUFFER ();
    if ( not .PAT$LR_NEVER_SUBSTITUTE_FOR [LS_LEX_TERM (INITIAL_TOKEN_PTR)]) and
	( not LS_IS_EOF (LS_LEX_TERM (INITIAL_TOKEN_PTR)))	! Don't substitute for EOF
    then
	begin
	PAT$ERROR_GET_NEXT_TRANS_INIT (.LOCAL_ATTEMPT_STATUS, .PAT$STACK_P [.STACK_PTR, PATSTK_STATE],
	    .PAT$STACK_P [.STACK_PTR, PATSTK_SYMBOL]);

	while (TERM = PAT$ERROR_GET_NEXT_TRANSITION (TRUE)) neq PAT$ERROR_NO_MORE_TRANSITIONS do
	    if (.TERM neq LS_T_ERRORMARK) and 		! Don't replace with errormark
		(not LS_IS_EOF (.TERM)) 		! Don't replace with end-of-file
!		and (not LS_IS_RESERVED_WORD (.TERM))	! Don't replace with reserved word
	    then
		begin
		PAT$TOKEN_GET (FALSE);		! Try dropping error token
		PAT$TOKEN_CURRENT_PTR = SYNTHESIZE_TOKEN (.TERM);	! Try replacement for error token
		CURRENT_SYMBOL = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);
		if PARSE_AHEAD (PARSE_AHEAD_SUBSTITUTION)
		    then POSS_SUBS [.TERM] = TRUE;
		RESTORE_STATE ();
		end;
	NUM_SUBS = COUNT (POSS_SUBS, PAT$DATA_NUM_TERM);
	if .NUM_SUBS gtr 1
	then
	    begin
	    BLOCK_AND (POSS_SUBS, PAT$LR_PREFERRED_INSERTIONS, PREF_SUBS, NUM_BYTES);
	    NUM_SUBS = COUNT (PREF_SUBS, PAT$DATA_NUM_TERM);
	    end
	else
	    BLOCK_COPY (POSS_SUBS, PREF_SUBS, NUM_BYTES);
	if (.NUM_SUBS neq 1) and
	    (.POSS_SUBS [LS_T_IDENTIFIER]) and
	    LS_IS_RESERVED_WORD (LS_LEX_TERM (INITIAL_TOKEN_PTR))
	then
	    begin
	    CLEAR (PREF_SUBS, NUM_BYTES);
	    PREF_SUBS [LS_T_IDENTIFIER] = TRUE;
	    NUM_SUBS = 1;
	    end;
	if .NUM_SUBS eql 1
	then
	    begin
	    PAT$TOKEN_GET (TRUE);		! Really drop error token
	    NEW_TOKEN_PTR = SYNTHESIZE_TOKEN (WHICH_TERM (PREF_SUBS, PAT$DATA_NUM_TERM));
						! Get terminal selected
	    PAT$TOKEN_SAVE (.NEW_TOKEN_PTR, TRUE);	! Substitute correction token
	    DEB_EVENT ('PAR_RECOVERY_LOCAL',
		PUT_MSG ('Successfully substituted '),
		PUT_STRING (PAT$DATA_SYMBOL_TEXT (LS_LEX_TERM (NEW_TOKEN_PTR))),
		PUT_MSG (' for '),
		PUT_STRING (PAT$DATA_SYMBOL_TEXT (LS_LEX_TERM (INITIAL_TOKEN_PTR))),
		PUT_EOL ());
	    ERROR_LOC = LS_LEX_LOCATOR (INITIAL_TOKEN_PTR);
	    LS_ERROR_SUBST (.ERROR_LOC, .INITIAL_TOKEN_PTR, .NEW_TOKEN_PTR);
	    return TRUE
	    end;
	end
    else
	DEB_EVENT ('PAR_RECOVERY_LOCAL',
	    PUT_MSG ('No substitutions are allowed for the token '),
	    PUT_STRING (PAT$DATA_SYMBOL_TEXT (LS_LEX_TERM (INITIAL_TOKEN_PTR))),
	    PUT_EOL ());
    PAT$TOKEN_RESTORE_BUF (.NUM_SAVED);
    return FALSE
    end;					! Of routine TRY_SUBSTITUTE
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine TRY_INSERT =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Try to get input to parse by inserting a token.
!
! FORMAL PARAMETERS:
!
!	None.
!
! IMPLICIT INPUTS:
!
!	PAT$TOKEN_CURRENT_PTR
!	PAT$STACK_P
!	PAT$LR_PREFERRED_INSERTIONS
!
! IMPLICIT OUTPUTS:
!
!	PAT$TOKEN_CURRENT_PTR
!	CURRENT_SYMBOL
!
! ROUTINE VALUE:
!
!	Returns TRUE if the result parsed, FALSE otherwise.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    local
	TERM,
	ERROR_LOC,
	NUM_INSERT,
	FOLLOW_TOKEN_1,
	FOLLOW_TOKEN_2,
	ENCOUNTERED_TOKEN_PTR,
	NEW_TOKEN_PTR,
	POSS_INSERT : bitvector [PAT$DATA_NUM_TERM],
	PREF_INSERT : bitvector [PAT$DATA_NUM_TERM];
    DEB_EVENT ('PAR_RECOVERY_LOCAL',
	PUT_EOL (),
	PUT_MSG_EOL ('Trying token insertion'));

    CLEAR (POSS_INSERT, NUM_BYTES);
    FOLLOW_TOKEN_1 = PAT$TOKEN_GET (FALSE);	! Find type of error token
    ENCOUNTERED_TOKEN_PTR = .PAT$TOKEN_CURRENT_PTR;
    FOLLOW_TOKEN_2 = PAT$TOKEN_GET (FALSE);	! Find type of following token
    PAT$TOKEN_RESET_BUFFER ();
    PAT$ERROR_GET_NEXT_TRANS_INIT (.LOCAL_ATTEMPT_STATUS, .PAT$STACK_P [.STACK_PTR, PATSTK_STATE],
	.PAT$STACK_P [.STACK_PTR, PATSTK_SYMBOL]);

    while (TERM = PAT$ERROR_GET_NEXT_TRANSITION (TRUE)) neq PAT$ERROR_NO_MORE_TRANSITIONS do

	if ( not NEVER_INSERT_BEFORE (.TERM, .FOLLOW_TOKEN_1, .FOLLOW_TOKEN_2)) and
						! Don't insert if in table
	    (.TERM neq LS_T_ERRORMARK) and 	! Don't insert ERRORMARK
	    ( not LS_IS_EOF (.TERM))		! Don't insert end-of-file
	then
	    begin
	    PAT$TOKEN_CURRENT_PTR = SYNTHESIZE_TOKEN (.TERM);	! Try inserting new token
	    CURRENT_SYMBOL = LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR);

	    if PARSE_AHEAD (PARSE_AHEAD_INSERTION)
		then POSS_INSERT [.TERM] = TRUE;

	    RESTORE_STATE ();
	    end;
    NUM_INSERT = COUNT (POSS_INSERT, PAT$DATA_NUM_TERM);

    if .NUM_INSERT gtr 1
    then
	begin
	BLOCK_AND (POSS_INSERT, PAT$LR_PREFERRED_INSERTIONS, PREF_INSERT, NUM_BYTES);
	NUM_INSERT = COUNT (PREF_INSERT, PAT$DATA_NUM_TERM);
	end
    else
	BLOCK_COPY (POSS_INSERT, PREF_INSERT, NUM_BYTES);

    if .NUM_INSERT eql 1
    then
	begin
	NEW_TOKEN_PTR = SYNTHESIZE_TOKEN (WHICH_TERM (PREF_INSERT, PAT$DATA_NUM_TERM));
						! Get terminal selected
	PAT$TOKEN_SAVE (.NEW_TOKEN_PTR, TRUE);	! Insert correcting token
	DEB_EVENT ('PAR_RECOVERY_LOCAL',
	    PUT_MSG ('Successful insertion of '),
	    PUT_STRING (PAT$DATA_SYMBOL_TEXT (LS_LEX_TERM (NEW_TOKEN_PTR))),
	    PUT_EOL ());
	ERROR_LOC = LS_LEX_LOCATOR (ENCOUNTERED_TOKEN_PTR);
	LS_ERROR_INSERT (.ERROR_LOC, .NEW_TOKEN_PTR, .ENCOUNTERED_TOKEN_PTR);
	return TRUE
	end;

    return FALSE
    end;					! Of routine TRY_INSERT
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine NEVER_INSERT_BEFORE (INSERTION, FIRST_FOLLOWING, SECOND_FOLLOWING) =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	During an attempt to get user input to parse, determine if nothing
!	should ever be inserted before the token.
!
! FORMAL PARAMETERS:
!
!	INSERTION		the token to attept to insert
!	FIRST_FOLLOWING		the original error token
!	SECOND_FOLLOWING	the following token
!
! IMPLICIT INPUTS:
!
!	PAT$LR_NEVER_INSERT_BEFORE
!
! IMPLICIT OUTPUTS:
!
!	None.
!
! ROUTINE VALUE:
!
!	Returns TRUE if no insertion should be done, FALSE otherwise.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    incr COUNTER from 0 to (LR_NUM_NIB - 1) do

	if (.INSERTION eql .PAT$LR_NEVER_INSERT_BEFORE [.COUNTER, LR_NIB_INSERTION]) and
	    (.FIRST_FOLLOWING eql .PAT$LR_NEVER_INSERT_BEFORE [.COUNTER, LR_NIB_CURTOK]) and
	    (.SECOND_FOLLOWING eql .PAT$LR_NEVER_INSERT_BEFORE [.COUNTER, LR_NIB_NEXTTOK])
	then
	    return TRUE;

    return FALSE
    end;
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine TRY_DELETE =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Try to get input to parse by deleting a token.
!
! FORMAL PARAMETERS:
!
!	None.
!
! IMPLICIT INPUTS:
!
!	PAT$TOKEN_CURRENT_PTR
!
! IMPLICIT OUTPUTS:
!
!	CURRENT_SYMBOL
!
! ROUTINE VALUE:
!
!	Returns TRUE if the result parsed, FALSE otherwise.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin
    DEB_EVENT ('PAR_RECOVERY_LOCAL',
	PUT_EOL (),
	PUT_MSG_EOL ('Trying token deletion'));
    CURRENT_SYMBOL = PAT$TOKEN_GET (FALSE);	! Try dropping error token
    CURRENT_SYMBOL = PAT$TOKEN_GET (FALSE);	! Start with following token

    ! Add check to NEVER_DELETE (for generality) and
    ! PAT$LR_NEVER_DEL_UNLESS_ERR_TOK (for backtracking)

    if PARSE_AHEAD (PARSE_AHEAD_DELETION)
    then
	begin
	CURRENT_SYMBOL = PAT$TOKEN_GET (TRUE);	! Drop error token for real

	DEB_EVENT ('PAR_RECOVERY_LOCAL',
	    PUT_MSG ('Successful deletion of '),
	    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.CURRENT_SYMBOL)),
	    PUT_EOL ());
	LS_ERROR_DELETED (LS_LEX_LOCATOR (PAT$TOKEN_CURRENT_PTR), .PAT$TOKEN_CURRENT_PTR);
	return TRUE
	end
    else
	return FALSE

    end;					! Of routine TRY_DELETE
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine SCOPE_RECOVERY (INIT_ONLY) =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Try to get input to parse by correcting scope errors.
!
! FORMAL PARAMETERS:
!
!	INIT_ONLY	TRUE if routine is being initialized only
!
! IMPLICIT INPUTS:
!
!	PAT$STACK_P
!	PRIOR_TOKEN_PTR
!	PAT$TOKEN_CURRENT_PTR
!	PAT$LR_ONLY_CLOSE_BEFORE
!	PAT$LR_CLOSER_TOKENS
!	PAT$LR_POINT_AT_PREV_TOKEN
!	PAT$LR_CLOSER_MATCH
!
! IMPLICIT OUTPUTS:
!
!	CURRENT_SYMBOL
!
! ROUTINE VALUE:
!
!	Returns TRUE if the result parsed, FALSE otherwise.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    local
	SAVED_TEMP_HEAD,
	NUM_TOKENS,
	MATCH_LOC,
	ERROR_LOC,
	ENCOUNTERED_TOKEN_PTR,
	PREVIOUS_TOKEN_PTR,
	TEMP_STACK_PTR;

    own
	LAST_ERROR_LOCATOR;
    ! If only initializing, then initialize LAST_ERROR_LOCATOR.
    ! If there are two consecutive scope recoveries, the locator
    ! of the last error is used since the current token is a
    ! synthetic one.

    if .INIT_ONLY
    then
	begin
	LAST_ERROR_LOCATOR = 0;
	return FALSE
	end;

    ! If don't have a prior token, must be at the start of the source
    ! file so it's silly to try scope recovery.

    if .PRIOR_TOKEN_PTR eql NULL then return FALSE;

    DEB_EVENT ('PAR_RECOVERY_LOCAL',
	PUT_EOL (),
	PUT_MSG_EOL ('Trying scope recovery'));
    PAT$TOKEN_GET (FALSE);			! Get error token for locator info
    ENCOUNTERED_TOKEN_PTR = .PAT$TOKEN_CURRENT_PTR;
    PREVIOUS_TOKEN_PTR = .PRIOR_TOKEN_PTR;
    PAT$TOKEN_RESET_BUFFER ();
! Try inserting each scope closer:

    incr CLOSER from FIRST_LR_CLOSER to LAST_LR_CLOSER do

	if .PAT$LR_ONLY_CLOSE_BEFORE [.CLOSER, LS_LEX_TERM (ENCOUNTERED_TOKEN_PTR)]
	then
	    begin

	    decr COUNTER from .PAT$LR_CLOSER_TOKENS [.CLOSER, LR_NUM_TOKS_INDEX] to 1 do
		PAT$TOKEN_SAVE
		(SYNTHESIZE_TOKEN (.PAT$LR_CLOSER_TOKENS [.CLOSER, .COUNTER]),
		    FALSE);

	    SAVED_TEMP_HEAD = PAT$TOKEN_TEMP_HEAD ();
	    CURRENT_SYMBOL = PAT$TOKEN_GET (FALSE);

	    ! Don't use closer if it's meant for providing an error message
	    ! indicating an insertion before the token preceding the error
	    ! AND that token is not the same terminal as the last symbol
	    ! in the closer.

	    if not (.PAT$LR_POINT_AT_PREV_TOKEN [.CLOSER] and
		(LS_LEX_TERM (PREVIOUS_TOKEN_PTR) neq
		.PAT$LR_CLOSER_TOKENS [.CLOSER,
		    .PAT$LR_CLOSER_TOKENS [.CLOSER, LR_NUM_TOKS_INDEX]]))
	    then

		if PARSE_AHEAD (.PAT$LR_CLOSER_TOKENS [.CLOSER, LR_NUM_TOKS_INDEX])
		then
		    begin

		    ! Change the effect to the above calls to
		    ! PAT$TOKEN_SAVE (..., FALSE) to
		    ! PAT$TOKEN_SAVE (..., TRUE) by modifying the
		    ! head of the token buffer.

		    PAT$TOKEN_SET_HEAD (.SAVED_TEMP_HEAD);
		    ERROR_LOC = LS_LEX_LOCATOR (ENCOUNTERED_TOKEN_PTR);

		    if .PAT$LR_POINT_AT_PREV_TOKEN [.CLOSER]
		    then
			ERROR_LOC = LS_LEX_LOCATOR (PREVIOUS_TOKEN_PTR);

		    if .ERROR_LOC eql 0
		    then
			begin
			DEB_ASSERT (.LAST_ERROR_LOCATOR neq 0, 'LAST_ERROR_LOCATOR is 0');
			ERROR_LOC = .LAST_ERROR_LOCATOR;
			end
		    else
			LAST_ERROR_LOCATOR = .ERROR_LOC;

		    if .PAT$LR_CLOSER_MATCH [.CLOSER, LR_CLOSERS_STACK]
			   eql LR_NOT_MATCHED
		    then
			LS_ERROR_SCOPE_NO_MATCH (.ERROR_LOC, .PAT$LR_CLOSER_MESSAGE [.CLOSER],
			    .ENCOUNTERED_TOKEN_PTR)
		    else
			begin
			TEMP_STACK_PTR = .STACK_PTR;

			while ((TEMP_STACK_PTR = .TEMP_STACK_PTR - 1) neq -1) do

			    if .PAT$STACK_P [.TEMP_STACK_PTR, PATSTK_SYMBOL] eql
				.PAT$LR_CLOSER_MATCH [.CLOSER, LR_CLOSERS_STACK]
			    then
				begin
				MATCH_LOC = .PAT$STACK_P [.TEMP_STACK_PTR, PATSTK_LOCATOR];
				exitloop;
				end;

			! It's possible that there isn't a scope
			! opener on the stack since sometimes there
			! isn't a begin that goes with "end".  e.g.
			!
			!	package foo x:integer;
			!	<end-of-file>	-- missing "end;"

			if .TEMP_STACK_PTR eql -1 then return FALSE;

			LS_ERROR_SCOPE_MATCH (.ERROR_LOC,
			    .PAT$LR_CLOSER_MESSAGE [.CLOSER],
			    .PAT$LR_CLOSER_MATCH [.CLOSER, LR_CLOSERS_TERMINAL],
			    .MATCH_LOC);
			end;

		    return TRUE;
		    end;

	    RESTORE_STATE ();
	    end;

    return FALSE
    end;					! Of routine SCOPE_RECOVERY
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine FIND_BACKUP_ORDER (P_STATUS, P_P_STATUS) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Called from LOCAL_RECOVERY to determine from what states we should
!	begin local error recovery:
!	ORDER_A:	The current state where the error occurred, with
!			no backup (state A).
!	ORDER_B:	The error state, before any default reductions
!			(state B).
!	ORDER_BC:	The token before the error, before any default
!			reductions (state C), and then state B.
!
! FORMAL PARAMETERS:
!
!	P_STATUS	previous status (prior to error)
!	P_P_STATUS	previous status to P_STATUS
!
! IMPLICIT INPUTS:
!
!	None.
!
! IMPLICIT OUTPUTS:
!
!	None.
!
! ROUTINE VALUE:
!
!	ORDER_A, ORDER_B, or ORDER_BC, or FALSE if previous parse
!	state is not legal.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    selectone .P_STATUS of
	set

	[CONSUME_TERM_ON_SHIFT, CONSUME_TERM_ON_REDUCTION] :

	    if .P_P_STATUS eql SAVED_INFO_NOT_VALID
	    then
		return ORDER_B
	    else
		return ORDER_BC;

	[REDUCT_AFTER_BACKUP_NOT_ALLOWED] :
	    return ORDER_B;

	[SAVED_INFO_NOT_VALID, CONSUME_NONTERM_ON_SHIFT] :
	    return ORDER_A;
	tes;

    DEB_ASSERT (FALSE, 'Previous status is of illegal status type');
    return FALSE;
    end;					! Of routine FIND_BACKUP_ORDER
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine SYNTHESIZE_TOKEN (TERM_TYPE) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	SYNTHESIZE_TOKEN creates a synthetic lexical token.
!
! FORMAL PARAMETERS:
!
!	TERM_TYPE	Initial terminal symbol for the token.
!
! IMPLICIT INPUTS:
!
!	NONE
!
! IMPLICIT OUTPUTS:
!
!	NONE
!
! ROUTINE VALUE:
!
!	NEW_TOKEN_PTR	Pointer to synthetic token created by this routine.
!
! SIDE EFFECTS:
!
!	The TKN_TERM and TKN_SYNTHETIC fields of NEW_TOKEN_PTR are set.
!
!--

    begin

    local
	NEW_TOKEN_PTR;

    NEW_TOKEN_PTR = SYN_TOK_STORAGE [.NEXT_SYN_TOK_INDEX, 0, 0, 0, 0];
    LS_LEX_SET_SYNTHETIC (NEW_TOKEN_PTR);
    LS_LEX_SET_TERM (NEW_TOKEN_PTR, .TERM_TYPE);
    NEXT_SYN_TOK_INDEX = .NEXT_SYN_TOK_INDEX + 1;

    if .NEXT_SYN_TOK_INDEX eql MAX_NUM_SYN_TOKS then NEXT_SYN_TOK_INDEX = 0;

    return .NEW_TOKEN_PTR
    end;
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine SAVE_STATE : novalue =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Save the state of the parse stack.  This state can be restored
!	by the routine RESTORE_STATE.
!
! FORMAL PARAMETERS:
!
!	NONE
!
! IMPLICIT INPUTS:
!
!	STACK_PTR
!
!	PAR_LOOKAHEAD_F
!
!	REDUCTION_CODE
!
! IMPLICIT OUTPUTS:
!
!	SAVED_STACK_PTR
!
!	SAVED_PAR_LOOKAHEAD_F
!
!	SAVED_REDUCTION_CODE
!
! ROUTINE VALUE:
!
!	NONE
!
! SIDE EFFECTS:
!
!	NONE
!
!--

    begin
    SAVED_STACK_PTR = .STACK_PTR;
    incr p from 1 to (.STACK_PTR + 1) do
	begin
	ref_alt_parse_stack [.P-1, PATSTK_LOCATOR]
	    = .ref_parse_stack [.P-1, PATSTK_LOCATOR];
	%if PATBLSEXT_EXTRA_STACK_FIELD
	%then
	ref_alt_parse_stack [.P-1, PATSTK_EXTRA_INFO]
	    = .ref_parse_stack [.P-1, PATSTK_EXTRA_INFO];
	%fi
	ref_alt_parse_stack [.P-1, PATSTK_SYMBOL]
	    = .ref_parse_stack [.P-1, PATSTK_SYMBOL];
	ref_alt_parse_stack [.P-1, PATSTK_TOKEN]
	    = .ref_parse_stack [.P-1, PATSTK_TOKEN];
	ref_alt_parse_stack [.P-1, PATSTK_ERRORMARK]
	    = .ref_parse_stack [.P-1, PATSTK_ERRORMARK];
	ref_alt_parse_stack [.P-1, PATSTK_STATE]
	    = .ref_parse_stack [.P-1, PATSTK_STATE];
	end;
    SAVED_PAR_LOOKAHEAD_F = .PAR_LOOKAHEAD_F;
    SAVED_REDUCTION_CODE = .REDUCTION_CODE;
    PAT$TOKEN_RESET_BUFFER ();
    end;					! Of routine SAVE_STATE
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine RESTORE_STATE : novalue =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Restore the state that the parse stack was in before SAVE_STATE
!	was last called.
!
! FORMAL PARAMETERS:
!
!	NONE
!
! IMPLICIT INPUTS:
!
!	SAVED_STACK_PTR
!
!	SAVED_PAR_LOOKAHEAD_F
!
!	SAVED_REDUCTION_CODE
!
! IMPLICIT OUTPUTS:
!
!	STACK_PTR
!
!	PAT$TOKEN_CURRENT_PTR
!
!	PAR_LOOKAHEAD_F
!
!	REDUCTION_CODE
!
! ROUTINE VALUE:
!
!	NONE
!
! SIDE EFFECTS:
!
!	NONE
!
!--

    begin
    STACK_PTR = .SAVED_STACK_PTR;
    PAR_LOOKAHEAD_F = .SAVED_PAR_LOOKAHEAD_F;
    REDUCTION_CODE = .SAVED_REDUCTION_CODE;
    PAT$TOKEN_RESET_BUFFER ();
    end;					! Of routine RESTORE_STATE
%fi
%if PATBLSEXT_LOCAL_RECOVERY
%then
routine DOWN_CASE (IN, OUT) : novalue =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Converts a string to lower case.
!
! FORMAL PARAMETERS:
!
!	IN		XPORT descriptor of original string
!	OUT		XPORT descriptor of resulting string
!
! IMPLICIT INPUTS:
!
!	None.
!
! IMPLICIT OUTPUTS:
!
!	None.
!
! ROUTINE VALUE:
!
!	None.
!
! SIDE EFFECTS:
!
!	None.
!
!--

    begin

    bind
		    DOWNCASE_TABLE = ch$transtable (! 004
		    %c' ', %c' ', %c' ', %c' ',	! 004 NUL, SOH, STX, ETX
		    %c' ', %c' ', %c' ', %c' ',	! 004 EOT, ENQ, ACK, BEL
		    %c' ', %c' ', %c' ', %c' ',	! 004  BS,  HT,  LF,  VT
		    %c' ', %c' ', %c' ', %c' ',	! 004  FF,  CR,  SO,  SI
		    %c' ', %c' ', %c' ', %c' ',	! 004 DLE, DC1, DC2, DC3
		    %c' ', %c' ', %c' ', %c' ',	! 004 DC4, NAK, SYN, ETB
		    %c' ', %c' ', %c' ', %c' ',	! 004 CAN,  EM, SUB, ESC
		    %c' ', %c' ', %c' ', %c' ',	! 004  FS,  GS,  RS,  US
		    %c' ', %c' ', %c' ', %c' ',	! 004  SP,   !,   ",   #
		    %c'$', %c' ', %c' ', %c' ',	! 004   $,   %,   &,   '
		    %c' ', %c' ', %c' ', %c' ',	! 004   (,   ),   *,   +
		    %c' ', %c'-', %c'.', %c' ',	! 004   ,,   -,   .,   /
		    %c'0', %c'1', %c'2', %c'3',	! 004   0,   1,   2,   3
		    %c'4', %c'5', %c'6', %c'7',	! 004   4,   5,   6,   7
		    %c'8', %c'9', %c' ', %c' ',	! 004   8,   9,   :,   ;
		    %c' ', %c' ', %c' ', %c' ',	! 004   <,   =,   >,   ?
		    %c' ', %c'a', %c'b', %c'c',	! 004   @,   A,   B,   C
		    %c'd', %c'e', %c'f', %c'g',	! 004   D,   E,   F,   G
		    %c'h', %c'i', %c'j', %c'k',	! 004   H,   I,   J,   K
		    %c'l', %c'm', %c'n', %c'o',	! 004   L,   M,   N,   O
		    %c'p', %c'q', %c'r', %c's',	! 004   P,   Q,   R,   S
		    %c't', %c'u', %c'v', %c'w',	! 004   T,   U,   V,   W
		    %c'x', %c'y', %c'z', %c' ',	! 004   X,   Y,   Z,   [
		    %c' ', %c' ', %c' ', %c'_',	! 004   \,   ],   ^,   _
		    %c' ', %c'a', %c'b', %c'c',	! 004   `,   a,   b,   c
		    %c'd', %c'e', %c'f', %c'g',	! 004   d,   e,   f,   g
		    %c'h', %c'i', %c'j', %c'k',	! 004   h,   i,   j,   k
		    %c'l', %c'm', %c'n', %c'o',	! 004   l,   m,   n,   o
		    %c'p', %c'q', %c'r', %c's',	! 004   p,   q,   r,   s
		    %c't', %c'u', %c'v', %c'w',	! 004   t,   u,   v,   w
		    %c'x', %c'y', %c'z', %c' ',	! 004   x,   y,   z,   {
		    %c' ', %c' ', %c' ', %c' ');! 004   |,   },   ~, DEL

    map
	IN: ref $STR_DESCRIPTOR (),					! 004
	OUT: ref $STR_DESCRIPTOR ();					! 004

    OUT [STR$H_LENGTH] = .IN [STR$H_LENGTH];				! 004
    ch$translate (DOWNCASE_TABLE, .IN [STR$H_LENGTH], .IN [STR$A_POINTER], ! 004
	0, .OUT [STR$H_LENGTH], .OUT [STR$A_POINTER]);			! 004
    end;					! Of routine DOWN_CASE
%fi
%if PATBLSEXT_DEBUGGING
%then

global routine PAT$DUMP_TOKS : novalue =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Debugging routine to  output several tokens
!	and symbols which are relevant to the state of the parse.
!
! FORMAL PARAMETERS:
!
!	None.
!
! IMPLICIT INPUTS:
!
!	PAT$DATA_SYMBOL_TEXT
!	PAT$TOKEN_CURRENT_PTR
!	LATEST_TOKEN_PTR
!	PRIOR_TOKEN_PTR
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	None.
!
! SIDE EFFECTS:
!
!	Displays lexical token information on the terminal.
!
!--

    begin
    PUT_MSG_EOL ('PAT$DUMP_TOKS :');
    PUT_MSG ('Current symbol:	');
    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.CURRENT_SYMBOL));
    PUT_EOL ();
    PUT_EOL ();

    if .HAVE_INITIAL_SYMBOL
    then
	begin
	PUT_MSG ('Initial symbol:	');
	PUT_STRING (PAT$DATA_SYMBOL_TEXT (.INITIAL_SYMBOL));
	PUT_EOL ();
	end
    else
	PUT_MSG_EOL ('No initial symbol');

    PUT_EOL ();
    PUT_MSG_EOL ('Current lexical token (PAT$TOKEN_CURRENT_PTR):');
    LS_DUMP_TOK (.PAT$TOKEN_CURRENT_PTR);
    PUT_EOL ();
    PUT_MSG_EOL ('Most recently read lexical token (LATEST_TOKEN_PTR):');

    if .LATEST_TOKEN_PTR neq NULL
    then
	begin
	LS_DUMP_TOK (.LATEST_TOKEN_PTR);
	PUT_EOL ();
	end
    else
	PUT_MSG_EOL ('NULL');

    PUT_EOL ();
    PUT_MSG_EOL ('Lexical token read prior to one above (PRIOR_TOKEN_PTR):');

    if .PRIOR_TOKEN_PTR neq NULL
    then
	begin
	LS_DUMP_TOK (.PRIOR_TOKEN_PTR);
	PUT_EOL ();
	end
    else
	PUT_MSG_EOL ('NULL');

    PUT_EOL ();
    end;					! Of PAT$DUMP_TOKS

%fi
%if PATBLSEXT_DEBUGGING and PATBLSEXT_LOCAL_RECOVERY
%then

global routine PAT$DUMP_BACKUP_INFO : novalue =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Displays backup information useful in understanding
!	the order in which error recovery will perform backup.
!
! FORMAL PARAMETERS:
!
!	None.
!
! IMPLICIT INPUTS:
!
!	None.
!
! IMPLICIT OUTPUTS:
!
!	None.
!
! ROUTINE VALUE:
!
!	None.
!
! SIDE EFFECTS:
!
!	Writes to the user's terminal.
!
!--

    begin

    local
	STATUS,
	ORDER;

    macro
	PUT_STATUS (STAT) =
	    selectone (STAT) of
		set
		[CONSUME_TERM_ON_REDUCTION] :
		    PUT_MSG ('"consuming a terminal on a reduction"');

		[CONSUME_TERM_ON_SHIFT] :
		    PUT_MSG ('"consuming a terminal on a shift"');

		[REDUCT_AFTER_BACKUP_NOT_ALLOWED] :
		    PUT_MSG ('"reduction disallowed further backup"');

		[SAVED_INFO_NOT_VALID] :
		    PUT_MSG ('"saved information is not valid for further backup"');

		[ERROR_ENCOUNTERED] :
		    PUT_MSG ('"error encountered"');
		tes %;
    ORDER = FIND_BACKUP_ORDER (.PREV_STATUS, .PREV_PREV_STATUS);
    PUT_MSG_EOL ('PAT$DUMP_BACKUP_INFO :');
    PUT_MSG_EOL ('If local error recovery were to begin now, the following');
    PUT_MSG_EOL ('state(s) would be tried in the order indicated below.');
    PUT_MSG_EOL ('Strong local recovery would be tried from all of those states,');
    PUT_MSG_EOL ('then weak local recovery would be tried from the same states.');
    PUT_EOL ();

!    selectone .ORDER of
!	set
!
!	[ORDER_A] :
!
!	    ! Start from state A (state when error encountered)
!
!	    begin
!	    PUT_MSG_EOL ('(A)  [State where error was encountered.]');
!	    PUT_MSG ('     The current symbol was ');
!	    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.CURRENT_SYMBOL));
!	    PUT_MSG (' and the state was ');
!	    PUT_NUMBER (.PAT$STACK_P [.STACK_PTR, PATSTK_STATE]);
!	    PUT_EOL ();
!	    PUT_EOL ();
!	    end;
!
!	[otherwise] :
!	;
!	tes;
    selectone .ORDER of
	set

	[ORDER_B, ORDER_BC] :

	    ! Try from state B (error state prior to default reductions)

	    begin
	    PUT_MSG_EOL ('(B)  [Error state prior to default reductions.]');
	    PUT_MSG ('     The current symbol was ');

	    selectone .PREV_STATUS of
		set

		[CONSUME_TERM_ON_REDUCTION, REDUCT_AFTER_BACKUP_NOT_ALLOWED] :
		    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.PREV_STACK_RECORD [PATSTK_SYMBOL]));

		[otherwise] :
		    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.CURRENT_SYMBOL));
		tes;

	    PUT_MSG ('.  At that point the state was ');
	    PUT_NUMBER (.PAT$STACK_P [.PREV_STACK_PTR, PATSTK_STATE]);
	    PUT_EOL ();
	    PUT_MSG ('     and the most recent status was ');
	    PUT_STATUS (.PREV_STATUS);
	    PUT_MSG_EOL ('.');
	    PUT_EOL ();
	    end;

	[otherwise] :
	;
	tes;
    selectone .ORDER of
	set

	[ORDER_BC] :

	    ! Try from state C (one token before error token, prior to default reductions)

	    begin
	    PUT_MSG_EOL ('(C)  [Before reading latest token, prior to default reductions.]');
	    PUT_MSG ('     The current symbol was ');

	    selectone .PREV_PREV_STATUS of
		set

		[CONSUME_TERM_ON_REDUCTION, REDUCT_AFTER_BACKUP_NOT_ALLOWED] :
		    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.PREV_PREV_STACK_RECORD [PATSTK_SYMBOL]));

		[otherwise] :
		    PUT_STRING (PAT$DATA_SYMBOL_TEXT (LS_LEX_TERM (PRIOR_TOKEN_PTR)));
		tes;

	    PUT_MSG ('.  At that point the state was ');
	    PUT_NUMBER (.PAT$STACK_P [.PREV_PREV_STACK_PTR, PATSTK_STATE]);
	    PUT_EOL ();
	    PUT_MSG ('     and the most recent status was ');
	    PUT_STATUS (.PREV_PREV_STATUS);
	    PUT_MSG_EOL ('.');
	    PUT_MSG ('     The token which will be read next is ');
	    PUT_STRING (PAT$DATA_SYMBOL_TEXT (LS_LEX_TERM (LATEST_TOKEN_PTR)));
	    PUT_EOL ();
	    PUT_EOL ();
	    end;

	[otherwise] :
	;
	tes;
! Move this code here to reflect that we will always try from state A.

	    ! Start from state A (state when error encountered)

	    PUT_MSG_EOL ('(A)  [State where error was encountered.]');
	    PUT_MSG ('     The current symbol was ');
	    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.CURRENT_SYMBOL));
	    PUT_MSG (' and the state was ');
	    PUT_NUMBER (.PAT$STACK_P [.STACK_PTR, PATSTK_STATE]);
	    PUT_EOL ();
	    PUT_EOL ();
    PUT_MSG ('Global error recovery will always begin in state ');
    PUT_NUMBER (.PAT$STACK_P [.STACK_PTR, PATSTK_STATE]);
    PUT_EOL ();
    PUT_MSG ('with the current symbol ');
!    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.CURRENT_SYMBOL));
    PUT_STRING (PAT$DATA_SYMBOL_TEXT (LS_LEX_TERM (PAT$TOKEN_CURRENT_PTR)));
    PUT_MSG_EOL ('.  The global recovery');
    PUT_MSG ('error message will indicate symbols expected in state ');
    if .PREV_STATUS eql SAVED_INFO_NOT_VALID
    then
	begin
	PUT_NUMBER (.PAT$STACK_P [.STACK_PTR, PATSTK_STATE]);
	PUT_EOL ();
	PUT_MSG ('with the status ');
	STATUS = ERROR_ENCOUNTERED;
	PUT_STATUS (.STATUS);
	PUT_EOL ();
	PUT_MSG ('and the current symbol ');
	PUT_STRING (PAT$DATA_SYMBOL_TEXT (.CURRENT_SYMBOL));
	end
    else
	begin
	PUT_NUMBER (.PREV_STACK_RECORD [PATSTK_STATE]);
	PUT_EOL ();
	PUT_MSG ('with the status ');
	PUT_STATUS (.PREV_STATUS);
	PUT_EOL ();
	PUT_MSG ('and the current symbol ');
	PUT_STRING (PAT$DATA_SYMBOL_TEXT (.PREV_STACK_RECORD [PATSTK_SYMBOL]));
	end;

    PUT_EOL ();

    if .PREV_STATUS eql REDUCT_AFTER_BACKUP_NOT_ALLOWED
    then
	begin
	PUT_MSG ('and state ');
	PUT_NUMBER (.GLOBAL_MSG_INIT_STATE);
	PUT_MSG_EOL (' with the status ');
	PUT_STATUS (.GLOBAL_MSG_STATUS);
	PUT_MSG (' and the current symbol ');
	PUT_STRING (PAT$DATA_SYMBOL_TEXT (.GLOBAL_MSG_SYMBOL));
	PUT_EOL ();
	end;

    end;					! Of PAT$DUMP_BACKUP_INFO

%fi
%if PATBLSEXT_DEBUGGING
%then

global routine PAT$DUMP_PARSE_STACK : novalue =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Debugging routine to display the contents of the parse stack.
!
! FORMAL PARAMETERS:
!
!	None.
!
! IMPLICIT INPUTS:
!
!	STACK_PTR
!	PAT$STACK_P
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	None.
!
! SIDE EFFECTS:
!
!	Contents of the parse stack are displayed on the terminal.
!
!--
    begin

    macro
	SPACE =
	    ' ' %;
    macro
	TAB =
	    '	' %;
    local
	S_PTR,
	SYMBOL,
	ACTION_NUM,
	LHS_SYMBOL,
	RHS_COUNT,
	SEMACT,
	NEW_PTR;

    if .REDUCTION_CODE lss 0
    then
	NEW_PTR = -1
    else
	begin
	PAT$DATA_GET_REDUCTION_INFO (.REDUCTION_CODE, LHS_SYMBOL, RHS_COUNT, SEMACT);
	if .PAR_LOOKAHEAD_F then NEW_PTR = .STACK_PTR - .RHS_COUNT else NEW_PTR = .STACK_PTR - .RHS_COUNT + 1;
	end;
    PUT_MSG_EOL ('PAT$DUMP_PARSE_STACK:');
    PUT_MSG_EOL ('stack	state');

%if PATBLSEXT_EXTRA_STACK_FIELD
%then
    PUT_MSG_EOL ('index	index	locator  comment  symbol');
%else
    PUT_MSG_EOL ('index	index	locator  symbol');
%fi

    incr I from 0 to .STACK_PTR - 1 do
	begin
	PUT_NUMBER (.I);
	PUT_MSG (TAB);
	S_PTR = .I;
	SYMBOL = .PAT$STACK_P [.S_PTR, PATSTK_SYMBOL];
	PUT_NUMBER (.PAT$STACK_P [.S_PTR, PATSTK_STATE]);
	PUT_MSG (TAB);
	PUT_HEX_LONG (.PAT$STACK_P [.S_PTR, PATSTK_LOCATOR]);
	PUT_MSG (SPACE);

%if PATBLSEXT_EXTRA_STACK_FIELD
%then
	PUT_HEX_LONG (.PAT$STACK_P [.S_PTR, PATSTK_EXTRA_INFO]);
	PUT_MSG (SPACE);
%fi

	PUT_STRING (PAT$DATA_SYMBOL_TEXT (.SYMBOL));

	if .I eql .NEW_PTR
	then
	    begin
	    PUT_MSG ('	Reduce to:  ');
	    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.LHS_SYMBOL));
	    end;

	PUT_EOL ();
	end;

    PUT_NUMBER (.STACK_PTR);
    PUT_MSG (TAB);
    PUT_NUMBER (.PAT$STACK_P [.STACK_PTR, PATSTK_STATE]);

    if .REDUCTION_CODE geq 0
    then

    ! Process the top-most stack entry for a reduction.

	begin
	PUT_MSG (TAB);
	PUT_HEX_LONG (.PAT$STACK_P [.STACK_PTR, PATSTK_LOCATOR]);

%if PATBLSEXT_EXTRA_STACK_FIELD
%then
	PUT_MSG (SPACE);
	PUT_HEX_LONG (.PAT$STACK_P [.STACK_PTR, PATSTK_EXTRA_INFO]);
%fi

	if .NEW_PTR eql .STACK_PTR
	then

	! NEW_PTR is the same as STACK_PTR if this is a lookahead
	! epsilon reduction or if it's a non-lookahead reduction
	! with one symbol on the right hand side.

	    if .RHS_COUNT eql 0
	    then
		begin
		! This is a lookahead epsilon reduction.
		PUT_MSG (SPACE);
		PUT_STRING (PAT$DATA_SYMBOL_TEXT (.LHS_SYMBOL));
		PUT_MSG ('	Reduction:  ');
		PUT_STRING (PAT$DATA_SYMBOL_TEXT (.LHS_SYMBOL));
		PUT_MSG (' = epsilon');
		end
	    else
		if .RHS_COUNT eql 1
		then
		    begin
		    ! This is a non-lookahead reduction with one symbol on the rhs
		    PUT_MSG (SPACE);
		    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.PAT$STACK_P [.STACK_PTR, PATSTK_SYMBOL]));
		    PUT_MSG ('	Reduce to:  ');
		    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.LHS_SYMBOL));
		    end
		else
		    PUT_MSG_EOL ('PAT$DUMP_PARSE_STACK makes an incorrect assumption about the parse stack!')
	else

	! This is a another kind of reduction.

	    if not .PAR_LOOKAHEAD_F
	    then
		begin
		PUT_MSG (SPACE);
		PUT_STRING (PAT$DATA_SYMBOL_TEXT (.PAT$STACK_P [.STACK_PTR, PATSTK_SYMBOL]));
		end;
	end;

    PUT_EOL ();
    end;					! Of routine PAT$DUMP_PARSE_STACK

%fi
%if PATBLSEXT_DEBUGGING
%then

global routine PAT$DUMP_REDUCTION : novalue =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	Debugging routine to do a symbolic display of the
!	current reduction, including the contents of the current
!	parse stack.
!
! FORMAL PARAMETERS:
!
!	None.
!
! IMPLICIT INPUTS:
!
!	STACK_PTR
!	PAT$STACK_P
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	None.
!
! SIDE EFFECTS:
!
!	Reduction information is displayed on the terminal.
!
!--

    begin

    literal
	CONT_INDENT = 17;

    local
	pblank: $STR_DESCRIPTOR (string=' '),				! 004
	S_PTR,
	L_PTR,
	R_PTR,
	SYMBOL,
	LHS_SYMBOL,
	RHS_COUNT,
	SEMACT,
	ACTION_NUM;

    if .REDUCTION_CODE lss 0
    then
	begin
	PUT_MSG_EOL ('PAT$DUMP_REDUCTION:  There is no current reduction.');
	return
	end;

    PAT$DATA_GET_REDUCTION_INFO (.REDUCTION_CODE, LHS_SYMBOL, RHS_COUNT, SEMACT);

    if .PAR_LOOKAHEAD_F
    then
	begin
	L_PTR = .STACK_PTR - .RHS_COUNT;
	R_PTR = .STACK_PTR - 1;
	end
    else
	begin
	L_PTR = .STACK_PTR - .RHS_COUNT + 1;
	R_PTR = .STACK_PTR;
	end;

    PUT_MSG ('  Reduction:    ');
    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.LHS_SYMBOL));
    PUT_MSG (' = ');

    if .RHS_COUNT eql 0
    then
	PUT_MSG ('epsilon')
    else
	begin
	PUT_START_AUTOEOL (CONT_INDENT,					! 004
	    .pblank [STR$H_LENGTH], .pblank [STR$A_POINTER]);		! 004

	incr I from .L_PTR to .R_PTR do
	    begin
	    S_PTR = .I;
	    SYMBOL = .PAT$STACK_P [.S_PTR, PATSTK_SYMBOL];
	    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.SYMBOL));
	    end;

	PUT_END_AUTOEOL ();
	end;

    PUT_EOL ();
    PUT_MSG ('  Parse stack:  ');
    PUT_START_AUTOEOL (CONT_INDENT, pblank);				! 004

    incr I from 0 to .L_PTR - 1 do
	begin
	S_PTR = .I;
	SYMBOL = .PAT$STACK_P [.S_PTR, PATSTK_SYMBOL];
	PUT_STRING (PAT$DATA_SYMBOL_TEXT (.SYMBOL));
	end;

    PUT_STRING (PAT$DATA_SYMBOL_TEXT (.LHS_SYMBOL));
    PUT_END_AUTOEOL ();
    PUT_EOL ();
    end;					! Of routine PAT$DUMP_REDUCTION

%fi

end						! End of module

eludom