-- file PGSLALR.mesa
-- last modified by Satterthwaite, 21-Jan-80  9:55 

DIRECTORY
  PGScondefs: FROM "pgscondefs";

PGSLALR: PROGRAM
    IMPORTS PGScondefs 
    EXPORTS PGScondefs =
  BEGIN OPEN PGScondefs;
  stateinfo:Stateinfo;
  table:Table;

  linewidth:CARDINAL;
  lalrsuccess:BOOLEAN;
  entrylim:CARDINAL; -- index into table
  six:CARDINAL; -- six, the current state; slim in PGScon the next state number allocated
  hashhead:DESCRIPTOR FOR ARRAY [0..60] OF CARDINAL;

  -- variables of the lookahead set calculation
  top, rlim:CARDINAL; -- global to all incarnations of the recursive procedure context
  predstate, symbol:CARDINAL; -- local variables of context shared by all incarnations

  backchain:Backchain;
  stack:Stack;
  chainstack:Chainstack;
  bitsinfo:Bitsinfo;
  bitstring:Bitstring;
  firstbits:Firstbits;

  lalrgen:PUBLIC PROCEDURE RETURNS [BOOLEAN] =
    BEGIN i, j, k, totalshifts, totalreduces, oldentries, firstorcount:CARDINAL;
    redentries, maxredentries, defaultprod:CARDINAL;
    conflictflag, reduceflag, messageflag:BOOLEAN;
    conflicts:Table;

    printheader:PROCEDURE =
      BEGIN i, j, p:CARDINAL;
      outeol[2];
      FOR i DECREASING IN (stateinfo[six+1].nucleus..stateinfo[six].nucleus]
        DO [,j,p] _ table[i];
        IF linewidth = 0 THEN
          BEGIN outnum[six,4]; outchar[' ,1]; linewidth _ tokensize+5;
          IF p>0 THEN outchar[' ,tokensize-outtoken[rhschar[prodinfo[p].index+j-1]]];
          END;
        IF linewidth+9 > outbuflim THEN
          BEGIN outeol[1]; outchar[' ,linewidth _ tokensize+5];
          END;
        outnum[p,4]; outnum[j,3]; outchar['/,1]; outchar[' ,1];
        ENDLOOP;
      outeol[1];
      END;

    printentry:PROCEDURE [item:itemrec, symmark:CARDINAL] =
      BEGIN i:INTEGER;  p, j:CARDINAL;
      IF item.tag = 2 THEN
        BEGIN outstring["    Reduce with "L]; outnum[item.pss,5]; outeol[1];
        END
      ELSE
        BEGIN i _ item.pss; IF item.tag # 0 THEN i _ -i;
        IF symmark = 0 THEN
          BEGIN [,j,p] _ IF item.tag=0 THEN table[stateinfo[item.pss].nucleus] ELSE item;
          symmark _ rhschar[prodinfo[p].index+j-1];
          END;
        linewidth _ linewidth+tokensize+8;
        IF linewidth > outbuflim THEN
          BEGIN outeol[1]; linewidth _ tokensize+8;
          END;
        outnum[i,5]; outchar[' ,1]; outchar[' ,tokensize+2-outtoken[symmark]];
        END;
      END;

    printstate:PROCEDURE =
      BEGIN i, j, k:CARDINAL;
      linewidth _ 0; printheader[]; linewidth _ 0;
      i _ stateinfo[six].entries; WHILE i <stateinfo[six+1].entries
        DO IF table[i].tag # 3 THEN
	    BEGIN printentry[table[i],0]; i _ i+1;
	    END
           ELSE
	    BEGIN FOR j _ i+1, j+1 WHILE table[j].tag = 3 DO NULL ENDLOOP;
	    FOR k IN [i..j) DO printentry[table[j], table[k].pss] ENDLOOP;
	    i _ j+1;
	    END;
        ENDLOOP;
      END;

    lalrheader:PROCEDURE =
      BEGIN IF ~messageflag THEN
        BEGIN messageflag _ TRUE; seterrstream[]; outeol[1];
        outstring["LALR(1) Tables"L]; outeol[1];
        END;
      IF ~conflictflag THEN
        BEGIN conflictflag _ TRUE; linewidth _ 0; printheader[];
        END;
      END;

    lalrsuccess _ TRUE; orcount _ 0;
  -- make arrays with all entries zeroed
    stateinfo _ LOOPHOLE[makearray[maxstatenum+2,SIZE[stateinforec]]];
    table _ LOOPHOLE[makearray[maxtabentries+1,SIZE[itemrec]]];
    hashhead _ DESCRIPTOR[AllocateSegment[61],61];
    FOR i IN [0..60] DO hashhead[i] _ 0 ENDLOOP;
    stateinfo[0].nucleus_maxtabentries; table[maxtabentries] _ [0,1,0]; --final state
    stateinfo[1].nucleus_maxtabentries-1; table[maxtabentries-1] _ [0,0,0];--initial state
    stateinfo[2].nucleus_maxtabentries-2; slim _ 2;
    -- the sets of p,j components defining the LR(0) states are built at the end of table;
    -- the nucleus field of each state indexes the appropriate set.
    -- the entries for states 1,2,...  are built at the beginning of table
    stateinfo[1].entries _ entrylim _ totalshifts _ totalreduces _ 0;
    IF flags[printlr] THEN
      BEGIN setoutstream[".lr"L]; outeol[1]; outstring["LR(0) TABLES"];
      END;
    FOR six _ 1, six+1 WHILE six < slim
      DO processstate[]; stateinfo[six+1].entries _ entrylim;
      IF flags[printlr] THEN printstate[]; -- LR(0) tables are only a testing aid
      FOR i IN [stateinfo[six].entries..stateinfo[six+1].entries)
        DO SELECT table[i].tag FROM
	 0 => totalshifts _ totalshifts+1;
	 2 => totalreduces _ totalreduces+1;
	 ENDCASE;
        ENDLOOP
      ENDLOOP;
    IF flags[printlr] THEN outeol[1];
    closeoutstream[];
    IF ~flags[lists] AND ~flags[printlalr] THEN RETURN[FALSE];

    -- now form inverse of shift transitions for the lookahead sets caculation
    backchain _ LOOPHOLE[makearray[totalshifts+1, SIZE[chainrec]]];
    FOR six IN [0..slim) DO stateinfo[six].link _ 0 ENDLOOP;
    k _ 1;
    FOR six IN [1..slim)
      DO FOR i IN [stateinfo[six].entries..stateinfo[six+1].entries)
        DO IF table[i].tag = 0 THEN -- transition from six to table[i].pss
          BEGIN backchain[k].state _ six;
          backchain[k].link _ stateinfo[table[i].pss].link;
          stateinfo[table[i].pss].link _ k; k _ k+1;
          END;
        ENDLOOP;
      ENDLOOP;

    -- LALR(1) calculation begins here
    bitstrsize _ (eofile+wordlength-1)/wordlength;
    firstbits _ LOOPHOLE[makearray[totaltokens-eofile+1,bitstrsize]];
    firstset[]; firstorcount _ orcount;
    FOR i IN [0..60] DO hashhead[i] _ 0 ENDLOOP; -- used by find
    bitsinfo _ LOOPHOLE[makearray[maxcontexts, SIZE[contextrec]]]; rlim _ 1;
    bitstring _ LOOPHOLE[makearray[maxcontexts, bitstrsize]];
    stack _ LOOPHOLE[makearray[30,SIZE[CARDINAL]]]; top _ 0;
    chainstack _ LOOPHOLE[makearray[90,SIZE[CARDINAL]]];
    conflicts _ LOOPHOLE[makearray[totaltokens+1,SIZE[itemrec]]];
    messageflag _ FALSE;
    tentries _ ntentries _ oldentries _ 0;
    IF flags[lists] THEN openwordstream[];

    FOR six IN [1..slim)
      DO FOR i IN [1..totaltokens] DO conflicts[i] _ [0,0,0] ENDLOOP;
      i _ stateinfo[six].entries; WHILE i < stateinfo[six+1].entries
        DO -- insert scan and scan reduce entries in conflicts array
        SELECT table[i].tag FROM
          0 => BEGIN j, p:CARDINAL;
	      [,j,p] _ table[stateinfo[table[i].pss].nucleus];
	      conflicts[rhschar[prodinfo[p].index+j-1]] _ table[i]; i _ i+1;
	      tentries _ tentries+1;
	      END;
          1 => BEGIN j, p:CARDINAL;
	      [,j,p] _ table[i];
	      conflicts[rhschar[prodinfo[p].index+j-1]] _ table[i]; i _ i+1;
	      tentries _ tentries+1;
	      END;
          2 => i _ i+1;
          3 => BEGIN conflicts[table[i].pss] _ table[i+1]; i _ i+2;
	      ntentries _ ntentries+1;
	      END;
          ENDCASE;
        ENDLOOP;

      -- compute lookaheads, insert reduce entries and output as necessary
      conflictflag _ FALSE; maxredentries _ defaultprod _ 0;
      FOR i IN [stateinfo[six].entries..stateinfo[six+1].entries) WHILE table[i].tag = 2 
        DO IF (k _ find[six,[0,table[i].jf,table[i].pss]]) = rlim THEN
          BEGIN rlim _ rlim +1; context[k,1];
          END;
        k _ k*bitstrsize; -- @bitstring[k] points at the LALR(1) lookahead for this reduce
        reduceflag _ FALSE; redentries _ 0;
        FOR j IN [1..eofile]
          DO IF findbit[j,@bitstring[k]] THEN
	  BEGIN IF conflicts[j] = [0,0,0] THEN
             BEGIN conflicts[j] _ table[i]; tentries _ tentries+1;
             redentries _ redentries+1;
             END
           ELSE
	    BEGIN --we have conflicts
	    lalrheader[];
	    IF ~reduceflag THEN
	      BEGIN reduceflag _ TRUE; outstring["    REDUCE with "L];
	      outnum[table[i].pss,4]; outstring[" conflicts with "L]; outchar[' ,40];
	      outchar['*,10]; linewidth _ outbuflim;
	      END;
	    IF (linewidth _ linewidth+tokensize+7) > outbuflim THEN
	      BEGIN outeol[1]; outchar[' ,4]; linewidth _ tokensize+11;
	      END;
	    outchar[' ,tokensize-outtoken[j]];
	    IF conflicts[j].tag # 2 THEN
	      BEGIN outstring[" SCAN/ "L]; warningslogged _ TRUE;
	      END
	    ELSE
	      BEGIN outnum[conflicts[j].pss,5]; outstring["/ "L]; lalrsuccess _ FALSE;
	      IF flags[lists] THEN -- turn off binary output
	        BEGIN flags[lists] _ FALSE; closewordstream[];
	        END;
	      END;
	    END;
	  END;
          ENDLOOP;
          IF reduceflag THEN outeol[1];
          IF redentries > maxredentries THEN
            BEGIN maxredentries _ redentries; defaultprod _ table[i].pss;
            END;
        ENDLOOP;

      IF flags[printlalr] THEN lalrheader[];
      IF flags[lists] THEN
        BEGIN outword[defaultprod]; outword[tentries+ntentries-oldentries];
        oldentries _ tentries+ntentries;
        END;
      linewidth _ 0;
      FOR j IN [1..totaltokens]
        DO IF conflicts[j] # [0,0,0] THEN
          BEGIN item:itemrec _ conflicts[j];
          -- grab entries for tabgen here
          IF flags[lists] THEN
            BEGIN  outword[j];
            outword[IF item.tag=0 THEN 0 ELSE 4*item.jf+item.tag]; outword[item.pss];
            END;
          IF flags[printlalr] OR conflictflag THEN
            BEGIN IF item.tag = 2 THEN
              BEGIN signchar _ '*; item.tag _1;
              END;
            printentry[item,j]; signchar _ '-;
            END;
          END;
        ENDLOOP;
      ENDLOOP;

    seterrstream[];outeol[2]; outstring["LALR(1) Statistics"L]; outeol[1];
    outstring["States ="L]; outnum[slim-1, 4]; outeol[1];
    outstring["Terminal entries ="L]; outnum[tentries, 5]; outeol[1];
    outstring["Nonterminal entries ="L]; outnum[ntentries, 5]; outeol[1];
    outstring["First OR operation count ="L]; outnum[firstorcount, 5]; outeol[1];
    outstring["Total OR operation count ="L]; outnum[orcount, 5]; outeol[1];
    outstring["Maximum number of contexts ="L]; outnum[rlim-1, 5]; outeol[1];

    FreeSegment[BASE[conflicts]]; FreeSegment[BASE[chainstack]];
    FreeSegment[BASE[stack]]; FreeSegment[BASE[bitstring]];
    FreeSegment[BASE[bitsinfo]]; FreeSegment[BASE[firstbits]];
    FreeSegment[BASE[backchain]]; FreeSegment[BASE[hashhead]];
    FreeSegment[BASE[table]]; FreeSegment[BASE[stateinfo]];
    FreeSegment[BASE[rhschar]]; FreeSegment[BASE[tokeninfo]];
    RETURN[lalrsuccess];
    END;

  processstate:PROCEDURE =
    BEGIN k1, k2, nmark, entrymark:CARDINAL; -- indexes into table
    p, j, n:CARDINAL;
    sym, nsym:CARDINAL;
    
    -- procedures called by processstate

    sort:PROCEDURE[index:CARDINAL] =
      BEGIN k1, k2:CARDINAL; item:itemrec; noswap:BOOLEAN;

      compare:PROCEDURE RETURNS [BOOLEAN] =
        BEGIN RETURN[ table[k1+1].pss > table[k1+3].pss OR
	(table[k1+1].pss = table[k1+3].pss AND table[k1+1].jf > table[k1+3].jf)];
        END;

      FOR k2 _ entrylim-2, k2-2 WHILE k2>=index
        DO noswap _ TRUE;
        FOR k1 _ index, k1+2 WHILE k1<k2
	 DO IF (table[k1].pss > table[k1+2].pss OR
		table[k1].pss = table[k1+2].pss AND compare[])
	 THEN
	   BEGIN item _ table[k1]; table[k1] _ table[k1+2]; table[k1+2] _ item;
	   item _ table[k1+1]; table[k1+1] _ table[k1+3]; table[k1+3] _ item;
	   noswap _ FALSE;
	   END;
	 ENDLOOP;
        IF noswap THEN RETURN;
        ENDLOOP;
      END;

    expandtable:PROCEDURE =
      BEGIN i:CARDINAL; new:LongDes;
      new _ LOOPHOLE[makearray[LENGTH[table]+tabext,SIZE[itemrec]]];
      FOR i IN [0..entrylim) DO new[i] _ table[i] ENDLOOP;
      FOR i IN (stateinfo[slim].nucleus..LENGTH[table])
        DO new[i+tabext] _ table[i]
        ENDLOOP;
      FOR i IN [1..slim]
        DO stateinfo[i].nucleus _ stateinfo[i].nucleus+tabext;
        ENDLOOP;
      FreeSegment[BASE[table]]; table _ new;
      END;

    locatestate:PROCEDURE[index, n:CARDINAL] RETURNS [CARDINAL] =
      BEGIN i, j, k, r:CARDINAL;
      IF table[index+1] = [0,1,0] THEN RETURN[0]; -- final state, n=2 in this case
      r _ (63*n+LOOPHOLE[table[index+1],CARDINAL]) MOD 61;
      i _ hashhead[r];
      WHILE i # 0
        DO IF n = 2*(stateinfo[i].nucleus-stateinfo[i+1].nucleus) THEN
	 BEGIN k _ index+1;
	 FOR j DECREASING IN (stateinfo[i+1].nucleus..stateinfo[i].nucleus]
	   DO IF table[j] # table[k] THEN EXIT; k _ k+2;
	   REPEAT FINISHED => RETURN[i]
	   ENDLOOP;
	 END;
        i _ stateinfo[i].link;
        ENDLOOP;
      -- a new state
      IF hashhead[r] # 0 THEN stateinfo[slim].link _ hashhead[r]; hashhead[r] _ slim;
      IF slim+1 = LENGTH[stateinfo] THEN
        stateinfo _ LOOPHOLE[expand[stateinfo, SIZE[stateinforec], stateext]];
      IF entrylim+n/2 > stateinfo[slim].nucleus THEN expandtable[];
      -- insert new nucleus
      r _ stateinfo[slim].nucleus;
      FOR i _ index+1, i+2 WHILE i<index+n
        DO table[r] _ table[i]; r _ r-1;
        ENDLOOP;
      slim _ slim+1; stateinfo[slim].nucleus _ r;
      IF slim <= psslim+1 THEN RETURN[slim-1] ELSE
        BEGIN seterrstream[]; outeol[2];
        outstring["ERROR - Internal field will overflow - increase PSSLIM"L]; outeol[1];
        ERROR PGSfail[];
        END;
      END;

    -- end of local procedures

    k1 _ stateinfo[six].nucleus;
    IF (k1-stateinfo[six+1].nucleus)*2 > stateinfo[slim].nucleus-entrylim+1
	 THEN expandtable[];
    -- copy nucleus to entries
    FOR k1 DECREASING IN (stateinfo[six+1].nucleus..k1]
      DO table[entrylim+1] _ table[k1]; entrylim _ entrylim+2;
      ENDLOOP;

    -- compute closure
    entrymark _ entrylim;
    FOR k2 _ stateinfo[six].entries, k2+2 WHILE k2<entrylim
      DO p _ table[k2+1].pss; j _ table[k2+1].jf; table[k2] _ [0,0,0];
      IF j # prodinfo[p].count THEN --not a reduce
        BEGIN sym _ rhschar[prodinfo[p].index+j]; table[k2].pss _ sym;
        IF sym>eofile THEN -- nonterminal scan
          BEGIN t:tokenrecord _ tokeninfo[sym-eofile];
          FOR p IN [t.index..t.index+t.count)
	   DO FOR k1 _ entrymark, k1+2 WHILE k1<entrylim
	     DO IF table[k1+1] = [0,0,p] THEN EXIT
	     REPEAT FINISHED =>
	       BEGIN IF entrylim+2 > stateinfo[slim].nucleus THEN expandtable[];
	       table[entrylim+1] _ [0,0,p]; entrylim _ entrylim+2;
	       END;
	     ENDLOOP;
	   ENDLOOP;
          END;
        END;
      ENDLOOP;
    sort[stateinfo[six].entries];

    IF flags[chain] THEN  -- extend closure
      BEGIN k2 _ stateinfo[six].entries;
      WHILE k2 < entrylim AND table[k2].pss <= eofile DO k2 _ k2+2 ENDLOOP;
      IF k2 < entrylim THEN
        BEGIN entrymark _ k2; --first nonterminal entry
        WHILE k2 < entrylim
          DO p _ table[k2+1].pss;
          IF prodinfo[p].chain THEN
            BEGIN sym _ table[k2].pss; nsym _ prodinfo[p].lhs; -- now search for lhs entry
            k1 _ entrymark; WHILE nsym # table[k1].pss DO k1 _ k1+2 ENDLOOP;
            -- now overwrite chain entry with first chained entry
            table[k2+1] _ table[k1+1];
            k2 _ k2-2; -- back up k2 in case first chained entry is also a chain entry
            -- now append the other chained entries
            FOR k1 _ k1+2, k1+2 WHILE k1 < entrylim
              DO IF nsym = table[k1].pss THEN
	       BEGIN IF entrylim+2 > stateinfo[slim].nucleus THEN expandtable[];
                table[entrylim].pss _ sym; table[entrylim+1] _ table[k1+1];
                entrylim _ entrylim+2;
	       END;
              ENDLOOP;
            END;
          k2 _ k2+2;
          ENDLOOP;
        sort[entrymark];
        END;
      END;

    -- pack up reduce entries
    k1 _ k2 _ stateinfo[six].entries;
    WHILE k2 < entrylim AND table[k2].pss = 0
      DO table[k1] _ table[k2+1]; table[k1].tag _ 2; k1 _ k1+1; k2 _ k2+2;
      ENDLOOP;

    -- form new states and pack up entries
    entrymark _ k2; nmark _ 0;
    WHILE entrymark < entrylim
      DO k2 _ entrymark+2;
      WHILE k2 < entrylim AND table[k2].pss = table[entrymark].pss
        DO table[k2+1].jf _ table[k2+1].jf+1; k2 _ k2+2;
        ENDLOOP;
      table[entrymark+1].jf _ table[entrymark+1].jf+1;
      n _ k2-entrymark; -- 2*number of elements in this state
      IF n#2 OR table[entrymark+1].jf # prodinfo[table[entrymark+1].pss].count THEN
          table[entrymark+1] _ [0,1,locatestate[entrymark,n]]  -- make shift
        ELSE table[entrymark+1].tag _ 1; -- make scan reduce
      IF table[entrymark].pss > eofile THEN -- insert symbol
        BEGIN IF nmark = 0 THEN nmark _ k1;
        table[k1] _ [3,0,table[entrymark].pss]; k1 _ k1+1;
        END;
      table[k1] _ table[entrymark+1]; k1 _ k1+1; --insert shift or scan reduce
      entrymark _ k2;
      ENDLOOP;
    entrylim _ k1; -- entrylim-1 => last entry, nmark => first nonterminal entry or is 0
    END;

  firstset:PROCEDURE=
    BEGIN i, j, top, listindex:CARDINAL;
    discrim, vertices:DESCRIPTOR FOR ARRAY OF CARDINAL;
    t:tokenrecord; p:prodrecord;

    first:PROCEDURE[nonterm:CARDINAL]=
      BEGIN prix, chix, w:CARDINAL;
      discrim[nonterm] _ top _ top+1; vertices[top] _ nonterm;
      t _ tokeninfo[nonterm];
      FOR prix IN [t.index..t.index+t.count)
        DO p _ prodinfo[prix];
        FOR chix IN [p.index..p.index+p.count)
          DO w _ rhschar[chix];
          IF w <= eofile THEN
            BEGIN insertbit[w,@firstbits[nonterm*bitstrsize]]; EXIT;
            END;
          w _ w-eofile; IF discrim[w] = 0 THEN first[w];
          IF discrim[w] <= top THEN discrim[nonterm] _ MIN[discrim[nonterm], discrim[w]]
            ELSE orbits[@firstbits[vertices[discrim[w]]*bitstrsize],
			 		@firstbits[nonterm*bitstrsize]];
          IF ~tokeninfo[w].empty THEN EXIT;
          ENDLOOP;
        ENDLOOP;
      IF nonterm = vertices[discrim[nonterm]] THEN
        BEGIN listindex _ listindex-1;
        w _ vertices[top]; top _ top-1; discrim[w] _ listindex;
        WHILE w # nonterm
          DO orbits[@firstbits[w*bitstrsize], @firstbits[nonterm*bitstrsize]];
          w _ vertices[top]; top _ top-1; discrim[w] _ listindex;
          ENDLOOP;
        vertices[listindex] _ nonterm;
        END;
      END;

    discrim _ LOOPHOLE[makearray[totaltokens-eofile+1, SIZE[CARDINAL]]];
    vertices _ LOOPHOLE[makearray[totaltokens-eofile+1, SIZE[CARDINAL]]];
    listindex _ totaltokens-eofile+1; top _ 0; -- initialise stack and list of heads
    FOR i IN [1..totaltokens-eofile] DO IF discrim[i] = 0 THEN first[i] ENDLOOP;
    FOR i IN [1..totaltokens-eofile]  -- copy head bitstrings to other scc vertices
      DO IF i # vertices[discrim[i]] THEN
        orbits[@firstbits[vertices[discrim[i]]*bitstrsize], @firstbits[i*bitstrsize]];
      ENDLOOP;
    FreeSegment[BASE[discrim]]; FreeSegment[BASE[vertices]];
    IF flags[first] THEN
      BEGIN setoutstream[".first"L]; outeol[1]; outstring["FIRST SETS"L]; outeol[2];
      FOR i IN [1..totaltokens-eofile]
        DO [] _ outtoken[i+eofile]; linewidth _ outbuflim;
        FOR j  IN [1..eofile]
          DO IF findbit[j,@firstbits[i*bitstrsize]] THEN
            BEGIN IF (linewidth _ linewidth+tokensize+1) > outbuflim THEN
              BEGIN outeol[1]; outchar[' ,4]; linewidth _ tokensize+5;
              END;
            outchar[' ,tokensize+1-outtoken[j]];
            END;
          ENDLOOP;
        outeol[2];
        ENDLOOP;
      closeoutstream[];
      END;
    END;

  find:PROCEDURE[state:CARDINAL, item:itemrec] RETURNS [CARDINAL]=
    BEGIN i, r:CARDINAL;
    r _ (state + LOOPHOLE[item,CARDINAL]) MOD 61; i _ hashhead[r];
    WHILE i # 0
      DO IF state = bitsinfo[i].state AND item = bitsinfo[i].item THEN RETURN[i];
      i _ bitsinfo[i].link;
      ENDLOOP;
    -- new context
    IF rlim>=LENGTH[bitsinfo] THEN
      BEGIN bitsinfo _ LOOPHOLE[expand[bitsinfo,SIZE[contextrec],LENGTH[bitsinfo]/8]];
      bitstring _ LOOPHOLE[expand[bitstring,bitstrsize,LENGTH[bitstring]/8]];
      END;
    IF hashhead[r] # 0 THEN bitsinfo[rlim].link _ hashhead[r];
    hashhead[r] _ rlim;
    bitsinfo[rlim].state _ state; bitsinfo[rlim].item _ item;
    RETURN[rlim];
    END;

  context:PROCEDURE[index,base:CARDINAL] =
    BEGIN cj,j:CARDINAL; -- displacements relative to base into chainstack
    i:CARDINAL; -- used locally but also indexes current (q,k+1) across recursive calls
    k:CARDINAL; -- used locally but also indexes current state across recursive calls

    top _ top+1;
    IF top = LENGTH[stack] THEN stack _ LOOPHOLE[expand[stack,SIZE[CARDINAL],15]];
    bitsinfo[index].status _ top; stack[top] _ index; -- initialise for transitive closure
    j _ bitsinfo[index].item.jf; -- want the jth predecessor state
    IF base+MAX[1,j] >= LENGTH[chainstack] THEN
      chainstack _ LOOPHOLE[expand[chainstack,SIZE[CARDINAL],45]];
    cj _1; chainstack[base+cj] _ stateinfo[bitsinfo[index].state].link; --index 1st predec
    DO -- for each jth predecessor state
    IF j=0 THEN
      BEGIN predstate _ bitsinfo[index].state; -- zeroth predecessor
      j _ 1; chainstack[base+cj] _ 0;  --ensure no more zeroth predecessors
      END
    ELSE
      DO IF chainstack[base+cj] = 0 THEN
        BEGIN IF (cj _ cj-1) =0 THEN GOTO quit; -- no more jth predecessors
        END
      ELSE
        BEGIN [predstate,chainstack[base+cj]] _ backchain[chainstack[base+cj]];
        IF cj=j THEN EXIT;
        cj _ cj+1; chainstack[base+cj] _ stateinfo[predstate].link;
        END;
      ENDLOOP;
    -- locate the (q,k+1) in each jth predecessor state
    FOR i IN [stateinfo[predstate].entries..stateinfo[predstate+1].entries)
      DO IF table[i] = [3,0,prodinfo[bitsinfo[index].item.pss].lhs] THEN EXIT;
      REPEAT FINISHED => ERROR  -- nonterminal not found
      ENDLOOP;
    i _ i+1; -- index the associated item
    IF table[i].tag # 0 THEN k _ i-1 ELSE
      BEGIN k _ stateinfo[table[i].pss+1].nucleus; i _ stateinfo[table[i].pss].nucleus;
      END;
    FOR i DECREASING IN (k..i] --select each (q,k+1) s.t. X[q,k+1] = A[p]
      DO FOR k IN [table[i].jf..prodinfo[table[i].pss].count) --all v s.t. k+2<=v<= n[q]
        DO IF (symbol _ rhschar[prodinfo[table[i].pss].index+k]) <= eofile THEN
          BEGIN --X[q.v]<=eofile
          insertbit[symbol, @bitstring[index*bitstrsize] ];
          EXIT;
          END
        ELSE
          BEGIN symbol _ symbol-eofile;
          orbits[ @firstbits[symbol*bitstrsize], @bitstring[index*bitstrsize] ];
          IF ~tokeninfo[symbol].empty THEN EXIT;
          END;
        -- now the core of the transitive closure algorithm
        REPEAT FINISHED =>
          BEGIN IF (k _ find[predstate, [0,table[i].jf-1,table[i].pss]]) = rlim THEN
            BEGIN rlim _ rlim+1; context[k,base+j];
            END;
          IF bitsinfo[k].status <= top THEN
              bitsinfo[index].status _ MIN[bitsinfo[index].status,bitsinfo[k].status]
            ELSE
              BEGIN orbits[ @bitstring[k*bitstrsize], @bitstring[index*bitstrsize] ];
              END;
          END;
        ENDLOOP;
      ENDLOOP;
    REPEAT quit => NULL
    ENDLOOP;
    IF index = stack[bitsinfo[index].status] THEN --scc head
      BEGIN k _ top; i _ stack[top]; bitsinfo[i].status _ LAST[CARDINAL];
      FOR top _ top-1, top-1 WHILE i #index
        DO orbits[ @bitstring[i*bitstrsize], @bitstring[index*bitstrsize] ];
        i _ stack[top]; bitsinfo[i].status _ LAST[CARDINAL];
        ENDLOOP;
      FOR k IN [top+2..k]
        DO orbits[ @bitstring[index*bitstrsize], @bitstring[stack[k]*bitstrsize] ];
        ENDLOOP;
      END;
    END;

  END.
(1800)\g1G