-- file PGSParse.Mesa
-- last modified by Satterthwaite,  July 14, 1980  2:50 PM

DIRECTORY
  PGS1: FROM "pgs1" USING [
    AllocateHeapNode, AllocateSegment, AssignDescriptors, Atom,
    ErrorContext, FreeHeapNode, FreeSegment,
    outchar,outeol, outnum, outstring, outtab, ProcessQueue,
    resetoutstream, ResetScanIndex, ScanInit, ScanReset,
    Token, TokenValue],
  ParseTable: FROM "PGSParseTable" USING [
    ActionEntry, ActionTag, DefaultMarker, EndMarker, FinalState, Handle,
    InitialState, NTIndex, NTState, NTSymbol, Production, ProductionInfo,
    State, TIndex, TSymbol, InitialSymbol];

Parser: PROGRAM
    IMPORTS PGS1 
    EXPORTS PGS1 =
  BEGIN  -- Mesa parser with error recovery
  OPEN ParseTable, PGS1;

  ErrorLimit: CARDINAL = 25;

  Scan: ActionTag = [FALSE, 0];

  inputSymbol: TSymbol;

  input: PROC RETURNS [token: Token];
  inputLoc: CARDINAL;
  inputValue: UNSPECIFIED;

  lastToken: Token;
  NullSymbol: TSymbol = 0;

  s: DESCRIPTOR FOR ARRAY OF State;
  l: DESCRIPTOR FOR ARRAY OF CARDINAL;
  v: DESCRIPTOR FOR ARRAY OF UNSPECIFIED;
  top: CARDINAL;
  stackSize: CARDINAL;

  q: DESCRIPTOR FOR ARRAY OF ActionEntry;
  qI: CARDINAL;
  queueSize: CARDINAL;

  lalrTable: ParseTable.Handle;

  -- transition tables for terminal input symbols

  tStart: POINTER TO ARRAY State OF TIndex;
  tLength: POINTER TO ARRAY State OF CARDINAL;
  tSymbol: POINTER TO ARRAY TIndex OF TSymbol;
  tAction: POINTER TO ARRAY TIndex OF ActionEntry;

  -- transition tables for nonterminal input symbols

  nStart: POINTER TO ARRAY NTState OF NTIndex;
  nLength: POINTER TO ARRAY NTState OF CARDINAL;
  nSymbol: POINTER TO ARRAY NTIndex OF NTSymbol;
  nAction: POINTER TO ARRAY NTIndex OF ActionEntry;
  ntDefaults: POINTER TO ARRAY NTSymbol OF ActionEntry;

  -- production information

  prodData: POINTER TO ARRAY Production OF ProductionInfo;


-- initialization/termination

  ParseInit: PROC [tablePtr: ParseTable.Handle] =
    BEGIN
    lalrTable ← tablePtr;		-- for error reporting
    PGS1.ScanInit[tablePtr];
    tStart ← @tablePtr.parseTable.tStart;
    tLength ← @tablePtr.parseTable.tLength;
    tSymbol ← @tablePtr.parseTable.tSymbol;
    tAction ← @tablePtr.parseTable.tAction;
    nStart ← @tablePtr.parseTable.nStart;
    nLength ← @tablePtr.parseTable.nLength;
    nSymbol ← @tablePtr.parseTable.nSymbol;
    nAction ← @tablePtr.parseTable.nAction;
    ntDefaults ← @tablePtr.parseTable.ntDefaults;
    prodData ← @tablePtr.parseTable.prodData;
    stackSize ← queueSize ← 0;  ExpandStack[512];  ExpandQueue[256];
    END;

  InputLoc: PUBLIC PROC RETURNS [CARDINAL] = BEGIN RETURN [inputLoc] END;


