-- file SMParserImpl.mesa
-- should be merged with CtoSParserImpl.mesa when new modeller permits
-- derived from ProtoParser.mesa
-- last modified by Satterthwaite, July 29, 1983 9:47 am

DIRECTORY
  IO: TYPE USING [card, Put, PutChar, STREAM, string],
  SMP1: TYPE --P1-- USING [
    ActionSeq, ActionStack, Index, LinkSeq, LinkStack, TValue, StateSeq, StateStack,
    Token, Value, ValueSeq, ValueStack, nullNTValue, nullTValue,
    AssignDescriptors, Atom, ErrorContext, InstallScanTable, ProcessQueue,
    ResetScanIndex, ScanInit, ScanReset, TokenValue],
  SMParseTable: TYPE ParseTable USING [
    ActionEntry, ActionTag, NActionsRef, NLengthsRef, NStartsRef, NSymbolsRef,
    NTDefaultsRef, NTIndex, NTState, NTSymbol, ProdDataRef, State, TableRef,
    TActionsRef, TIndex, TLengthsRef, TStartsRef, TSymbol, TSymbolsRef,
    defaultMarker, endMarker, initialState, finalState, initialSymbol],
  SMOps: TYPE USING [MS];

SMParserImpl: PROGRAM
    IMPORTS IO, SMP1
    EXPORTS SMP1 = {
  -- Cedar/Mesa parser with error recovery
  OPEN P1~~SMP1, SMParseTable;

-- table installation
 
  tablePtr: TableRef;

  -- transition tables for terminal input symbols

  tStart: TStartsRef;
  tLength: TLengthsRef;
  tSymbol: TSymbolsRef;
  tAction: TActionsRef;

  -- transition tables for nonterminal input symbols

  nStart: NStartsRef;
  nLength: NLengthsRef;
  nSymbol: NSymbolsRef;
  nAction: NActionsRef;
  ntDefaults: NTDefaultsRef;

  -- production information

  prodData: ProdDataRef;


  InstallParseTable: PUBLIC SAFE PROC [base: TableRef] = TRUSTED {
    tablePtr ← base;
    tStart ← @tablePtr[tablePtr.parseTable.tStart];
    tLength ← @tablePtr[tablePtr.parseTable.tLength];
    tSymbol ← @tablePtr[tablePtr.parseTable.tSymbol];
    tAction ← @tablePtr[tablePtr.parseTable.tAction];
    nStart ← @tablePtr[tablePtr.parseTable.nStart];
    nLength ← @tablePtr[tablePtr.parseTable.nLength];
    nSymbol ← @tablePtr[tablePtr.parseTable.nSymbol];
    nAction ← @tablePtr[tablePtr.parseTable.nAction];
    ntDefaults ← @tablePtr[tablePtr.parseTable.ntDefaults];
    prodData ← @tablePtr[tablePtr.parseTable.prodData];
    P1.InstallScanTable[base]};


-- parser state

  cm: SMOps.MS;
  
  errorLimit: NAT = 25;

  scanTag: ActionTag = [FALSE, 0];

  inputSymbol: TSymbol;

  Input: PROC RETURNS [token: P1.Token];
  inputLoc: P1.Index;
  inputValue: P1.TValue;

  lastToken: P1.Token;
  nullSymbol: TSymbol = 0;

  zone: ZONE ← NIL;
  
  s: P1.StateStack ← NIL;
  l: P1.LinkStack ← NIL;
  v: P1.ValueStack ← NIL;
  top: CARDINAL;

  q: P1.ActionStack ← NIL;
  qI: CARDINAL;

-- initialization/termination

  ParseInit: PROC [scratchZone: ZONE] = INLINE {
    zone ← scratchZone;
    s ← NIL;  q ← NIL;  ExpandStack[500];  ExpandQueue[250];
    scanBuffer ← NIL};

  ParseReset: PROC = INLINE {
    EraseQueue[];  EraseStack[];
    IF scanBuffer # NIL THEN zone.FREE[@scanBuffer];
    zone ← NIL};


  InputLoc: PUBLIC SAFE PROC RETURNS [P1.Index] = CHECKED {
    RETURN [inputLoc]};


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

  Parse: PUBLIC PROC [model: SMOps.MS, source: IO.STREAM, prefix: BOOL]
      RETURNS [complete: BOOL, nTokens, nErrors: NAT] = {
    currentState: State;
    i, valid, m: CARDINAL;		-- stack pointers
    action: ActionEntry;

    cm ← model;
    ParseInit[cm.z];
    P1.ScanInit[cm, source];  Input ← P1.Atom;
    nErrors ← 0;  complete ← TRUE;
    i ← top ← valid ← 0;  qI ← 0;
    s[0] ← currentState ← initialState;  lastToken.class ← nullSymbol;
    inputSymbol ← initialSymbol;  inputValue ← P1.nullTValue;  inputLoc ← 0;

    UNTIL currentState = finalState DO
      BEGIN
      tI: TIndex ← 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 THEN {	-- scan or scan reduce entry
	IF qI > 0 THEN {
	  FOR k: CARDINAL IN (valid..i] DO s[k] ← s[top+(k-valid)] ENDLOOP;
	  P1.ProcessQueue[qI, top];  qI ← 0};
	IF (top ← valid ← i ← i+1) >= s.length THEN ExpandStack[256];
	lastToken.class ← inputSymbol;
	v[i] ← [t~inputValue, n~P1.nullNTValue]; l[i] ← inputLoc;
	[[inputSymbol, inputValue, inputLoc]]  ← Input[]};

      WHILE action.tag # scanTag DO
        IF qI >= q.length 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)];
	  BEGIN
	  lhs: NTSymbol = prodData[action.transition].lhs;
	  IF currentState <= NTState.LAST THEN {
	    nI: NTIndex ← nStart[currentState];
	    FOR nI IN [nI..nI+nLength[currentState]) DO
	      IF lhs = nSymbol[nI] THEN {action ← nAction[nI]; GO TO nFound};
	      ENDLOOP};
	  action ← ntDefaults[lhs];
	  EXITS
	    nFound => NULL;
	  END;
        i ← i+1;
        ENDLOOP;
      IF (m ← top+(i-valid)) >= s.length THEN ExpandStack[256];
      s[m] ← currentState ← action.transition;
      EXITS
	SyntaxError => {
	  lastToken.value ← v[top].t;  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[];
	  IF ~complete THEN EXIT};
      END;
    ENDLOOP;

    P1.ProcessQueue[qI, top];
    nErrors ← nErrors + ([nTokens~nTokens] ← P1.ScanReset[]).nErrors;
    ParseReset[];
    RETURN};


  ExpandStack: PROC [delta: NAT] = {
    oldSize: NAT = (IF s = NIL THEN 0 ELSE s.length);
    newSize: NAT = oldSize + delta;
    newS: P1.StateStack = zone.NEW[P1.StateSeq[newSize]];
    newL: P1.LinkStack = zone.NEW[P1.LinkSeq[newSize]];
    newV: P1.ValueStack = zone.NEW[P1.ValueSeq[newSize]];
    FOR i: NAT IN [0..oldSize) DO
      newS[i] ← s[i]; newL[i] ← l[i]; newV[i] ← v[i] ENDLOOP;
    EraseStack[];
    s ← newS;  l ← newL;  v ← newV;
    P1.AssignDescriptors[qd~q, vd~v, ld~l, pp~prodData, model~cm]};

  EraseStack: PROC = {
    IF s # NIL THEN {zone.FREE[@v]; zone.FREE[@l]; zone.FREE[@s]}};

  ExpandQueue: PROC [delta: NAT] = {
    oldSize: NAT = (IF q = NIL THEN 0 ELSE q.length);
    newSize: NAT = oldSize + delta;
    newQ: P1.ActionStack = zone.NEW[P1.ActionSeq[newSize]];
    FOR i: NAT IN [0..oldSize) DO newQ[i] ← q[i] ENDLOOP;
    EraseQueue[];
    q ← newQ;
    P1.AssignDescriptors[qd~q, vd~v, ld~l, pp~prodData, model~cm]};

  EraseQueue: PROC = {IF q # NIL THEN zone.FREE[@q]};



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

 -- parameters of error recovery

  minScanLimit: NAT = 4;
  maxScanLimit: NAT = 12;
  insertLimit: NAT = 2;
  discardLimit: NAT = 10;
  treeSize: NAT = 250;
  checkSize: NAT = maxScanLimit+insertLimit+2;

 -- tree management

  NodeIndex: TYPE = NAT [0..treeSize);
  nullIndex: NodeIndex = 0;

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

  TreeSpace: TYPE = ARRAY [0..treeSize) OF StackNode;
  tree: REF TreeSpace;
  nextNode: NAT [0..treeSize];
  maxNode: NodeIndex;
  treeLimit: NAT [0..treeSize];
  TreeFull: ERROR = CODE;


  Allocate: PROC [parent, pred: NodeIndex, terminal: TSymbol, stateNo: State]
      RETURNS [index: NodeIndex] = {
    IF (index ← nextNode) >= treeLimit THEN ERROR 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};


  hashSize: NAT = 250;	-- should depend on state count ?
  HashIndex: TYPE = [0..hashSize);
  HashSpace: TYPE = ARRAY HashIndex OF NodeIndex;
  hashTable: REF HashSpace;

  HashValue: PROC [s: State] RETURNS [HashIndex] = INLINE {
    RETURN [s MOD hashSize]};
    
  ParsingMode: TYPE = {aTree, bTree, checking};
  parseMode: ParsingMode;

  LinkHash: PROC [n: NodeIndex] = {
    htIndex: HashIndex = HashValue[tree[n].state];
    tree[n].link ← hashTable[htIndex];  hashTable[htIndex] ← n};

  DelinkHash: PROC [n: NodeIndex] = {
    htIndex: HashIndex = HashValue[tree[n].state];
    p: NodeIndex ← nullIndex;
    FOR i: NodeIndex ← hashTable[htIndex], tree[i].link UNTIL i = nullIndex DO
      IF i = n THEN GO TO delete;
      p ← i;
      REPEAT
        delete =>
	  IF p = nullIndex THEN hashTable[htIndex] ← tree[n].link
	  ELSE tree[p].link ← tree[n].link;
      ENDLOOP};
      
  ExistingConfiguration: PROC [stack: StackRep] RETURNS [NodeIndex] = {
    htIndex: HashIndex;
    aTree: BOOL;
    SELECT parseMode FROM
      $aTree => aTree ← TRUE;
      $bTree => aTree ← FALSE;
      ENDCASE => RETURN [nullIndex];
    htIndex ← HashValue[stack.extension];
    FOR i: NodeIndex ← hashTable[htIndex], tree[i].link UNTIL i = nullIndex DO
      IF (IF aTree THEN tree[i].aLeaf ELSE tree[i].bLeaf) THEN {
	s1: State ← stack.extension;
	s2: State ← tree[i].state;
	n1: NodeIndex ← stack.leaf;
	n2: NodeIndex ← tree[i].father;
	DO
	  IF s1 # s2 THEN EXIT;
	  IF n1 = n2 THEN RETURN [i];
	  s1 ← tree[n1].state;  s2 ← tree[n2].state;
	  n1 ← tree[n1].father;  n2 ← tree[n2].father;
	  ENDLOOP};
      ENDLOOP;
    RETURN [nullIndex]};

  FindNode: PROC [parent, pred: NodeIndex, stateNo: State] RETURNS [index: NodeIndex] = {
    index ← ExistingConfiguration[[leaf~parent, extension~stateNo]];
    IF index = nullIndex THEN {
      index ← Allocate[parent, pred, 0, stateNo];
      SELECT parseMode FROM
	$aTree => {tree[index].aLeaf ← TRUE; LinkHash[index]};
	$bTree => {tree[index].bLeaf ← TRUE; LinkHash[index]};
	ENDCASE => NULL};
    RETURN};

  TrimTree: PROC [newNext: NodeIndex] = {
    WHILE nextNode > newNext DO
      nextNode ← nextNode-1; DelinkHash[nextNode] ENDLOOP};
 

 -- parsing simulation

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

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


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

  ActOnStack: PROC [stack: StackRep, action: ActionEntry, nScanned: [0..1]]
      RETURNS [StackRep] = {
    currentNode, thread: NodeIndex ← stack.leaf;
    count: NAT ← nScanned;
    currentState: State;
    IF stack.extension = nullState THEN currentState ← tree[currentNode].state
    ELSE {currentState ← stack.extension; count ← count + 1};
    UNTIL action.tag = scanTag DO
      IF count > action.tag.pLength THEN {  -- can be one greater
	currentNode ← FindNode[currentNode, thread, currentState];
	count ← count - 1};
      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]};


  ParseStep: PROC [stack: StackRep, input: TSymbol] RETURNS [StackRep] = {
    currentState: State ← IF stack.extension = nullState
	THEN tree[stack.leaf].state
	ELSE stack.extension;
    scanned: BOOL ← FALSE;
    WHILE ~scanned DO
      action: ActionEntry;
      count: [0..1];
      tI: TIndex ← 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 {count ← 1; scanned ← TRUE}	-- shift or shift reduce
      ELSE count ← 0;
      stack ← ActOnStack[stack, action, count];
      currentState ← stack.extension;
      ENDLOOP;
    RETURN [stack]};


 -- text buffer management

  Insert: TYPE = ARRAY [0 .. 1+insertLimit) OF P1.Token;
  newText: REF Insert;
  insertCount: NAT;

  Buffer: TYPE = ARRAY [0 .. 1+discardLimit+(maxScanLimit+insertLimit)) OF P1.Token;
  scanBuffer: REF Buffer;
  scanBase, scanLimit: NAT;


  Advance: PROC = {scanBuffer[scanLimit] ← Input[];	scanLimit ← scanLimit+1};

  Discard: PROC = INLINE {scanBase ← scanBase+1};

  UnDiscard: PROC = INLINE {scanBase ← scanBase-1};

  RecoverInput: PROC RETURNS [token: P1.Token] = {
    IF insertCount <= insertLimit THEN {
      token ← newText[insertCount];
      IF (insertCount ← insertCount+1) > insertLimit THEN zone.FREE[@newText]}
    ELSE {
      token ← scanBuffer[scanBase];
      IF (scanBase ← scanBase+1) = scanLimit THEN {
        zone.FREE[@scanBuffer]; Input ← P1.Atom}};
    RETURN};


 -- acceptance checking

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

  RightScan: PROC [node: NodeIndex] RETURNS [stop: BOOL] = {
    savedNextNode: NodeIndex = nextNode;
    savedMode: ParsingMode = parseMode;
    savedLimit: NAT = treeLimit;
    stack: StackRep ← [leaf~node, extension~nullState];
    state: State ← tree[node].state;
    nAccepted: NAT ← 0;
    parseMode ← $checking;  treeLimit ← treeSize;
    FOR i: NAT IN [scanBase .. scanLimit) DO
      IF state = finalState THEN {
	nAccepted ← IF (scanBuffer[i].class = endMarker)
	  THEN scanLimit-scanBase
	  ELSE 0;
	EXIT};
      stack ← ParseStep[stack, scanBuffer[i].class];
      IF stack.leaf = nullIndex THEN EXIT;
      nAccepted ← nAccepted + 1;  state ← stack.extension;
      ENDLOOP;
    TrimTree[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]};


 -- strategy management

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

  RowHandle: TYPE = REF RowRecord;

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

  FreeRowList: PROC [list: RowHandle] RETURNS [RowHandle] = {
    r: RowHandle ← list;
    UNTIL r = NIL DO
      next: RowHandle = r.next;
      zone.FREE[@r]; r ← next;
      ENDLOOP;
    RETURN [NIL]};


  Position: TYPE = {after, before};
  Length: TYPE = NAT [0..insertLimit];

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


  AddLeaf: PROC [stack: StackRep, s: TSymbol, thread: NodeIndex]
      RETURNS [stop: BOOL] = {
    saveNextNode: NodeIndex = nextNode;
    stack ← ParseStep[stack, s];
    IF stack.leaf = nullIndex OR ExistingConfiguration[stack] # nullIndex THEN {
      TrimTree[saveNextNode]; stop ← FALSE} 
    ELSE {
      newLeaf: NodeIndex = Allocate[stack.leaf, thread, s, stack.extension];
      SELECT parseMode FROM
	$aTree => tree[newLeaf].aLeaf ← TRUE;
	$bTree => tree[newLeaf].bLeaf ← TRUE;
	ENDCASE => ERROR;
      LinkHash[newLeaf];
      stop ← RightScan[newLeaf]};
    RETURN};


  GrowTree: PROC [p: Position, n: Length] RETURNS [stop: BOOL] = {
    rowList: RowHandle ← NIL;
    FOR i: NodeIndex IN [levelStart[p][n-1] .. levelEnd[p][n-1]) DO
      IF tree[i].symbol # 0 OR n = 1 THEN {
	ENABLE UNWIND => {rowList ← FreeRowList[rowList]};
	stack: StackRep ← [leaf~i, extension~nullState];
	state: State ← tree[i].state;
	r: RowHandle;
	DO
	  tI: TIndex = tStart[state];
	  tLimit: NAT = tI + tLength[state];
	  r ← zone.NEW[RowRecord←[index~tI, limit~tLimit, stack~stack, next~rowList]];
	  rowList ← r;
	  IF tI = tLimit OR tSymbol[tLimit-1] # 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;
	rowList ← FreeRowList[rowList]};
      REPEAT
	found => stop ← TRUE;
	FINISHED => stop ← FALSE;
      ENDLOOP;
    rowList ← FreeRowList[rowList];  RETURN};

  CheckTree: PROC [p: Position, n: Length] RETURNS [stop: BOOL] = {
    FOR i: NodeIndex 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};


  Accept: PROC RETURNS [success: BOOL] = {
    s: TSymbol;
    discardBase: NAT = best.nPassed;
    insertCount ← 1+insertLimit;
    FOR p: NodeIndex ← best.node, tree[p].last WHILE p > rTop DO
      IF (s ← tree[p].symbol) # 0 THEN {
	insertCount ← insertCount-1;
	newText[insertCount] ← P1.Token[s, P1.TokenValue[s], inputLoc]};
      ENDLOOP;
    scanBase ← discardBase;
    IF best.nDiscards # 0 THEN {
      cm.out.Put[IO.string["Text deleted is: "L]];
      FOR j: NAT IN [1 .. best.nDiscards] DO
	TypeSym[scanBuffer[scanBase].class];  scanBase ← scanBase + 1;
	ENDLOOP};
    IF insertCount <= insertLimit THEN {
      IF scanBase # discardBase THEN cm.out.PutChar['\n];
      cm.out.Put[IO.string["Text inserted is: "L]];
      FOR j: NAT IN [insertCount .. insertLimit] DO
        TypeSym[newText[j].class]  ENDLOOP};
    IF discardBase = 1 THEN {insertCount ← insertCount-1; newText[insertCount] ← scanBuffer[0]};
    IF insertCount > insertLimit THEN zone.FREE[@newText];
    IF scanBase + best.nAccepted < scanLimit THEN
      success ← P1.ResetScanIndex[scanBuffer[scanBase+best.nAccepted].index]
    ELSE success ← TRUE;
    scanLimit ← scanBase + best.nAccepted;
    Input ← RecoverInput};

  TypeSym: PROC [sym: TSymbol] = {
    OPEN t~~tablePtr.scanTable;
    vocab: LONG STRING = LOOPHOLE[@tablePtr[t.vocabBody]];
    cm.out.PutChar[' ];
    IF sym IN [1..endMarker) THEN
      FOR i: NAT IN [tablePtr[t.vocabIndex][sym-1]..tablePtr[t.vocabIndex][sym]) DO
	cm.out.PutChar[vocab[i]] ENDLOOP
    ELSE cm.out.Put[IO.card[sym]]};

--stack node indices
  rTop: NodeIndex;


  Recover: PROC = {
    ModeMap: ARRAY Position OF ParsingMode = [$aTree, $bTree];
    stack: StackRep;

    treeLimit ← treeSize - checkSize;
    hashTable↑ ← ALL[nullIndex];
    rTop ← nullIndex;  nextNode ← maxNode ← 1;

    best.nAccepted ← 0;  best.nPassed ← 1;  best.mode ← $aTree;
    scanBuffer[0] ← lastToken;
    scanBuffer[1] ← P1.Token[inputSymbol, inputValue, inputLoc];
    scanBase ← 1;  scanLimit ← 2;
    THROUGH [1 .. maxScanLimit) DO Advance[] ENDLOOP;
    FOR i: NAT IN [0 .. top) DO
      rTop ← Allocate[rTop, rTop, 0, s[i]];
      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;

    FOR level: Length IN [1 .. Length.LAST] DO
      FOR place: Position 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
	THROUGH [1 .. level) DO
	  Discard[]; IF CheckTree[place, level] THEN GO TO found ENDLOOP;
	Discard[];
	IF place = $after THEN Advance[];
	FOR inserts: NAT IN [0 .. level] DO
	  IF CheckTree[place, inserts] THEN GO TO found ENDLOOP;
	-- undo discards at this level
	THROUGH [1..level] DO UnDiscard[] ENDLOOP;
	IF place = $before THEN Discard[];
	ENDLOOP;
      REPEAT
	found => NULL;
	FINISHED => {
	  threshold: NAT ← (minScanLimit+maxScanLimit)/2;
	  THROUGH [1..Length.LAST] DO Discard[]; Advance[] ENDLOOP;
	  UNTIL scanBase > discardLimit DO
	    IF best.nAccepted >= threshold THEN GO TO found;
	    Discard[];
	    FOR inserts: NAT IN Length DO
	      FOR place: Position 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 {best.mode ← $aTree; best.nPassed ← 1};
	    ENDLOOP};
      ENDLOOP};

  SyntaxError: PROC [abort: BOOL] RETURNS [success: BOOL] = {
    IF abort THEN {
      P1.ErrorContext["Syntax Error", inputLoc];
      cm.out.Put[IO.string["... Parse abandoned.\n"L]];
      success ← FALSE}
    ELSE {
      scanBuffer ← zone.NEW[Buffer];
      newText ← zone.NEW[Insert];
      tree ← zone.NEW[TreeSpace];
      hashTable ← zone.NEW[HashSpace];
      Recover[ ! TreeFull => {CONTINUE}];
      zone.FREE[@hashTable];
      P1.ErrorContext["Syntax Error",
	scanBuffer[IF best.mode=$bTree THEN 0 ELSE 1].index];
      IF ~(success ← best.nAccepted >= minScanLimit AND Accept[]) THEN {
	cm.out.Put[IO.string["No recovery found."L]];
	zone.FREE[@newText];  zone.FREE[@scanBuffer]};
      zone.FREE[@tree];
      cm.out.PutChar['\n]};
    cm.out.PutChar['\n];
    RETURN};

  }.