-- file Parser.Mesa
-- last modified by Satterthwaite, November 1, 1982 2:45 pm

DIRECTORY
  CharIO: TYPE USING [PutChar, PutDecimal, PutString],
  CompilerUtil: TYPE USING [
    AcquireStream, AcquireTable, AcquireZone,
    ReleaseStream, ReleaseTable, ReleaseZone],
  P1: TYPE USING [
    ActionSeq, ActionStack, LinkSeq, LinkStack, StateSeq, StateStack, Token,
    Value, ValueSeq, ValueStack, NullValue,
    AssignDescriptors, Atom, ErrorContext, ProcessQueue, ResetScanIndex,
    ScanInit, ScanReset, TokenValue],
  ParseTable: TYPE 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],
  Stream: TYPE USING [Handle],
  Strings: TYPE USING [String];

Parser: PROGRAM
    IMPORTS CharIO, CompilerUtil, P1 
    EXPORTS P1 = {
  -- Mesa parser with error recovery
  OPEN ParseTable;

  ErrorLimit: NAT = 25;

  scanTag: ActionTag = [FALSE, 0];

  inputSymbol: TSymbol;

  Input: PROC RETURNS [token: P1.Token];
  inputLoc: CARDINAL;
  inputValue: P1.Value;

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

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

  q: P1.ActionStack;
  qI: CARDINAL;

  tablePtr: ParseTable.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;


-- initialization/termination

  ParseInit: PROC = {
    zone _ CompilerUtil.AcquireZone[];
    tablePtr _ CompilerUtil.AcquireTable[parse];
    P1.ScanInit[tablePtr];
    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];
    s _ NIL;  q _ NIL;  ExpandStack[500];  ExpandQueue[250];
    scanBuffer _ NIL};

 
  ParseReset: PROC = INLINE {
    EraseQueue[];  EraseStack[];  CompilerUtil.ReleaseTable[parse];
    IF scanBuffer # NIL THEN zone.FREE[@scanBuffer];
    CompilerUtil.ReleaseZone[zone]; zone _ NIL};


  InputLoc: PUBLIC PROC RETURNS [CARDINAL] = {RETURN [inputLoc]};


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

  Parse: PUBLIC PROC RETURNS [complete: BOOL, nTokens, nErrors: NAT] = {
    currentState: State;
    i, valid, m: CARDINAL;		-- stack pointers
    action: ActionEntry;

    ParseInit[];  Input _ P1.Atom;
    nErrors _ 0;  complete _ TRUE;
    i _ top _ valid _ 0;  qI _ 0;
    s[0] _ currentState _ InitialState;  lastToken.class _ nullSymbol;
    inputSymbol _ InitialSymbol;  inputValue _ P1.NullValue;  inputLoc _ 0;

    WHILE 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] _ inputValue; 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];  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]};

  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]};

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



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

 -- parameters of error recovery

  errorStream: Stream.Handle _ NIL;

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


 -- debugging

  ParserID: PUBLIC PROC RETURNS [Strings.String] = {RETURN [NIL]};

  track: BOOL = FALSE;

  DisplayNode: PROC [n: NodeIndex] = {
    IF track THEN {
      OPEN CharIO;
      PutString[errorStream, "::new node::"L];
      PutChar[errorStream, '\t]; PutDecimal[errorStream, n];
      PutChar[errorStream, '\t]; PutDecimal[errorStream, tree[n].father]; 
      PutChar[errorStream, '\t]; PutDecimal[errorStream, tree[n].last];
      PutChar[errorStream, '\t]; PutDecimal[errorStream, tree[n].state];
      PutChar[errorStream, '\t]; TypeSym[tree[n].symbol]; NewLine[]}};


 -- 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: LONG POINTER TO 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: LONG POINTER TO 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: LONG POINTER TO Insert;
  insertCount: NAT;

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


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

  Discard: PROC = {
    IF track THEN {
      CharIO.PutString[errorStream, "::discarding symbol: "L];
      TypeSym[scanBuffer[scanBase].class];  NewLine[]};
    scanBase _ scanBase+1};

  UnDiscard: PROC = {
    scanBase _ scanBase-1;
    IF track THEN {
      CharIO.PutString[errorStream, "::recovering symbol: "L];
      TypeSym[scanBuffer[scanBase].class];  NewLine[]}};

  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 = LONG POINTER TO 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];
      IF track THEN DisplayNode[newLeaf];
      stop _ RightScan[newLeaf]};
    RETURN};


  GrowTree: PROC [p: Position, n: Length] RETURNS [stop: BOOL] = {
    rowList: RowHandle _ NIL;
    IF track THEN {
      CharIO.PutString[errorStream, "::generating length: "L];
      CharIO.PutDecimal[errorStream, n];
      CharIO.PutChar[errorStream, IF p = $before THEN 'B ELSE 'A];  NewLine[]};
    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];
	  r^ _ 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] = {
    IF track THEN {
      CharIO.PutString[errorStream, "::checking length: "L];
      CharIO.PutDecimal[errorStream, n];
      CharIO.PutChar[errorStream, IF p = $before THEN 'B ELSE 'A];  NewLine[]};
    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 {
      CharIO.PutString[errorStream, "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 NewLine[];
      CharIO.PutString[errorStream, "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 CharIO, t: tablePtr.scanTable;
    vocab: Strings.String = LOOPHOLE[@tablePtr[t.vocabBody]];
    PutChar[errorStream, ' ];
    IF sym IN [1..EndMarker) THEN
      FOR i: NAT IN [tablePtr[t.vocabIndex][sym-1]..tablePtr[t.vocabIndex][sym]) DO
	PutChar[errorStream, vocab[i]] ENDLOOP
    ELSE PutDecimal[errorStream, 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]];
      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: 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] = {
    errorStream _ CompilerUtil.AcquireStream[log];
    IF abort THEN {
      P1.ErrorContext[errorStream, "Syntax Error"L, inputLoc];
      CharIO.PutString[errorStream, "... Parse abandoned."L];  NewLine[];
      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[errorStream, "Syntax Error"L,
	scanBuffer[IF best.mode=$bTree THEN 0 ELSE 1].index];
      IF ~(success _ best.nAccepted >= minScanLimit AND Accept[]) THEN {
	CharIO.PutString[errorStream, "No recovery found."L];
	zone.FREE[@newText];  zone.FREE[@scanBuffer]};
      zone.FREE[@tree];
      NewLine[]};
    NewLine[];
    CompilerUtil.ReleaseStream[log];  errorStream _ NIL;
    RETURN};

  NewLine: PROC = {CharIO.PutChar[errorStream, '\n]};

  }.

ส˜J˜ยด
—…—ZDZh