-- * * * *  Main Parsing Procedures * * * * --

  Parse: PUBLIC PROC [table: ParseTable.Handle]
      RETURNS [complete: BOOLEAN, nTokens, nErrors: CARDINAL] =
    BEGIN
    currentState: State;
    lhs: NTSymbol;
    i, valid, k, m: CARDINAL;		-- stack pointers
    tI: TIndex;
    nI: NTIndex;
    action: ActionEntry;

    ParseInit[table];  input ← PGS1.Atom;
    nErrors ← 0;  complete ← TRUE;
    i ← top ← valid ← 0;  qI ← 0;
    s[0] ← currentState ← InitialState;  lastToken.class ← NullSymbol;
    inputSymbol ← InitialSymbol;  inputValue ← 0;  inputLoc ← 0;

    WHILE currentState # FinalState DO
      BEGIN
      tI ← tStart[currentState];
      FOR tI IN [tI .. tI + tLength[currentState]) 
	DO
	SELECT tSymbol[tI] FROM
	  inputSymbol, DefaultMarker => EXIT;
	  ENDCASE;
	REPEAT
	  FINISHED => GO TO SyntaxError;
	ENDLOOP;

      action ← tAction[tI]; 
      IF ~action.tag.reduce	-- scan or scan reduce entry
	THEN
	  BEGIN
	  IF qI > 0 
	    THEN
	      BEGIN
	      FOR k IN (valid..i] DO s[k] ← s[top+(k-valid)] ENDLOOP;
	      PGS1.ProcessQueue[qI, top];  qI ← 0;
	      END;
	  IF (top ← valid ← i ← i+1) >= stackSize THEN ExpandStack[256];
	  lastToken.class ← inputSymbol; v[i] ← inputValue; l[i] ← inputLoc;
	  [inputSymbol, inputValue, inputLoc]  ← input[].token;
	  END;

      WHILE action.tag # Scan 
        DO
        IF qI >= queueSize THEN ExpandQueue[256];
        q[qI] ← action;  qI ← qI + 1;
        i ← i-action.tag.pLength;
        currentState ← s[IF i > valid THEN top+(i-valid) ELSE (valid ← i)];
        lhs ← prodData[action.transition].lhs;
	  BEGIN
	  IF currentState <= LAST[NTState] 
	    THEN
	      BEGIN  nI ← nStart[currentState];
	      FOR nI IN [nI..nI+nLength[currentState])
		DO
		IF lhs = nSymbol[nI] THEN
		  BEGIN  action ← nAction[nI]; GO TO nFound  END;
		ENDLOOP;
	      END;
	  action ← ntDefaults[lhs];
	  EXITS
	    nFound => NULL;
	  END;
        i ← i+1;
        ENDLOOP;
      IF (m ← top+(i-valid)) >= stackSize THEN ExpandStack[256];
      s[m] ← currentState ← action.transition;
      EXITS
	SyntaxError =>
	  BEGIN
	  lastToken.value ← v[top];  lastToken.index ← l[top];
	  top ← top - 1;
	  complete ← SyntaxError[(nErrors←nErrors+1)>ErrorLimit]; 
	  i ← valid ← top;  qI ← 0;  lastToken.class ← NullSymbol;
	  currentState ← s[i];
	  [inputSymbol, inputValue, inputLoc] ← input[].token;
	  IF ~complete THEN EXIT
	  END;
      END;
    ENDLOOP;

    PGS1.ProcessQueue[qI, top];
    EraseQueue[];  EraseStack[];
      BEGIN
      n: CARDINAL;
      [nTokens, n] ← PGS1.ScanReset[nErrors];  nErrors ← nErrors + n;
      END;
    RETURN
    END;


  ExpandStack: PROC [delta: CARDINAL] =
    BEGIN i: CARDINAL;
    newS: DESCRIPTOR FOR ARRAY OF State;
    newL: DESCRIPTOR FOR ARRAY OF CARDINAL;
    newV: DESCRIPTOR FOR ARRAY OF UNSPECIFIED;
    newSize: CARDINAL = stackSize + delta;
    newS ← DESCRIPTOR[AllocateSegment[newSize*SIZE[State]], newSize];
    newL ← DESCRIPTOR[AllocateSegment[newSize*SIZE[CARDINAL]], newSize];
    newV ← DESCRIPTOR[AllocateSegment[newSize*SIZE[UNSPECIFIED]], newSize];
    FOR i IN [0..stackSize)
      DO  newS[i] ← s[i];  newL[i] ← l[i];  newV[i] ← v[i]  ENDLOOP;
    EraseStack[];
    s ← newS;  l ← newL;  v ← newV;  stackSize ← newSize;
    PGS1.AssignDescriptors[qd:q, vd:v, ld:l, pp:prodData];
    END;

  EraseStack: PROC =
    BEGIN
    IF stackSize # 0 THEN
      BEGIN FreeSegment[BASE[v]];  FreeSegment[BASE[l]];  FreeSegment[BASE[s]];
      END;
    END;

  ExpandQueue: PROC [delta: CARDINAL] =
    BEGIN i: CARDINAL;
    newQ: DESCRIPTOR FOR ARRAY OF ActionEntry;
    newSize: CARDINAL = queueSize + delta;
    newQ ← DESCRIPTOR[AllocateSegment[newSize*SIZE[ActionEntry]], newSize];
    FOR i IN [0..queueSize)  DO  newQ[i] ← q[i]  ENDLOOP;
    EraseQueue[];
    q ← newQ;  queueSize ← newSize;
    PGS1.AssignDescriptors[qd:q, vd:v, ld:l, pp:prodData];
    END;

  EraseQueue: PROC =
    BEGIN
    IF queueSize # 0 THEN FreeSegment[BASE[q]];
    END;



