program first(shared firstend, firstok : boolean);
const test_antal=6;
var ref: reference;
    r: array(0..test_antal-1) of reference;
    p: array(0..1) of pool;
    ref_no: array(0..test_antal-1) of integer;
    is_fault: boolean := false;
    max_i: integer;
    mbx: mailbox;
    test3: boolean;
    for_i,for_j:integer;
    z : inoutzone;
    
procedure tracex(i:integer);
begin
  trace(i);
  is_fault:= true;
end;
  
procedure allocrefs(i:integer);
begin
  for j:=0 to i-1 do alloc(r(j),p(0),mbx);
  for j:=i to test_antal-1 do begin
    alloc(r(j),p(1),mbx);
    setoffset(r(j),5+j);
    setbytecount(r(j),11+j);
    settop(r(j),117+j);
  end;
end;

procedure releaserefs;
begin
  for j:=0 to test_antal-1 do release(r(j));
end;

procedure build_stack(i:integer);
var j:integer;
begin  
  for antal:=test_antal downto 1 do
  begin
    j:=i mod antal;
    for x:=0 to test_antal-1 do 
    begin
      if nil(r(x)) then else
      begin
        if j=0 then begin
          push(r(x),ref);
          ref_no(test_antal-antal):=x;
        end;
        j:=j-1;
      end;
    end;
    i:=i div antal;
  end; 
end;

function test_unchanged(var r: reference;x:integer): boolean;
begin
if bufsize(r)>0 then begin
  if offset(r)<>5+x then tracex(200);
  if bytecount(r)<>11+x then tracex(201);
  if top(r)<>117+x then tracex(202);
  if first(r)<>5+x then tracex(203);
  if next(r)<>16+x+x then tracex(204);
  if last(r)<>116+x then tracex(205);
  if is_fault then
  begin
  trace(for_j); trace(for_i); trace(x);
  for i:=0 to test_antal-1 do trace(ref_no(i));
  end;
end;
  test_unchanged:= is_fault;  
end;

function test_changed(var r: reference): boolean;
var tempoffset : integer;
begin
  if test3 then
  begin
  tempoffset := offset(r);
  if bytecount(r)<> ( 20 - tempoffset) then tracex(301);
  if top(r)<>101 then tracex(302);
  if first(r) <> tempoffset then tracex(303);
  if next(r)<>20 then tracex(304);
  if last(r)<>100 then tracex(305);    
  end
  else
  begin
  if offset(r)<>7 then tracex(300);
  if bytecount(r)<>13 then tracex(301);
  if top(r)<>101 then tracex(302);
  if first(r)<>7 then tracex(303);
  if next(r)<>20 then tracex(304);
  if last(r)<>100 then tracex(305);    
  end;
  test_changed:= is_fault;  
end;
 
function test:boolean;
var i:integer;
    c:boolean;
begin
  c:=true;
  test:=true;
  for x:=test_antal-1 downto 0 do
  begin
    if c then
    begin
      if test_changed(ref) then exit;
      pop(r(ref_no(x)),ref);
      if bufsize(r(ref_no(x)))<>0 then c:=false;
    end else
    begin
      pop(r(ref_no(x)),ref);
      if test_unchanged(r(ref_no(x)),ref_no(x)) then exit;
    end;
  end; 
  
  test:=false;  
end;
procedure exiterror;
begin
  region firstok  do firstok := false;
  region firstend do firstend := true;
end;    
begin
  if allocmempool(p(0),test_antal,0,mem_private)<>test_antal then tracex(100);
  if allocpool(p(1),test_antal,200)<>test_antal then tracex(101);
  
  max_i:=1;
  for i:=2 to test_antal do max_i:=max_i*i;
  for j:=1 to test_antal-1 do
  for i:=0 to max_i-1 do
  begin
    if (i mod 10) = 0 then printinteger(z,i);
    for_j:=j;
    for_i:=i;
    test3:=false;
    allocrefs(j);
    build_stack(i);
    setfirst(ref,7);
    setnext(ref,20);
    setlast(ref,100);
    if test then begin  exiterror; exit; end;
    releaserefs;
    allocrefs(j);
    build_stack(i);
    setnext(ref,20);
    setfirst(ref,7);
    setlast(ref,100);
    if test then begin tracex(600);  exiterror; exit; end;
    releaserefs;
    test3:=true;
    allocrefs(j);
    build_stack(i);
    setoffset(ref,7);
    setnext(ref,20);
    setlast(ref,100);
    if test then begin tracex(601);  exiterror; exit; end;
    releaserefs;
  end;
(*
  allocrefs(0);
  build_stack(0);
  setnext(ref,30);
  for i:=0 to test_antal-1 do
  begin
    pop(r(i),ref);
    if bytecount(r(i))<>30 then tracex(700+i);
  end;
*)
  region firstok  do firstok := not is_fault;
  region firstend do firstend := true;
end.