-- * * * * Error Recovery Section * * * * --

 -- parameters of error recovery

  MinScanLimit: CARDINAL = 4;
  MaxScanLimit: CARDINAL = 12;
  InsertLimit: CARDINAL = 2;
  DiscardLimit: CARDINAL = 10;
  TreeSize: CARDINAL = 256;
  CheckSize: CARDINAL = MaxScanLimit+InsertLimit+2;


 -- debugging

  ParserID: PUBLIC PROC RETURNS [STRING] =
    BEGIN
    RETURN [NIL]
    END;

  track: BOOLEAN = FALSE;

  DisplayNode: PROC [n: NodeIndex] =
    BEGIN IF track THEN
      BEGIN
      outstring["::new node::"L];
      outtab[]; outnum[n,1];
      outtab[]; outnum[tree[n].father,1]; 
      outtab[]; outnum[tree[n].last,1]; outtab[];
      outnum[tree[n].state,1];  outtab[]; TypeSym[tree[n].symbol];
      outeol[1];
      END;
    END;


 -- tree management

  NodeIndex: TYPE = CARDINAL [0..TreeSize);
  NullIndex: NodeIndex = 0;

  StackNode: TYPE = RECORD[
    father: NodeIndex,
    last: NodeIndex,
    state:  State,
    symbol: TSymbol,
    aLeaf, bLeaf: BOOLEAN,
    link: NodeIndex];

  tree: POINTER TO ARRAY [0..TreeSize) OF StackNode;
  nextNode: NodeIndex;
  maxNode: NodeIndex;
  treeLimit: CARDINAL;
  TreeFull: SIGNAL = CODE;


  Allocate: PROC [parent, pred: NodeIndex, terminal: TSymbol, stateNo: State]
      RETURNS [index: NodeIndex] =
    BEGIN
    IF (index ← nextNode) >= treeLimit THEN SIGNAL TreeFull;
    maxNode ← MAX[index, maxNode];
    tree[index] ← StackNode[
	father: parent,
	last: pred,
	state: stateNo,
	symbol: terminal,
	aLeaf: FALSE,
 	bLeaf: FALSE,
	link: NullIndex];
    nextNode ← nextNode+1;  RETURN
    END;


  HashSize: INTEGER = 256;	-- should depend on state count ?
  hashTable: POINTER TO ARRAY [0..HashSize) OF NodeIndex;

  ParsingMode: TYPE = {ATree, BTree, Checking};
  parseMode: ParsingMode;

  LinkHash: PROC [n: NodeIndex] =
    BEGIN
    htIndex: [0..HashSize) = tree[n].state MOD HashSize;
    tree[n].link ← hashTable[htIndex];  hashTable[htIndex] ← n;
    END;

  ExistingConfiguration: PROC [stack: StackRep] RETURNS [NodeIndex] =
    BEGIN
    n, n1, n2: NodeIndex;
    s1, s2: State;
    htIndex: [0..HashSize);
    aTree: BOOLEAN;
    SELECT parseMode FROM
      ATree =>  aTree ← TRUE;
      BTree =>  aTree ← FALSE;
      ENDCASE => RETURN [NullIndex];
    htIndex ← stack.extension MOD HashSize;
    FOR n ← hashTable[htIndex], tree[n].link UNTIL n = NullIndex
      DO
      IF (IF aTree THEN tree[n].aLeaf ELSE tree[n].bLeaf) THEN
	BEGIN
	s1 ← stack.extension;  s2 ← tree[n].state;
	n1 ← stack.leaf;       n2 ← tree[n].father;
	  DO
	  IF s1 # s2 THEN EXIT;
	  IF n1 = n2 THEN RETURN [n];
	  s1 ← tree[n1].state;  s2 ← tree[n2].state;
	  n1 ← tree[n1].father;  n2 ← tree[n2].father;
	  ENDLOOP;
	END;
      ENDLOOP;
    RETURN [NullIndex]
    END;

  FindNode: PROC [parent, pred: NodeIndex, stateNo: State] RETURNS [index: NodeIndex] =
    BEGIN
    index ← ExistingConfiguration[[leaf:parent, extension:stateNo]];
    IF index = NullIndex
      THEN
	BEGIN
	index ← Allocate[parent, pred, 0, stateNo];
	SELECT parseMode FROM
	  ATree =>  BEGIN  tree[index].aLeaf ← TRUE;  LinkHash[index]  END;
	  BTree =>  BEGIN  tree[index].bLeaf ← TRUE;  LinkHash[index]  END;
	  ENDCASE => NULL;
	END;
    RETURN
    END;


 -- parsing simulation

  ExtState: TYPE = [FIRST[State] .. LAST[State]+1];
  NullState: ExtState = LAST[ExtState];

  StackRep: TYPE = RECORD[
    leaf: NodeIndex,
    extension: ExtState];


  GetNTEntry: PROC [state: State, lhs: NTSymbol] RETURNS [ActionEntry] =
    BEGIN
    nI: NTIndex;
    IF state <= LAST[NTState] THEN
      BEGIN
      nI ← nStart[state];
      FOR nI IN [nI..nI+nLength[state])
	DO  IF lhs = nSymbol[nI] THEN RETURN [nAction[nI]]  ENDLOOP;
      END;
    RETURN [ntDefaults[lhs]]
    END;

  ActOnStack: PROC [stack: StackRep, action: ActionEntry, nScanned: [0..1]]
      RETURNS [StackRep] =
    BEGIN
    currentNode, thread: NodeIndex;
    currentState: State;
    count: CARDINAL;
    currentNode ← thread ← stack.leaf;  count ← nScanned;
    IF stack.extension = NullState
      THEN  currentState ← tree[currentNode].state
      ELSE  BEGIN  currentState ← stack.extension;  count ← count + 1  END;
    UNTIL action.tag = Scan
      DO
      IF count > action.tag.pLength  -- can be one greater
	THEN
	  BEGIN
	  currentNode ← FindNode[currentNode, thread, currentState];
	  count ← count - 1;
	  END;
      UNTIL count = action.tag.pLength
	DO
	currentNode ← tree[currentNode].father;  count ← count + 1;
	ENDLOOP;
      currentState ← tree[currentNode].state;  count ← 1;
      action ← GetNTEntry[currentState, prodData[action.transition].lhs];
      ENDLOOP;
    IF count > 1
      THEN currentNode ← FindNode[currentNode, thread, currentState];
    stack.leaf ← currentNode;  stack.extension ← action.transition;
    RETURN [stack]
    END;


  ParseStep: PROC [stack: StackRep, input: TSymbol] RETURNS [StackRep] =
    BEGIN
    currentState: State;
    tI: TIndex;
    action: ActionEntry;
    count: [0..1];
    scanned: BOOLEAN ← FALSE;
    currentState ← IF stack.extension = NullState
	THEN tree[stack.leaf].state
	ELSE stack.extension;
    WHILE ~scanned 
      DO
      tI ← tStart[currentState];
      FOR tI IN [tI..tI+tLength[currentState])
	DO
	SELECT tSymbol[tI] FROM
	  input, DefaultMarker => EXIT;
	  ENDCASE;
	REPEAT
	  FINISHED => RETURN [[NullIndex, NullState]];
	ENDLOOP;
      action ← tAction[tI];
      IF ~action.tag.reduce
	THEN  -- shift or shift reduce
	  BEGIN  count ← 1;  scanned ← TRUE  END
	ELSE  count ← 0;
      stack ← ActOnStack[stack, action, count];
      currentState ← stack.extension;
      ENDLOOP;
    RETURN [stack]
    END;


 -- text buffer management

  Insert: TYPE = ARRAY [0 .. 1+InsertLimit) OF Token;
  newText: POINTER TO Insert;
  insertCount: CARDINAL;

  Buffer: TYPE =
   ARRAY [0 .. 1 + DiscardLimit + (MaxScanLimit+InsertLimit)) OF Token;
  sourceText: POINTER TO Buffer;
  scanBase, scanLimit: CARDINAL;


  Advance: PROC =
    BEGIN
    sourceText[scanLimit] ← input[];  scanLimit ← scanLimit + 1;
    END;

  Discard: PROC =
    BEGIN
    IF track THEN
      BEGIN outstring["::discarding symbol -- "L];
      TypeSym[sourceText[scanBase].class];  outeol[1];
      END;
    scanBase ← scanBase+1;
    END;

  UnDiscard: PROC =
    BEGIN
    scanBase ← scanBase-1;
    IF track THEN
      BEGIN outstring["::recovering symbol -- "L];
      TypeSym[sourceText[scanBase].class];  outeol[1];
      END;
    END;

  RecoverInput: PROC RETURNS [token: Token] =
    BEGIN
    IF insertCount <= InsertLimit 
      THEN
	BEGIN  token ← newText[insertCount];
	IF (insertCount ← insertCount+1) > InsertLimit
	  THEN FreeHeapNode[newText];
	END
      ELSE
	BEGIN  token ← sourceText[scanBase];
	IF (scanBase ← scanBase+1) = scanLimit
	  THEN BEGIN FreeHeapNode[sourceText]; input ← PGS1.Atom END;
	END;
    RETURN
    END;


 -- acceptance checking

  best: RECORD [
    nAccepted: CARDINAL,
    nPassed: [0..1],
    node: NodeIndex,
    mode: ParsingMode,
    nDiscards: CARDINAL];

  RightScan: PROC [node: NodeIndex] RETURNS [stop: BOOLEAN] =
    BEGIN
    i: CARDINAL;
    stack: StackRep;
    state: State;
    nAccepted: CARDINAL;
    savedNextNode: NodeIndex = nextNode;
    savedMode: ParsingMode = parseMode;
    savedLimit: CARDINAL = treeLimit;
    parseMode ← Checking;  treeLimit ← TreeSize;
    nAccepted ← 0;
    state ← tree[node].state;  stack ← [leaf:node, extension:NullState];
    FOR i IN [scanBase .. scanLimit) 
      DO
      IF state = FinalState
	THEN
	  BEGIN
	  nAccepted ← IF (sourceText[i].class = EndMarker)
	    THEN scanLimit-scanBase
	    ELSE 0;
	  EXIT
	  END;
      stack ← ParseStep[stack, sourceText[i].class];
      IF stack.leaf = NullIndex THEN EXIT;
      nAccepted ← nAccepted + 1;  state ← stack.extension;
      ENDLOOP;
    nextNode ← savedNextNode;  treeLimit ← savedLimit;
    SELECT (parseMode ← savedMode) FROM
      ATree =>
	IF nAccepted + 1 > best.nAccepted + best.nPassed
	  THEN best ← [nAccepted, 1, node, ATree, scanBase-1];
      BTree =>
	IF nAccepted > best.nAccepted + best.nPassed
	  THEN best ← [nAccepted, 0, node, BTree, scanBase];
      ENDCASE;
    RETURN [nAccepted >= MaxScanLimit]
    END;


 -- strategy management

  RowRecord: TYPE = RECORD [
    index, limit: CARDINAL,
    stack: StackRep,
    next: RowHandle];

  RowHandle: TYPE = POINTER TO RowRecord;

  NextRow: PROC [list: RowHandle] RETURNS [row: RowHandle] =
    BEGIN
    r: RowHandle;
    s, t: TSymbol;
    row ← NIL;
    FOR r ← list, r.next UNTIL r = NIL
      DO
      IF r.index < r.limit
	THEN
	  BEGIN  s ← tSymbol[r.index];
	  IF row = NIL OR s < t THEN  BEGIN  row ← r;  t ← s  END;
	  END;
      ENDLOOP;
    RETURN
    END;

  FreeRowList: PROC [list: RowHandle] =
    BEGIN
    r, next: RowHandle;
    FOR r ← list, next UNTIL r = NIL
      DO  next ← r.next;  FreeHeapNode[r]  ENDLOOP;
    END;


  Position: TYPE = {after, before};
  Length: TYPE = CARDINAL [0..InsertLimit];

  levelStart, levelEnd: ARRAY Position OF ARRAY Length OF NodeIndex;


  AddLeaf: PROC [stack: StackRep, s: TSymbol, thread: NodeIndex] RETURNS [stop: BOOLEAN] =
    BEGIN
    newLeaf: NodeIndex;
    saveNextNode: NodeIndex = nextNode;
    stack ← ParseStep[stack, s];
    IF stack.leaf = NullIndex OR ExistingConfiguration[stack] # NullIndex
      THEN   BEGIN  nextNode ← saveNextNode;  stop ← FALSE  END 
      ELSE
	BEGIN
	newLeaf ← Allocate[stack.leaf, thread, s, stack.extension];
	SELECT parseMode FROM
	  ATree => tree[newLeaf].aLeaf ← TRUE;
	  BTree => tree[newLeaf].bLeaf ← TRUE;
	  ENDCASE => ERROR;
	LinkHash[newLeaf];
	IF track THEN DisplayNode[newLeaf];
	stop ← RightScan[newLeaf];
	END;
    RETURN
    END;


  GrowTree: PROC [p: Position, n: Length] RETURNS [stop: BOOLEAN] =
    BEGIN
    i: NodeIndex;
    tI, tLimit: TIndex;
    stack: StackRep;
    state: State;
    rowList, r: RowHandle;
    s: TSymbol;
    IF track THEN
      BEGIN outstring["::generating length -- "L];  outnum[n,1];
      outchar[IF p = before THEN 'B ELSE 'A,1];  outeol[1];
      END;
    rowList ← NIL;
    FOR i IN [levelStart[p][n-1] .. levelEnd[p][n-1]) 
      DO
      IF tree[i].symbol # 0 OR n = 1
	THEN
	  BEGIN
	  ENABLE  UNWIND => FreeRowList[rowList];
	  rowList ← NIL;
	  stack ← [leaf:i, extension:NullState];  state ← tree[i].state;
	    DO
	    tI ← tStart[state];  tLimit ← tI + tLength[state];
	    s ← tSymbol[tLimit-1];
	    r ← AllocateHeapNode[SIZE[RowRecord]];
	    r↑ ← RowRecord[index:tI, limit:tLimit, stack:stack, next:rowList];
	    rowList ← r;
	    IF s # DefaultMarker THEN EXIT;
	    r.limit ← r.limit - 1;
	    stack ← ActOnStack[stack, tAction[tLimit-1], 0];
	    state ← stack.extension;
	    ENDLOOP;
	  UNTIL (r ← NextRow[rowList]) = NIL 
	    DO
	    IF AddLeaf[r.stack, tSymbol[r.index], i] THEN GO TO found;
	    r.index ← r.index + 1;
	    ENDLOOP;
	  END;
      REPEAT
	found => stop ← TRUE;
	FINISHED =>  stop ← FALSE;
      ENDLOOP;
    FreeRowList[rowList];  rowList ← NIL;  RETURN
    END;

  CheckTree: PROC [p: Position, n: Length] RETURNS [stop: BOOLEAN] =
    BEGIN
    i: NodeIndex;
    IF track THEN
      BEGIN outstring["::checking length -- "L];  outnum[n,1];
      outchar[IF p = before THEN 'B ELSE 'A,1];  outeol[1];
      END;
    FOR i IN [levelStart[p][n] .. levelEnd[p][n])
      DO
      ENABLE TreeFull => CONTINUE;
      IF RightScan[i] THEN GO TO found;
      REPEAT
	found => stop ← TRUE;
	FINISHED =>  stop ← FALSE;
      ENDLOOP;
    RETURN
    END;


  Accept: PROC =
    BEGIN
    j: CARDINAL;
    p: NodeIndex;
    s: TSymbol;
    discardBase: CARDINAL = best.nPassed;
    insertCount ← 1+InsertLimit;
    FOR p ← best.node, tree[p].last WHILE p > rTop
      DO
      IF (s ← tree[p].symbol) # 0 THEN
	BEGIN
	insertCount ← insertCount-1;
	newText[insertCount] ← Token[s, PGS1.TokenValue[s], inputLoc];
	END;
      ENDLOOP;
    scanBase ← discardBase;
    IF best.nDiscards # 0 
      THEN
	BEGIN outstring["Text deleted is: "L];
	FOR j IN [1 .. best.nDiscards]
	  DO
	  TypeSym[sourceText[scanBase].class];  scanBase ← scanBase + 1;
	  ENDLOOP;
	END;
    IF insertCount <= InsertLimit 
      THEN
	BEGIN IF scanBase # discardBase THEN outeol[1];
	outstring["Text inserted is: "L];
	FOR j IN [insertCount .. InsertLimit]
	  DO  TypeSym[newText[j].class]  ENDLOOP;
	END;
    IF discardBase = 1
      THEN
	BEGIN
	insertCount ← insertCount-1;  newText[insertCount] ← sourceText[0];
	END;
    IF insertCount > InsertLimit THEN FreeHeapNode[newText];
    IF scanBase + best.nAccepted < scanLimit
      THEN PGS1.ResetScanIndex[sourceText[scanBase+best.nAccepted].index];
    scanLimit ← scanBase + best.nAccepted;
    input ← RecoverInput;
--  outeol[1];
    END;

  TypeSym: PROC [sym: TSymbol] =
    BEGIN
    OPEN lalrTable.scanTable;
    i: CARDINAL;
    vocab: STRING = LOOPHOLE[@vocabBody, STRING];
    outchar[' ,1];
    IF sym ~IN [1..EndMarker)
      THEN outnum[sym,1]
      ELSE
	FOR i IN [vocabIndex[sym-1]..vocabIndex[sym])
	  DO  outchar[vocab[i],1]  ENDLOOP;
    END;


--stack node indices
  rTop: NodeIndex;


  Recover: PROC =
    BEGIN
    ModeMap: ARRAY Position OF ParsingMode = [ATree, BTree];
    i: CARDINAL;
    place: Position;
    level: Length;
    inserts, discards: CARDINAL;
    stack: StackRep;
    threshold: CARDINAL;

    treeLimit ← TreeSize - CheckSize;
    FOR i IN [0 .. HashSize) DO hashTable[i] ← NullIndex ENDLOOP;
    rTop ← NullIndex;  nextNode ← maxNode ← 1;

    best.nAccepted ← 0;  best.nPassed ← 1;  best.mode ← ATree;
    sourceText[0] ← lastToken;
    sourceText[1] ← Token[inputSymbol, inputValue, inputLoc];
    scanBase ← 1;  scanLimit ← 2;
    THROUGH [1 .. MaxScanLimit) DO Advance[]  ENDLOOP;
    FOR i IN [0 .. top)
      DO
      rTop ← Allocate[rTop, rTop, 0, s[i]];
      IF track THEN DisplayNode[rTop];
      ENDLOOP;
    parseMode ← BTree;
    levelStart[before][0] ← rTop ← FindNode[rTop, rTop, s[top]];
    tree[rTop].bLeaf ← TRUE;
    levelEnd[before][0] ← nextNode;
    parseMode ← ATree;
    stack ← ParseStep[[leaf:rTop, extension:NullState], lastToken.class];
    rTop ← FindNode[stack.leaf, rTop, stack.extension];
    tree[rTop].symbol ← lastToken.class;
    tree[rTop].aLeaf ← tree[rTop].bLeaf ← TRUE;
    levelStart[after][0] ← rTop;  levelEnd[after][0] ← nextNode;
    IF track THEN DisplayNode[rTop];

    FOR level IN [1 .. LAST[Length]]
      DO
      FOR place IN Position
	DO
	parseMode ← ModeMap[place];
	IF place = before THEN UnDiscard[];
	-- try simple insertion (inserts=level)
	levelStart[place][level] ← nextNode;
	IF GrowTree[place, level !TreeFull => CONTINUE] THEN GO TO found;
	levelEnd[place][level] ← nextNode;
	-- try discards followed by 0 or more insertions
	FOR discards IN [1 .. level)
	  DO
	  Discard[];
	  IF CheckTree[place, level] THEN GO TO found;
	  ENDLOOP;
	Discard[];
	IF place = after THEN Advance[];
	FOR inserts IN [0 .. level]
	  DO
	  IF CheckTree[place, inserts] THEN GO TO found;
	  ENDLOOP;
	-- undo discards at this level
	FOR discards DECREASING IN [1..level] DO UnDiscard[] ENDLOOP;
	IF place = before THEN Discard[];
	ENDLOOP;
      REPEAT
	found =>  NULL;
	FINISHED =>
	  BEGIN
	  threshold ← (MinScanLimit+MaxScanLimit)/2;
	  FOR discards IN [1..LAST[Length]] DO Discard[]; Advance[] ENDLOOP;
	  UNTIL scanBase > DiscardLimit
	    DO
	    IF best.nAccepted >= threshold THEN GO TO found;
	    Discard[];
	    FOR inserts IN Length
	      DO
	      FOR place IN Position
		DO
		parseMode ← ModeMap[place];
		IF place = before THEN UnDiscard[];
		IF CheckTree[place, inserts] THEN GO TO found;
		IF place = before THEN Discard[];
		ENDLOOP;
	      ENDLOOP;
	    Advance[];
	    threshold ← IF threshold > MinScanLimit THEN threshold-1 ELSE MinScanLimit;
	    REPEAT
	      found => NULL;
	      FINISHED =>
		IF best.nAccepted < MinScanLimit
		  THEN  BEGIN  best.mode ← ATree;  best.nPassed ← 1  END;
	    ENDLOOP;
	  END;
      ENDLOOP;

    END;

  SyntaxError: PROC [abort: BOOLEAN] RETURNS [success: BOOLEAN] =
    BEGIN
    IF abort
      THEN
	BEGIN PGS1.ErrorContext["Syntax Error"L, inputLoc];
	outstring["... Parse abandoned."L];  outeol[1];
	success ← FALSE
	END
      ELSE
	BEGIN sourceText ← AllocateHeapNode[SIZE[Buffer]];
	newText ← AllocateHeapNode[SIZE[Insert]];
	tree ← AllocateSegment[TreeSize*SIZE[StackNode]];
	hashTable ← AllocateSegment[HashSize*SIZE[NodeIndex]];
	Recover[ ! TreeFull => CONTINUE];
	FreeSegment[hashTable];
	PGS1.ErrorContext["Syntax Error"L,
	  sourceText[IF best.mode=BTree THEN 0 ELSE 1].index]; outeol[1];
	IF (success ← best.nAccepted >= MinScanLimit)
	  THEN  Accept[]
	  ELSE
	    BEGIN outstring["No recovery found."L];
	    FreeHeapNode[newText];
	    FreeHeapNode[sourceText];
	    END;
	FreeSegment[tree];
--	outstring["   ("L];  outnum[maxNode,1];  outchar['),1];
	outeol[1];
	END;
    outeol[1]; resetoutstream[];  RETURN
    END;

END.