{$standard-pascal} { -- set gpc to standard pascal }

{
  set of tests to verify conformance to pascal standard ISO/IEC 7185 :1990(E)
   based on various sources, including pcvs published in PUG newsletter #16,
   the bsd pascal test suite and tests developed over time.
   A test with a number like cipjpka is a test matching section i.j.k of the Pascal Standard,
   and a is an alphabetic sequence number.
   Each test should compile without error and print a 'PASS' message when executed.
   Otherwise the test fails.
}

{ TODO: dispose memory where allocated }

program conformant(output);

type
   colour = (red, yellow, green, blue, tartan);

var
   eps : real;
   pi, erec, ln2 : real;


{calculate eps, where 1+eps is smallest nr > 1.0
 calculate pi, 1/e & ln2 to accuracy of eps}
procedure initialise;

var a,b,c : real;

{calculate exp(x) by taylor's series}
function myexp(x :  real) : real;
function f1(x1 : real; n:integer):real;
begin
   if abs(x1) < abs(x)*eps then
      f1 := x1
   else
      f1 := x1 + f1(x*x1/(n+1), n+1);
end; { f1 }
begin
   myexp := f1(1,0);
end; { myexp }

{find ln(2) using Euler's method}
function mylntwo: real;
var
   a, b, t :  real; {above, below, test values}
   lna, lnb, lnt :  real;
begin
   { choose b < 0.5 < a }
   b := erec; lnb := 1;
   a := 1; lna := 0;
   repeat
      t := sqrt(a*b);
      lnt := (lna+lnb)/2;
      if t >= 0.5 then begin
         a := t;
         lna := lnt;
      end
      else begin
         b := t;
         lnb := lnt;
      end;
      {writeln( 't is ', t:1:4, ', lnt is ', lnt:1:33 );}
   until abs(t-0.5) <= 0.5*eps;
   mylntwo := lnt;
end; { mylntwo }


{arctan(1/x) by Euler's method - use this to calculate pi}
function atan1x(x :real ):real;

function f1(x1 : real; n:integer ): real;
var t :  real;
begin
   t := 2*n*x1/((2*n+1)*(1+sqr(x)));
   if x1 < eps then begin
         {writeln;
         writeln( 'n is ', n:1, ', x1 is ', x1:1:33 );}
      f1 := t;
   end
   else
      f1 := x1 + f1( t, n+1 );
end; { f1 }

begin
   atan1x := x/(1+sqr(x)) * f1(1,1);
end; { atan1x }

begin
{
  estimate unit roundoff, from the linpack benchmark
     this code should function properly on all systems
     satisfying the following two assumptions,
        1.  the base used in representing floating point
            numbers is not a power of three.
        2.  the variable  a  is represented to the accuracy
            used in floating point variables that are stored
            in memory.
     the loop is intended to force optimising compilers to
     generate code satisfying assumption 2.
     under these assumptions, it should be true that,
            a  is not exactly equal to four-thirds,
            b  has a zero for its last bit or digit,
            c  is not exactly equal to one,
            eps  measures the separation of 1.0 from
                 the next larger real number.
}
   a := 4.0/3.0;
   repeat
      b := a - 1;
      c := b + b + b;
      eps := abs(c-1);
   until eps > 0;
   {writeln('eps is ', eps);}

   pi := 16*atan1x(5) - 4*atan1x(239);
   {writeln( 'pi is ', pi:1:33 );}

   erec := myexp(-1);
   {writeln( 'e is ', 1/erec:1:33 );}

   ln2 := mylntwo;
   {writeln( 'ln2 is ', ln2:1:33 );}

end; {initialise}


{TEST 6.1.2c}
{Check that identifiers and reserved words are correctly distinguished }
procedure c6p1p2c;
var

   andd, arrayy, beginn, casee,
   procedurex, procedurf, procedur,
   an, arra, begi, cas : char;

   constt, divv, doo, downtoo,
   functionx, functiom, functio,
   cons, di, d, downt : integer;

   elsee, endd, filee, forr, gotoo, inn, labell,
   modd, nill, nott, off, orr, packedd, iff,
   els, en, fil, fo, got, labe, mo, ni, no, o, packe, i   : boolean;

   proceduree, programm, recordd, repeatt, sett,
   thenn, too, typee, untill, varr, whilee, withh,
   progra, recor, repea, se, the,  t,  typ, unti, va, whil, wit : real;

begin
   andd := 'n';
   arrayy := 'r';
   beginn := 'e';
   casee := 'a';
   procedurex := 'O';
   procedurf := '1';

   functionx := 0;
   functiom := 1;
   constt := 3;
   divv := 4;
   doo := 5;
   downtoo := 6;

   elsee := true;
   endd := false;
   filee := false;
   forr := true;
   gotoo := true;
   labell := true;
   modd := true;
   nill := true;
   nott := true;
   off := true;
   orr := true;
   packedd := true;
   iff := true;
   inn := false;

   proceduree := 5.2;
   programm := 5.2;
   recordd := 5.2;
   repeatt := 5.2;
   sett := 5.2;
   thenn := 5.2;
   too := 5.2;
   typee := 5.2;
   untill := 5.2;
   varr := 5.2;
   whilee := 5.2;
   withh := 5.1;

   an := 'n';
   arra := 'r';
   begi := 'e';
   cas := 'a';
   procedur := 'O';

   functio := 0;
   cons := 3;
   di := 4;
   d := 5;
   downt := 6;

   els := true;
   en := false;
   fil := false;
   fo := true;
   got := true;
   labe := true;
   mo := true;
   ni := true;
   no := true;
   o := true;
   packe := true;
   i := true;

   progra := 5.2;
   recor := 5.2;
   repea := 5.2;
   se := 5.2;
   the := 5.2;
   t := 5.2;
   typ := 5.2;
   unti := 5.2;
   va := 5.2;
   whil := 5.2;
   wit := 5.1;

   writeln(' PASS ... 6.1.2c, IDENTIFIERS')
end;


{TEST 6.1.3a}
{ Verify that the compiler accepts identifiers up to 70 characters long.}
procedure c6p1p3a;
const
   nxxxxxxxxx = 10;
   nxxxxxxxxxxxxxxxxxxx = 20;
   nxxxxxxxxxxxxxxxxxxxxxxxxxxxxx = 30;
   nxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx = 40;
   nxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx = 50;
   nxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx = 60;
   nxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx = 70;
begIn
   if nxxxxxxxxx
       + nxxxxxxxxxxxxxxxxxxx
       + nxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
       + nxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
       + nxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
       + nxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
       + nxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
	<> 280 then
      writeln('FAIL ... 6.1.3a IDENTIFIER LENGTH')
   else
      writeln(' PASS ... 6.1.3a IDENTIFIER LENGTH')
end;


{TEST 6.1.3b}
{ check that upper and lower case letters are equivalent in identifiers
  and reserved words }
Procedure c6p1p3b;
VAR
   testvar : Integer;

procedure inner;
var
   TESTVAR : INTEGER;
begin
   testvar := 0;  {should set the local var}
   TESTVAR := 1;
end;

BegIn
   BEGIN
      TestVar := 1;
      tESTvAR := 2;
      inner;
      If testvar = 2 Then
	 WriteLn(' PASS ... 6.1.3b CASE')
      ELSE
	 WRITELN('FAIL ... 6.1.3b CASE')
   enD
End;



{ ------- 6 .1 .5 Numbers ------- }

{TEST 6.1.5a}
{ Test the syntax productions for numbers }
procedure c6p1p5a;
const
   { all cases are legal productions }
   a = 01;
   b = 12;
   c = 0000000000000000123;
   d = 123.0123;
   e = 123.0123E+2;
   f = 123.0123E-2;
   g = 123.0123E2;
   h = 123E+2;
   i = 0123E-2;
   j = 0123E2;
   k = 123E2;
   e1 = 123.0123e+2;
   f1 = 123.0123e-2;
   g1 = 123.0123e2;
   h1 = 123e+2;
   i1 = 0123e-00000000000000002;
   j1 = 0123e000000000000000002;
   x1 = 1e-10000;  {legal, probably truncated to zero}
   x2 = -1e-10000;

var
   pass: boolean;
begin
   { check the numbers are correct }
   pass := true;
   if a+b+c <> 136 then
      pass := false;
   if c+0.0123 <> d then
      pass := false;
   if e <> 12301.23 then
      pass := false;
   if f <> 1.230123 then
      pass := false;
   if g <> e then
      pass := false;
   if g <> h+i then
      pass := false;
   if i <> 1.23 then
      pass := false;
   if h <> j then
      pass := false;
   if j <> k then
      pass := false;
   if e <> e1 then
      pass := false;
   if f1 <> f then
      pass := false;
   if  g <> g1 then
      pass := false;
   if h <> h1 then
      pass := false;
   if i <> i1 then
      pass := false;
   if j <> j1 then
      pass := false;
   if (x1 <> 0) or (x2 <> 0) then
      writeln( 'x1 is ', x1:33, ', x2 is ', x2:33 );

   if pass then
      writeln(' PASS ... 6.1.5a NUMBER FORMAT')
   else
      writeln('FAIL ... 6.1.5a NUMBER FORMAT')
end;


{TEST 6.1.5b}
{Check that very long numbers are accepted }
procedure c6p1pSb;
const
   {100 decimal places}
   cpi  = 3.141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086
   ;
   cln2 = 6931471805599453094172321214581765680755001343602552541206800094933936219696947156058633269964186875e-100
   ;

var pass: boolean;
begin

   pass := (abs(pi - cpi) <= 2*eps) or (abs(pi-cpi) <= 1.0e-100);
   pass := pass and (abs(ln2 - cln2) <= 0.5*eps) or (abs(ln2-cln2) <= 1.0e-100);

   if pass then
      writeln(' PASS ... 6.1.5b LONG NUMBERS')
   else
      writeln('FAIL ... 6.1.5b LONG NUMBERS')
end;


{TEST 6.1.6a}
{ Verify that standard labels are permitted and may be in the closed interval 0..9999 }
procedure c6p1p6a;
label
    0,20,300,4000,9999;
begin
    write(' P');
    goto 4000;
0:
    write(' .6');
    goto 9999;
20:
    write('SS');
    goto 300;
300:
    write(' ..');
    goto 0;
4000:
    write('A');
    goto 20;
9999:
    writeln('.1.6a LABELS');
end;


{TEST 6.1.6b}
{Test that labels can be distinguished by their apparent integer value }
procedure c6p1p6b;
label
   5,6,7,008;
begin
   goto 005;
0006:
    goto 7;
5:
    goto 6;
007:
    writeln(' PASS ... 6.1.6b, LABELS');
    goto 8;
    writeln('FAIL ... 6.1.6b, LABELS');
8:
end;


{TEST 6.1.7a}
{Verify that single character constant strings are char constants }
procedure c6p1p7a;
const
    cha = 'a';
    chb = 'b';
var
   ch : char;
   pass : boolean;
begin
   pass := false;
   if (cha <> chb) and (chb = 'b') then begin
      ch := 'b';
      if ch = chb then
	 pass := true;
   end;

   if pass then
      writeln(' PASS ... 6.1.7a CHAR CONSTANTS')
   else
      writeln('FAIL ... 6.1.7a CHAR CONSTANTS')
end;


{TEST 6.1.7b}
{ Check that strings at least 80 characters long are accepted }
procedure c6p1p7b;
const
   n = 80; { str length }
type string1 = packed array [1..n] of char;
var
   alpha : string1;
   i : integer;
   pass : boolean;
begin
   alpha := 'ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZAB';
   pass := true;
   for i := 1 to n do begin
      if ord(alpha[i]) <> ord('A') + (i-1) mod 26  then begin
         writeln( 'long string test failed, alpha[', i:1, '] is ', alpha[i] );
         pass := false;
      end;
   end;
   if pass then
      writeln(' PASS ... 6.1.7b STRING LENGTH')
   else
      writeln('FAIL ... 6.1.7b STRING LENGTH')
end;


{TEST 6.1.7c}
{Test that quotes appear as char constants if they are written twice }
procedure c6p1p7c;
const
   quote = '''';
var
   qstr :  packed array[1..5] of char;
begin
   qstr := 'WON''T';
   if (qstr[4] = quote) and (qstr[5] = 'T') then
      writeln(' PASS ... 6.1.7c - QUOTE')
   else
      writeln('FAIL ... 6.1.7c - QUOTE')
end;


{TEST 6.1.8a}
{Check that a comment is considered to be a token separator }
procedure{ Is this a separator? }c6p1p8a;
var{ Or here? }i{ control variable }:{ colon }integer{ type };
begin
   for{ loop }i{ control variable }:={ assigrment }
        1{start}to{end}1{repetitions}do{write}writeln(' PASS ... 6.1.8a, COMMENT')
end;


{TEST 6.1.8b}
{ Check that an open curly bracket is allowed inside a comment }
procedure c6p1p8b;
begin
   { Is a { permitted in a comment? }
   writeln(' PASS ... 6.1.8b, COMMENT')
end;


{TEST 6.1.8c}
{ Verify that mixed comments are allowed }
procedure c6p1p8c;
var
   r : integer;
begin
{ standard comment }
(* alternative form *)
   r :=  1 + { is this a mixed comment? *) 2 + (* or is it a single comment? }
         4 + (* is the code in between } 8 + {  commented out? *)  16;
   if r = 31 then
      writeln(' PASS ... 6.1.8c MIXED COMMENTS')
   else
      writeln('FAIL ... 6.1.8c MIXED COMMENTS')
end;


{TEST 6.1.8d}
{ Verify that comments are not nested }
procedure c6p1p8d;
begin

   if (* nested { comments } not (* here *) true then
      writeln('FAIL ... 6.1.8d NESTED COMMENTS')
   else
      writeln(' PASS ... 6.1.8d NESTED COMMENTS')
end;


{TEST 6.1.8e}
{ Test various comment endings,
  Verify that if options are recognised, they correctly preserve comments  }
procedure c6p1p8e;

const missed =
(*$l+,d*)
   false; notmissed =   (*is this line missed?*)
   true;
var
   n:    integer;
begin
   n := 0;
   if missed then
      writeln('FAIL ... 6.1.8d COMMENT OPTIONS')
   else
      n := n+1;
   if not (* * )not{} true then
      writeln('FAIL ... 6.1.8d end of COMMENT missed (1)')
   else
      n := n+1;
   if not (*)not{} true then
      writeln('FAIL ... 6.1.8e end of COMMENT missed (2)')
   else
      n := n+1;
   if not (**)not{} false then
      writeln('FAIL ... 6.1.8e end of COMMENT missed (3)')
   else
      n := n+1;
   if not {}{}not{}{} false then
      writeln('FAIL ... 6.1.8e end of COMMENT missed (4)')
   else
      n := n+1;

   if n=5 then
      writeln(' PASS ... 6.1.8e COMMENT')
end; {c6p1p8d}


{TEST 6.1.8f}
{ Verify that comment start char has no effect if it is inside a string }
procedure c6p1p8f;
const
   s = '{comment';
   t = true; {comment}
begin

   if t then
      writeln(' PASS ... 6.1.8f COMMENT CHAR IN STRING')
   else
      writeln('FAIL ... 6.1.8f COMMENT CHAR IN STRING')
end;


{TEST 6.1.8g}
{ Verify that comment start char has no effect if it is  inside a string }
procedure c6p1p8g;
const
   s = '(*comment';
   t = true; {comment}
begin

   if t then
      writeln(' PASS ... 6.1.8g COMMENT CHARS IN STRING')
   else
      writeln('FAIL ... 6.1.8g COMMENT CHARS IN STRING')
end;



{ ------- 6.2 Blocks, scopes, and activations ------- }

{ ------- 6.2.1 Blocks ------- }


{TEST 6.2.1a}
{Include a sample of each declaration part in its minimal form }
procedure c6p2p1a;
label
   1;
const
   one = 1;
   c = 'q';
type
   small = 1..3;
var
   tiny : small;
procedure p(var x: small);
begin
   x := 1
end;
begin
   goto 1;
1:
   p(tiny);
   if tiny = one then begin
      writeln( ' PASS ... 6.2.1a, DECLARATIONS' );
   end
   else
      writeln('FAIL ... 6.2.1a, DECLARATIONS')
end;


{TEST 6.2.1b}
{Check that multiple repetitions are possible in the declaration parts }
procedure c6p2p1b;
label
   1,2,3;
const
   one=1;
   two=2;
   three=3;
type
   small = 1..3;
   larger = 1 .. 10;
   biggest = 1 .. 100;
var
   tiny : small;
   soso : larger;
   big : biggest;
procedure p(var x: small);
begin
   x := 1
end;
procedure q(var y: larger);
begin
   y := 2
end;
procedure r(var z: biggest);
begin
   z := 3
end;
begin
   p(tiny); goto 2;
1:
   r(big); goto 3;
2:
   q(soso); goto 1;
3:
   if (tiny=one) and (soso=two) and (big=three) then
      writeln(' PASS ... 6.2.1b, DECLARATIONS')
   else
      writeln('FAIL ... 6.2.1b, DECLARATIONS')
end;


{TEST 6.2.1f}
{ Check that an empty procedure is allowed }
procedure c6p2p1f;
begin
end;


{TEST 6.2.2b}
{Check that a user can redefine a predefined name }
procedure c6p2p2b;
var
   true : boolean;
begin
   true := false;
   if (true = false) and not true then
      writeln(' PASS ... 6.2.2b, redefine predefined name')
   else
      writeln('FAIL ... 6.2.2b, redefine predefined name')
end;


{TEST 6.2.2c}
{This procedure is similar to 6.2.2d, however a type identifier,
say T, which specifies the domain of a pointer type ^T, is
permitted to have its defining occurence anywhere in the type
definition part in which ^T occurs.
Thus in this example, (node=real)'s scope is excluded from the
type definition of check }
procedure c6p2p2c;
type
   node = real;
procedure check;
type
   p = ^node;         {should point to boolean, not real}
   node = boolean;
var
   ptr : p;
begin
   new(ptr);
   ptr^ := true;
   dispose(ptr);
   writeln(' PASS ... 6.2.2c, POINTER SCOPE')
end;
begin
   check;
end; {c6p2p2c}


{TEST 6.2.2f}
{ Verify that records have their own scope.
  Thus it is possible to redefine a field-name of a record within
  the same scope as the record }
procedure c6p2p2f;
var
   j : integer;
   x : record
	  j : integer   {redefining j}
       end;
begin
   j := 1;
   x.j := 2;
   with x do
      j := 3;
   if (j=1) and (x.j=3) then writeln(' PASS ... 6.2.2f, RECORD SCOPE')
   else writeln('FAIL ... 6.2.2f, RECORD SCOPE')
end;


{TEST 6.2.2h}
{ It is possible to assign a value to a function at an inner level }
procedure c6p2p2h;
var
   j,k: integer;
function f1 (i:integer) : integer;
function f2(i:integer):integer;
function f3(i:integer) : integer;
begin {f3}
   f3 := 1;
   f1 := i    { assigning result of outer function }
end;
begin {f2}
   f2 := f3(i)
end;
begin {f1}
   j := f2(i)
end;
begin
   k := f1(5);
   if k=5 then
      writeln(' PASS ... 6.2.2h, FUNCTION')
   else
      writeln('FAIL ... 6.2.2h, FUNCTION')
end;


{TEST 6.2.2j}
{This obscure procedure is nevertheless standard Pascal.
An inner scope hides part of a type while leaving other parts accessible }
procedure c6p2p2j;
type
   colour= (red, yellow, green, blue, tartan);
var
   c : colour;
procedure nested;
type
   colour=(purple, red, blue); { this hides red }
var
   paint : colour;
begin
   c := green;
   paint := red;
   c := pred (yellow);
   if (ord(c)<>0) or (ord(paint)<>1) then
      writeln('FAIL ... 6.2.2j, SCOPE');
end;
begin
   nested;
   if c <> red then
      writeln('FAIL ... 6.2.2j, SCOPE')
   else
      writeln(' PASS ... 6.2.2j, SCOPE')
end;


{TEST 6.2.2k }
{The occurrence of an identifier within an identifier 1ist of a pararmeter group
is its defining occurrence as a parameter identifer for the formal parameter
list in which it occurs and any corresponding procedure block or function block.
Check if the compiler detects that the return type of a function is outside this scope }
procedure c6p2p2k;
type
   ttt = integer;
var
   i : integer;

{ here, scope of parameter ttt is inside the function,
  while ttt the return type is in outer scope}
function test(ttt:  integer) : ttt;
begin
   test := 2*ttt;
end;

begin
   i :=5;
   if test(i) = 10 then
      writeln(' PASS ... 6.2.2k function return scope' )
   else
      writeln('FAIL ... 6.2.2k  function return scope' )
end; {c6p2p2k}


{TEST 6.2.2l }
{test redefinition of names in new scope levels }
procedure c6p2p2l;   {here c6p2p2l is in top level scope (level (1)}
var
   i : integer;
   testRec : record
                c6p2p2l : integer; {here c6p2p2l is in its own scope (level (2)}
             end;

{here procedure c6p2p2l is in next level scope (level 2),
and var parameter c6p2p2l is at yet a further level down (level 3) }
procedure c6p2p2l(var c6p2p2l:  integer);
begin
   c6p2p2l := 2*c6p2p2l;   {update the var parameter}
end;

begin
   with testRec do begin
      c6p2p2l := 0;         {inside the with statement, record scope wins}
      i :=5+c6p2p2l;
   end;

   c6p2p2l(i);              {call inner procedure}
   if i = 10 then
      writeln(' PASS ... 6.2.2l SCOPE' )
   else
      writeln('FAIL ... 6.2.2l SCOPE' )
end; {c6p2p2l}


{TEST 6.2.2.5a}
{The Pascal Standard permits redefinition of a user name, by a further
defining occurrence in a region (eg. procedure block) enclosed by the first
defining occurence.
This second region (and all regions enclosed by it) are excluded from
the scope of the defining occurence of the first region.
Test the scope conformance of the compiler for user names }
procedure c6p2p2p5a;
const
   range = 10;
var
   i : integer;
   pass : boolean;
procedure redefine;
const
   range = -10;
var
   i : integer;
begin
   i := range;
end;
begin
   i := 1;
   pass := false;
   redefine;
   if range=-10 then
      writeln('FAIL ... 6.2.2.5a: SCOPE ERROR-REGION')
   else
      pass := true;
   if i=-10 then
      writeln('FAIL ... 6.2.2.5a: SCOPE ERROR-I')
   else if pass then
      writeln(' PASS ... 6.2.2.5a: scope of inner regions')
end;


{TEST 6.2.2.5e}
{Similarly to 6.2.2.5a, test that labels can be redefined in an inner block }
procedure c6p2p2p5e;
label
   4,5,6;
var
   i : integer;
procedure redefine;
label
   6,7,8;
var
   j : integer;
begin
   j := 1;
   goto 6;
7:
   j := j-1;
   goto 8;
6:
   j := j+1;
   goto 7;
8:
   j := 0;
end;

begin
   goto 4;
5:
   i := i+1;
   goto 6;
4:
   i := 1;
   redefine;
   goto 5;
6:
   if i=1 then
      writeln('FAIL ... 6.2.2.5e')
   else
      writeln(' PASS ... 6.2.2.5e, labels in regions')
end;


{TEST 6.3a}
{ test all allowed combinations for a constant in a const declaration }
procedure c6p3a;
const
   ten = 10;
   minusone = -1;
   minustentoo = -ten;
   decade = ten;
   dot = '.';
   str = ' PASS ';
   on = true;
   minusc6p3 = -6.3;
   c6p3 = -minusc6p3;
begin
   writeln( str, dot, dot, dot, c6p3:4:1, 'a, CONSTANTS' );
end;


{TEST 6.4.1a}
{ test that pointer types can be declared before thay are used }
procedure c6p4p1a;
type
   ptr1 = ^polar;
   polar = record
	r,theta : real
     end;
   purelink = ^purelink;
   ptr2 = ^person;
   ptr3 = ptr2;
   person = record
      mother,father: ptr2;
      firstchild:  ptr2;
      nextsibling:  ptr3
   end;
begin
   writeln(' PASS ... 6.4.1a, POINTER TYPES')
end;


{TEST 6.4.2.2a}
{Test that the standard simple types are implemented. }
procedure c6p4p2p2a;
type
   myinteger = integer;
   myreal = real;
   myboolean = boolean;
   mychar = char;
var
   a:   myinteger;
   b:   myreal;
   c:   myboolean;
   d:   mychar;
begin
   a := 6*2+3;
   b := 3.14159*2;
   c := (a=15);
   d := 'Z';
   writeln(' PASS ... 6.4.2.2a, STANDARD SIMPLE TYPES')
end;


{TEST 6.4.2.2b}
{ Check that the values an integer may take are within the range -maxint .. +maxint }
procedure c6p4p2p2b;
type
   natural = 0.. maxint;
   whole = -maxint .. +maxint;
var
   i : natural;
   j : whole;
   k : integer;
begin
   i := maxint;
   j := -maxint;
   k := maxint;
   writeln(' PASS ... 6.4.2.2b, INTEGER TYPE')
end;


{TEST 6.4.2.2c}
{Test that type BOOLEAN has values true and false, where false < true }
procedure c6p4p2p2c;
begin
   if (false < true) and succ(false) and not pred(true) then
      writeln(' PASS ... 6.4.2.2c, BOOLEAN TYPE')
   else
      writeln('FAIL ... 6.4.2.2c, BOOLEAN TYPE')
end;


{TEST 6.4.2.2d}
{Test that the characters '0' .. '9' are ordered and contiguous }
procedure c6p4p2p2d;
var
   a,b : boolean;
begin
   a := (succ('0') = '1') and
	(succ('1') = '2') and
	(succ('2') = '3') and
	(succ('3') = '4') and
	(succ('4') = '5') and
	(succ('5') = '6') and
	(succ('6') = '7') and
	(succ('7') = '8') and
	(succ('8') = '9');
   if not a then
      writeln('FAIL a ... 6.4.2.2d');

   b := ('0' < '1') and  {technically, this is redundant}
        ('1' < '2') and
        ('2' < '3') and
        ('3' < '4') and
        ('4' < '5') and
        ('5' < '6') and
        ('6' < '7') and
        ('7' < '8') and
        ('8' < '9');
   if not b then
     writeln('FAIL b ... 6.4.2.2d, NUMBER CHARS');

   if a and b then
      writeln(' PASS ... 6.4.2.2d, NUMBER CHARS')
end;


{TEST 6.4.2.2e}
{Test that the upper-case letters A-Z are ordered
(but not necessarily contiguous) }
procedure c6p4p2p2e;
begin
   if ('A' < 'B') and
      ('B' < 'C') and
      ('C' < 'D') and
      ('D' < 'E') and
      ('E' < 'F') and
      ('F' < 'G') and
      ('G' < 'H') and
      ('H' < 'I') and
      ('I' < 'J') and
      ('J' < 'K') and
      ('K' < 'L') and
      ('L' < 'M') and
      ('M' < 'N') and
      ('N' < 'O') and
      ('O' < 'P') and
      ('P' < 'Q') and
      ('Q' < 'R') and
      ('R' < 'S') and
      ('S' < 'T') and
      ('T' < 'U') and
      ('U' < 'V') and
      ('V' < 'W') and
      ('W' < 'X') and
      ('X' < 'Y') and
      ('Y' < 'Z') then
      writeln(' PASS ... 6.4.2.2e: upper case characters are ordered')
   else
      writeln('FAIL ... 6.4.2.2e: upper case characters are unordered')
end;


{TEST 6.4.2.2f}
{Test that the lower-case letters a-z are ordered
(but not necessarily contiguous).
NOTE: remove this test for upper case only compilers }
procedure c6p4p2p2f;
begin
   if ('a' < 'b') and ('b' < 'c') and ('c' < 'd') and
      ('d' < 'e') and ('e' < 'f') and ('f' < 'g') and
      ('g' < 'h') and ('h' < 'i') and ('i' < 'j') and
      ('j' < 'k') and ('k' < 'l') and ('l' < 'm') and
      ('m' < 'n') and ('n' < 'o') and ('o' < 'p') and
      ('p' < 'q') and ('q' < 'r') and ('r' < 's') and
      ('s' < 't') and ('t' < 'u') and ('u' < 'v') and
      ('v' < 'w') and ('w' < 'x') and ('x' < 'y') and
      ('y' < 'z') then
      writeln(' PASS ... 6.4.2.2f: lower case characters are ordered')
   else
      writeln('FAIL ... 6.4.2.2f: lower case characters are unordered')
end;


{TEST 6.4.2.3a}
{ Check the syntax definitions for enumerated types }
procedure c6p4p2p3a;
type
   singularitytype = (me);
   switch =  (on,off);
   maritalstatus = (married,divorced,widowed,single);
   status = (Busy, InterruptEnable, ParityError, OutOfPaper, LineBreak);
   cardsuit = (heart,diamond,spade,club);
var
   i : singularitytype;
begin
   i := me;
   writeln(' PASS ... 6.4.2.3a, ENUMERATED TYPES')
end;


{TEST 6.4.2.3b}
{Test that enumerated type constants are ordered by the sequence in which
 they are defined, and have consecutive ordinal numbers starting at zero. }
procedure c6p4p2p3b;
type   suit = (club,spade,diamond,heart);
var
   a,b  : boolean;
begin
   a := (succ(club) = spade) and
       (succ (spade) = diamond) and
       (succ(diamond) = heart);
   b := (club < spade) and
      (spade < diamond) and
      (diamond < heart);
   if a and b and (ord(club) = 0) then
      writeln(' PASS ... 6.4.2.3b, ENUMERATED TYPES')
   else
      writeln('FAIL ... 6.4.2.3b, ENUMERATED TYPES')
end;


{TEST 6.4.2.4a}
{Test that a type may be defined as a subrange of another ordinal-type (host-type).}
procedure c6p4p2p4a;
type
   colour  = (red, yellow, green, blue, tartan);
   somecolour = red .. green;
   century = 1..100;
   twentyone = -10 .. +10;
   digits  = '0' .. '9';
   zero  = 0 .. 0;
   logical =  false .. true;
var
   pass : logical;
begin
   pass := true;
   if pass then
      writeln(' PASS ... 6.4.2.4a, SUBRANGE DECLARATIONS')
end;


{TEST 6.4.3.1c}
{Check that array, set, file and record types can be declared as PACKED.
The procedure simply tests that all these are permitted.}
procedure c6p4p3p1c;
type
   arrType =   packed array[1 .. 10] of char;
   recType =  packed record
	     bookcode : integer;
	     authorcode : integer;
	  end;
   myFile =  packed file of arrType;
   card =   (heart,diamond,spade,club);
   setType =   packed set of card;
begin
   writeln(' PASS ... 6.4.3.1c, PACKED DECLARATIONS')
end;


{TEST 6.4.3.2a}
{Test the valid productions for an array declaration from the syntax conform to
 the Pascal Standard.}
procedure c6p4p3p2a;
type
   cards = (two,three,four,five,six,seven,eight,nine,ten,jack,queen,king,ace);
   suit =  (heart,diamond,spade,club);
   hand =  array[cards] of suit;
   picturecards= array[jack .. king] of suit;
   played = array[cards] of array[heart .. diamond] of boolean;
   playedtoo = array[cards,heart .. diamond] of boolean;

begin
   writeln(' PASS ... 6.4.3.2a, ARRAY DECLARATION')
end;


{TEST 6.4.3.2b}
{verify that the abbreviated form and the full form of array declaration are
 equivalent, see also 6.5.3.2b}
procedure c6p4p3p2b;
var
   array1, array2 : array [1..10, 1..10] of real;
   array3, array4 : array [1..10] of array [1..10] of real;
   i, j: integer;

begin
   for i := 1 to 10 do for j := 1 to 10 do begin
      array1[i,j]  := 100 + 10*i + j;
      array2[i][j] := 200 + 10*i + j;
      array3[i,j]  := 300 + 10*i + j;
      array4[i][j] := 400 + 10*i + j;
   end;

   array1[1,2] := array2[2,3];
   array2[4][5] := array1[6][7];
   array3[10,9] := array4[8][7];
   array4[6,5] := array3[4][3];

   if (array1[1][2] = 223) and
      (array2[4,5] = 167) and
      (array3[10][9] = 487) and
      (array4[6][5] = 343)
   then
      writeln(' PASS ... 6.4.3.2b array index')
   else
      writeln('FAIL ... 6.4.3.2b array index');

end;


{TEST 6.4.3.2c}
{The compiler should allow an index type to be an ordinal type, viz
 BOOLEAN, CHAR, INTEGER and some user defined type names.
Test if the compiler allows these except for INTEGER,
which is tested separately,}
procedure c6p4p3p2c;
type
   digits =    0 .. 9;
   letters =   'a' .. 'z';
   colour =   (red, yellow, green, blue, tartan);
   intensity = (bright,dull);
var
   alltoo:   array[boolean] of boolean;
   numeric:  array[digits] of integer;
   alphabetic: array[letters] of integer;
   colours:  array[colour] of intensity;
   code:     array[char] of digits;
begin
   numeric[0] := 0;
   alphabetic['a'] := 3;
   colours[yellow] := bright;
   alltoo[true] := false;
   code['A'] := 0;
   writeln(' PASS ... 6.4.3.2c, INDEX TYPES')
end;


{TEST 6.4.3.2d}
{test that a string index is a subrange of integer, starting at 1}
procedure c6p4p3p2d;
type
    subr = 1..9;
    strType = packed  array[subr] of char;
var
    mystr1, mystr2: strType;
procedure p(s: strType);
begin
    write(s);
end;
begin
    mystr1 := '123456789';
    mystr2 := ' 6.4.3.2d';
    if mystr1 <> mystr2 then
        p(' PASS ...');
    writeln(mystr2, ', STRING INDEX')
end;


{------- 6.4.3.3  Record-types -------}

{TEST 6.4.3.3a}
{Test that all valid productions from the syntax for record types conform to the Pascal Standard }
procedure c6p4p3p3a;
type
   str = packed array[1 .. 25] of char;
   married = (false,true);
   shape =  (triangle,rectangle,square,circle);
   angle = 0..90;
   a = record
	  year : integer;
	  month : 1..12;
	  day : 1 .. 31
       end;
   b = record
	  name,firstname : str;
	  age : 0 .. 99;
	  case married of
	     true: (spousename : str);
	     false : ()
       end;
   c = record
	  case s : shape of
	     triangle : (side : real;
			 inclination,angle1,angle2 : angle);
	     square,rectangle : (sidel,side2: real;
				 skew,angle3: angle);
	     circle : (diameter : real)
       end;

   d = record   { cf TEST 6.4.3.3c }
       end;
   e = record
	  case married of
            true: (spousename: str);
	     false : ();
       end;
begin
   writeln(' PASS ... 6.4.3.3a, RECORD TYPES')
end; {c6p4p3p3a}


{TEST 6.4.3.3b}
{Test that the occurrence of a field identifier within
the identifier list of a record section is its defining occurence as a
field identifier for the record type in which the record section occurs.
This should allow redefinition of a field identifier in another type declaration.}
procedure c6p4p3p3b;
type
   a   = record
            realpart : real;
            imagpart : real
         end;
   realpart = (notimaginary, withbody, withsubstance);
begin
   writeln(' PASS ... 6.4.3.3b, FIELD IDENTIFIER SCOPE')
end;


{TEST 6.4.3.3c}
{Empty record are allowed by the Pascal Standard.
 This empty record serves little purpose, and for this reason
 some compilers will not allow it to be used.}
procedure c6p4p3p3c;
type
   statuskind = (defined,undefined);
   emptykind = record end;
var
   empty : emptykind;
   number: record
              case status:statuskind of
              defined: (i:  integer);
              undefined: (e : emptykind)
           end;
begin
   with number do begin
      status := defined;
      i := 7
   end;
   writeln(' PASS ... 6.4.3.3c, EMPTY RECORD')
end;


{TEST 6.4.3.3d}
{Similarly to 6.4.3.3b, a tag-field may be redefined elsewhere in the declaration part }
procedure c6p4p3p3d;
type
   which = (white,black,warlock,sand);
var
    polex : record
           case which:boolean of
           true: (realpart:real;
                  imagpart:real);
           false:(theta:real;
                  magnit: real)
       end;
begin
   polex.which := true;
   polex.realpart := 0.5;
   polex.imagpart := 0.8;
   writeln(' PASS ... 6.4.3.3d, RECORD TAG SCOPE')
end;


{TEST 6.4.3.3j}
{Test that case constants are distinct,
and are of an ordinal type which is compatible with the tag-field.
Test to see if the compiler will permit case
constants outside the tag-field subrange - it should.
A warning might be appropriate, however, as fields outside the
tag field subrange are not accessible }
procedure c6p4p3p3j;
type
   a   =   0 .. 3;
   b = record
	  case c:a of
	     0: (d:array[1..2] of boolean);
	     1: (e:array[1..3] of boolean);
	     2: (f:array[1..4] of boolean);
	     3: (g:array[1..5] of boolean);
	     4: (h:array[1..6] of boolean)   {this field cannot be accessed}
       end;
begin
   writeln(' PASS ... 6.4.3.3j, CASE CONSTANTS')
end;


{TEST 6.4.3.3m}
{ Check that nested variants are allowed with the appropriate syntax }
procedure c6p4p3p3m;
type
   a = record
	 case b:boolean of
	   true: (c:char);
	   false: (case d:boolean of
		   true: (e:char);
		   false: (f:integer))
     end;
var
   g:a;
begin
   g.b := false;
   g.d := false;
   g.f := 1;
   g.d := true;
   g.e := 'A';

   g.b := true;
   g.c := 'a';

   writeln(' PASS ... 6.4.3.3m, VARIANTS')
end;


{TEST 6.4.3.3n}
{ Check that nested variants are allowed with the appropriate syntax.
  similar to previous test, but use free/undiscriminated records }
procedure c6p4p3p3n;
type
   a=record
        case boolean of
        true: (c:char);
        false: (case boolean of
                true: (e:char);
                false: (f:integer))
     end;
var
   g:a;
begin
   g.f := 1;
   g.e := 'A';
   g.c := 'a';
   writeln(' PASS ... 6.4.3.3n, VARIANTS')
end;


{ -------- 6.4.3.4 Set-types ------- }

{TEST 6.4.3.4a}
{Test that set types as described in the Pascal Standard are permitted }
procedure c6p4p3p4a;
var
   ired, iyellow, igreen, iblue, itartan : boolean;
   pass: boolean;
   i,j: integer;
   s: array[1..32] of set of (red, yellow, green, blue, tartan); {all possible combinations}
begin
   pass := true;

   {cardinality test - all sets must be distinct}
   i := 0;
   for ired := false to true do begin
      for iyellow := false to true do begin
         for iblue := false to true do begin
            for igreen := false to true do begin
               for itartan := false to true do begin
                  i := i+1;
                  s[i] := [];
                  if ired then s[i] := [red];
                  if iyellow then s[i] := s[i] + [yellow];
                  if iblue then s[i] := s[i] + [blue];
                  if igreen then s[i] := s[i] + [green];
                  if itartan then s[i] := s[i] + [tartan];
               end;
            end;
         end;
      end;
   end;

   for i := i downto 1 do begin
      for j := i downto 1 do begin
         if (s[i] = s[j]) <> (i = j) then begin
            pass := false;
         end;
      end;
   end;

   if pass then
      writeln(' PASS ... 6.4.3.4a - set types')
   else
      writeln('FAIL ... 6.4.3.4a -  set types')
end;


{ ------- 6.4.3.5 File-types ----- }

{TEST 6.4.3.5a}
{A file-type is a sequence of components which are all one type.
 All cases in this procedure should pass }
procedure c6p4p3p5a;
type
   i      = integer;
   ptrtoi =   ^i;
   a = array [1..10] of integer;
   r = record
	  a : integer;
	  b : boolean
       end;
   s = set of (red,blue,green,purple);
var
   file1 :   file of char;
   file2 :   file of real;
   file3 :   file of r;
   file4 :   file of s;
   file5 :   file of ptrtoi;
   file6 :   file of a;
begin
   writeln(' PASS ... 6.4.3.5a, FILE TYPE')
end;


{TEST 6.4.3.5b}
{Test that files of type TEXT are permitted and that the type adheres
to the structure laid down in the Standard }
procedure c6p4p3p5b;
var
   f : text;
   n : integer;
procedure fail;
begin
   writeln('FAIL ... 6.4.3.5b, text files (', n:1, ')' )
end;
begin
   rewrite(f);
   writeln(f);         { no characters,  but a linemarker }
   writeln( f, 'ABC'); { characters and linemarker }
   reset(f);
   n := 1;
   if eoln(f) then get(f)
   else fail;
   n := 2;
   if f^='A' then get(f)
   else fail;
   n := 3;
   if f^='B' then get(f)
   else fail;
   n := 4;
   if f^='C' then get( f)
   else fail;
   n := 5;
   if eoln(f) and (f^=' ') then get(f)
   else fail;
   n := 6;
   if eof(f) then
      writeln(' PASS ... 6.4.3.5b, TEXT')
   else
      fail
end;


{TEST 6.4.3.5c}
{ All text files require a closing linemarker.
  Test if an end of line marker is inserted at the end of the line,
  if not explicitly done in the program }
procedure c6p4p3p5c;
var
   f : text;
begin
   rewrite(f);
   write(f,'A');
   reset(f);  { should insert eoln }
   get(f);
   if eoln(f) then writeln(' PASS ... 6.4.3.5c, INSERT CLOSING EOLN')
   else writeln('FAIL ... 6.4.3.5c, INSERT CLOSING EOLN')
end;


{TEST 6.4.3.5d}
{ variant records could overwrite each other and destroy state information
 contained in file variables.
 check that file-types in variant records are handled correctly }
procedure c6p4p3p5d;
type
   atyp = array [1..10] of integer;
   ctyp = (red,blue,green,purple);
   rtyp = record
          a : atyp;
          f : file of integer;
          case b : boolean of
          true:  (f1: file of atyp);
          false: (f2: file of ctyp);
       end;
var
   myRec : rtyp;
   c : ctyp;
   a : atyp;
   i1, i2 : integer;
   pass: boolean;
begin
   with myRec do begin
      rewrite(f);
      write(f, 32, 64);
      reset(f);
      if not eof(f) then
         read(f, i1, i2);
      pass := (i1 = 32) and (i2 = 64);

      b := true;
      rewrite(f1);
      for i1 := 1 to 10 do
         a[i1] := 10-i1;
      write(f1, a);
      reset(f1);
      for i1 := 1 to 10 do
         a[i1] := -1;
      read(f1, a);
      for i1 := 1 to 10 do
         pass := pass and (a[i1] = 10-i1);

      b := false;
      rewrite(f2);
      write(f2, red, green, blue);
      reset(f2);
      read(f2, c);
      pass := pass and (c = red);
      read(f2, c);
      pass := pass and (c = green);
      read(f2, c);
      pass := pass and (c = blue);

      b := true;
      rewrite(f1);
      for i1 := 1 to 10 do
         a[i1] := 20-i1;
      write(f1, a);
      reset(f1);
      for i1 := 1 to 10 do
         a[i1] := -1;
      read(f1, a);
      for i1 := 1 to 10 do
         pass := pass and (a[i1] = 20-i1);
   end;
   if pass then
      writeln(' PASS ... 6.4.3.5d, file in variant')
   else
      writeln('FAIL ... 6.4.3.5d, file in variant')
end;


{TEST 6.4.3.5e}
{Test if an end-of-line marker is inserted at the end of the line on the
predefined file output, if not explicitly done in the program
(i.e. is the buffer flushed).  See also test 6.4.3.5c }
procedure c6p4p3p5e;
begin
   { NOTE: this must be the last output of the program }
   write(  ' PASS ... 6.4.3.5e, tests completed,');
   write(' providing eoln inserted here');
end;


{ ------- 6.4.4 Pointer-types ------- }

{TEST 6.4.4a}
{ Test that pointer types as described in the Pascal Standard are permitted }
procedure c6p4p4a;
type
   set2 =   set of 1 .. 2;
   arrType =  packed array[1 .. 4] of char;
   recType =   record
      a : integer;
      b : boolean;
      p : ^pureptr;
      pr: ^recType;       {useless, but legal}
   end;
   ptrset2   = ^set2;
   pureptr   = ^pureptr;  {useless, but legal}
var
   ptr1:   ^integer;
   ptr2:   ^real;
   ptr3:   ^boolean;
   ptr4:   ^set2;
   ptr5:   ^arrType;
   ptr6:   ^recType;
   ptr7:   pureptr;
   ptr8:   ptrset2;
   ptr9:   ^pureptr;
begin
   new(ptr1);
   new(ptr2);
   new(ptr3);
   new(ptr4);
   new(ptr5);
   new(ptr6);
   new(ptr7);
   new(ptr8);
   new(ptr9);

   {test pointers}
   ptr1^ := 10;
   ptr2^ := ptr1^;
   ptr3^ := ptr2^ + 1 = 11;
   ptr4^ := [1];
   ptr8^ := ptr4^;
   with ptr6^ do begin
      b := ptr3^ and (ptr8^ = [1]);
      a := ptr1^;
   end;
   ptr9^ := ptr7;
   ptr7^ := ptr9^;
   ptr3^ := (ptr9^ = ptr7) and (ptr9^^ = ptr9^);

   if ptr3^ and ptr6^.b then ptr5^ := 'PASS' else ptr5^ := 'FAIL';
   writeln(' ', ptr5^, ' ... 6.4.4a, pointer types');

   dispose(ptr1);
   dispose(ptr2);
   dispose(ptr3);
   dispose(ptr4);
   dispose(ptr5);
   dispose(ptr6);
   dispose(ptr7);
   dispose(ptr8);
   dispose(ptr9);
end;


{ ------- 6.4.5 Compatible types ------- }

{TEST 6.4.5a}
{Test that types designated at two or more different places in
the procedure text are identical if the same type identifier is used at these places, or
if different identifiers are used which have been defined to be equivalent to each other. }
procedure c6p4p5a;
type
   t1 = array[1 .. 5] of boolean;
   t2 = t1;
   t3 = t2;
var
   a : t1;
   b : t2;
   c : t3;
procedure identical(var a: t1; var b: t2; var c: t3);
begin
   a[1] := true;
   b[1] := false;
   c[1] := true
end;
begin
   a[1] := true;
   b[1] := false;
   c[1] := false;
   identical (a,b,c);
   identical(c,a,b);
   identical(b,c,a);
   writeln(' PASS ... 6.4.5a, TYPE EQUIVALENCE')
end;


{TEST 6.4.5f}
{Two types are compatible if they are identical or if one is a
subrange of the other, or if both are subranges of the same type.
Test with only subranges of the same type having some overlap.}
procedure c6p4p5f;
type
   colour = (red, yellow, green, blue, tartan);
   colourtoo= colour;
var
   col1:   colour;
   col2:   colourtoo;
   subcol1:  red .. green;
   subcol2 : yellow .. blue;
begin
   col1 := red;
   col2 := red;
   if col1 = col2 then write(' PA');
   subcol1 := red;
   if col1 = subcol1 then write('S');
   subcol1 := yellow;
   subcol2 := yellow;
   if subcol1 = subcol2 then write('S');
   writeln(' ... 6.4.5f, type compatibility')
end;


{TEST 6.4.5g}
{ Test that two subranges of the same type with
no overlap are considered as compatible by the compiler }
procedure c6p4p5g;
type
   colour = (red, yellow, green, blue, tartan);
var
   col1 : red .. yellow;
   col2 : green .. tartan;
begin
   col1 := yellow;
   col2 := green;
   if col1 < col2 then writeln(' PASS ... 6.4.5g, SUBRANGES')
   else writeln('FAIL ... 6.4.5g, SUBRANGES')
end;


{TEST 6.4.5h}
{Test that string types with the same number of components are compatible.}
procedure c6p4p5h;
var
   string1 : packed array[1 .. 4] of char;
   string2 : packed array[1 .. 4] of char;
begin
   string1 := 'ABCD';
   string2 := 'EFGH';
   if 'ABC' = 'ABC' then
      if string1 <> string2 then begin
         string2 := 'ABCD';
         if string1 = string2 then
            writeln(' PASS ... 6.4.5h STRING COMPARE')
         else
            writeln('FAIL ... 6.4.5h STRING EQUALITY')
      end
      else
         writeln('FAIL ... 6.4.5h STRING INEQUALITY')
end;


{TEST 6.4.5i}
{ check that base types of sets are compatible as defined by the Pascal Standard.}
procedure c6p4p5i;
type
   colour = (red, yellow, green, blue, tartan);

var
   set1 : set of red .. green;
   set2 : set of green .. tartan;
begin
   set1 := [green];
   set2 := [green];
   if set1=set2 then
      writeln(' PASS ... 6.4.5i, SET COMPATIBILITY')
   else
      writeln('FAIL ... 6.4.5i, SET COMPATIBILITY')
end;


{TEST 6.4.5l}
{If two types are declared equivalent, they inherit all properties
 in common, including operators and special attributes.
 This is checked by an analogue of type boolean }
procedure c6p4p5l;
const
   on=true;
   off=false;
type
   logical=boolean;
var
   test:   integer;
   b1,b2: boolean;
   l1,l2:logical;
begin
   test := 0;
   b1 := true;
   b2 := off;
   l1 := true;
   l2 := off;
   if l2 then test := test+1;
   l2 := b2;
   if b1=b2 then test := test+1;
   b2 := l2;
   if b2 or l2 then test := test+1;
   if test=0 then
      writeln(' PASS ... 6.4.5l, TYPES')
   else
      writeln('FAIL ... 6.4.5l, TYPES')
end;


{ ------- 6.4.6 Assignment-compatibility ------- }

{TEST 6.4.6a}
{Test that all assignment compatible types as described by
the Pascal Standard are permitted by this compiler.
Test only those uses in assignment statements }
procedure c6p4p6a;
type
   colour =  (red, yellow, green, blue, tartan);

   recType = record
	       a: integer;
               b: boolean;
               p1,p2 : ^colour
	    end;
var
   i:  integer;
   j:  0..99;
   x:  real;
   col1:   colour;
   col2:   yellow .. green;
   col3:   set of colour;
   col4:   set of red .. yellow;
   testArray1: array[1..6] of integer;
   testArray2,testArray3: array[ 1 .. 4] of integer;
   record1:   recType;
   record2:   recType;
begin
   i := 2;
   x := i;
   j := 33;
   x := j;
   col1 := yellow;
   col2 := col1;
   col3 := [yellow];
   col4 := col3;
   testArray2[1] := 0;
   testArray1[6] := testArray2[1];
   testArray3 := testArray2;
   record1.a := 2;
   record1.b := true;
   record2 := record1;

   new(record2.p2);
   new(record2.p1);
   record2.p2^ := green;
   record1.p1 := record2.p2;
   record2.p1^ := record1.p1^;
   if record1.p1^ <> green then
      writeln( 'FAIL ... 6.4.6a, ASSIGNMENT COMPATIBLE TYPES, test value is ', ord(record1.p1^):1 );
   if record2.p1^ <> green then
      writeln( 'FAIL ... 6.4.6a, ASSIGNMENT COMPATIBLE TYPES is ', ord(record2.p1^):1 );
   dispose(record1.p1);
   dispose(record2.p1);

   writeln(' PASS ... 6.4.6a, ASSIGNMENT COMPATIBLE TYPES')
end;


{TEST 6.4.6b}
{This test is similar to 6.4.6a, except that it tests the use
of assigrment compatibility in actual and formal parameters }
procedure c6p4p6b;
type
   colour = (red, yellow, green, blue, tartan);
   subcol1 = green.. tartan;
   subcol2 = set of colour;
   subcol3 = set of yellow ..tartan;
var
   a   : integer;
   b   : real;
   colour1:   colour;
   colour2:   yellow ..tartan;
   colour3 : set of colour;
   colour4 : set of green.. tartan;
procedure compat(i : integer; j : real;
		 col1 : colour; col2 : subcol1;
		 col3 : subcol2; col4 : subcol3);
begin
end;
begin
   compat(2,2.4,green,green,[yellow],[yellow]);
   a := 2;
   b := 3.1;
   colour1 := yellow;
   colour2 := tartan;
   colour3 := [green];
   colour4 := [green];
   compat(a,b,colour1,colour2,colour3,colour4);
   compat(a,a,colour2,colour2,colour4,colour4);
   writeln(' PASS ... 6.4.6b, ASSIGNMENT COMPATIBLE PARAMETERS')
end;


{TEST 6.4.6c}
{Test a part of 6.5.2.1, that states that an index expression is assigment
compatible with the index type specified in the definition of the array type.}
procedure c6p4p6c;
type
   colour = (red, yellow, green, blue, tartan);
   intensity = (bright,dull);
var
   array1 : array[blue .. tartan] of boolean;
   array2 : array[colour] of intensity;
   array3 : array[1 .. 99] of integer;
   colour1 : red .. blue;
   i   : integer;
begin
   array1[blue] := true;
   colour1 := blue;
   array1[colour1] := false;
   array2[colour1] := bright;
   array3[1] := 0;
   i := 2;
   array3[i*3+2] := 1;
   writeln(' PASS ... 6.4.6c, INDEX TYPE COMPATIBILITY')
end;


{ ------- 6.5 Declarations and denotations of variables -------}

{ ------- 6.5.1 Variable-declarations ------- }

{TEST 6.5.1a}
{Check legal type and var declarations }
procedure c6p5p1a;

const limit = 50;

type
   { from section 6.4.7 of the Pascal Standard }
   natural       = 0..maxint;
   count         = integer;
   range         = integer;
   colour        = (red, yellow, green, blue);
   sex           = (male, female);
   year          = 1900 .. 1999;
   shape         = (triangle, rectangle, circle);
   line          = array [1 ..80] of char;
   textfile      = file of char;
   angle         = real;
   polar         = record
                      r : real;
                      theta : angle
                   end;

   indextype     = 1..limit;
   vector        = array [indextype] of real;

   person        = ^persondetails;
   persondetails = record
                      name, firstname : line;
                      age  : natural;
                      married  : Boolean ;
                      father, child, sibling  : person;
                      case s : sex of
                      male : (enlisted, bearded : Boolean);
                      female : (mother, programmer : Boolean)
                   end;

   tape          = file of persondetails;
   FileOfInteger = file of integer;


var
   { from section 6.5.1 of the Pascal Standard }
   {note: looks like this is unrecognised }
   {$no-unused-variable }  { gpc: these vars are unused, suppress the warning }
   x,y,z,max : real;
   i,j       : integer;
   k         : 0 .. 9;
   p,q,r     : boolean;
   operator  : (plus,minus,times);
   a         : array[0 .. 63] of real;
   c         : colour;
   f         : file of char;
   hue1,hue2 : set of colour;
   p1,p2     : person;
   m,m1,m2   : array[1..10, 1..10] of real;
   coord     : polar;
   pooltape  : array[1 .. 4] of tape;
   date      : record
                  month : 1 .. 12;
                  year  : integer
               end;

   {$unused-variable }
begin
   writeln(' PASS ... 6.5.1a TYPE & VAR DECLARATIONS')
end;


{ -------- 6.5.3 Component-variables ------- }

{ ------- 6.5.3.2 Indexed-variables ------- }

{TEST 6.5.3.2b}
{ Check that the two ways of indexing a multi-dimensional array are equivalent.}
procedure c6p5p3p2b;
var
   a:array[1 .. 4,1 .. 4] of integer;
   b:array[1 .. 4] of
	array[1..4] of integer;
   p:packed array [1 .. 4,1 .. 4] of char;
   q:packed array[1 .. 4] of
	       packed array [1 .. 4] of char;
   i,j:integer;
   pass : boolean;
begin
   pass := true;
   for i := 1 to 4 do
      for j := 1 to 4 do begin
	 a[i][j] := 10*i+j;
	 b[i,j] := 100*i+j;
	 case j of
	    1: begin
		  p[i][j] := 'B';
		  q[i][j] := 'P';
	       end;
	    2: begin
		  p[i,j] := 'L';
		  q[i,j] := 'I';
	       end;
	    3: begin
		  p[i,j] := 'U';
		  q[i,j] := 'N';
	       end;
	    4: begin
		  p[i,j] := 'E';
		  q[i,j] := 'K';
	       end;
	 end;
      end;
   for i := 1 to 4 do
      for j := 1 to 4 do begin
	 if (a[i] [j] <> a[i,j]) or (a[i][j] <> 10*i + j) then
	    pass := false;
         if (b[i] [j] <> b[i,j]) or (b[i][j] <> 100*i + j) then
	    pass := false;
	 if (p[i] [j] <> p[i,j]) then
	    pass := false;
	 if q[i] [j] <> q[i,j] then
            pass := false;
         if (p[i] <> 'BLUE') or (q[i] <> 'PINK') then
            pass := false;
      end;
   if pass then
      writeln(' PASS ... 6.5.3.2b, INDEXING')
   else
      writeln(' FAIL ... 6.5.3.2b, INDEXING')
end;


{ ------- 6.5.3.3 Field-designators ------- }

{ ------- 6.5.5 Buffer-variables ------- }

{TEST 6.5.5a}
{Test that the existance of a file variable f with
components of type T implies the existence of a buffer variable of type T.
Only the one component of a file variable determined by the
current file position is directly accessible.
The procedure tests that file buffers may be referenced in this implementation.}
procedure c6p5p5a;
type
   recType = record
               arr : array[1 .. 21] of char;
               a : integer;
               b : real
            end;
var
   myFile: file of recType;
   pass: boolean;
begin
   pass := true;
   rewrite(myFile);
   myFile^.arr[1] := '0';
   myFile^.arr[2] := 'K';
   myFile^.a := 10;
   myFile^.b := 2.375;
   put(myFile);
   with myFile^ do begin
      arr[1] := 'O';
      arr[2] := 'K';
      a := 4;
      b := 3.5
   end;
   put(myFile);
   reset(myFile);
   if myFile^.arr[1] <> '0' then pass := false;
   if myFile^.arr[2] <> 'K' then pass := false;
   if myFile^.a <> 10 then pass := false;
   if myFile^.b <> 2.375 then pass := false;
   get(myFile);
   with myFile^ do begin
      if arr[1] <> 'O' then pass := false;
      if arr[2] <> 'K' then pass := false;
      if a <> 4 then pass := false;
      if b <> 3.5 then pass := false
   end;
   if pass then
      writeln(' PASS ... 6.5.5a, file buffer variable')
   else
      writeln('FAIL  ... 6.5.5a, file buffer variable')
end;


{TEST 6.5.5b}
{Test that a file buffer variable is correctly passed as a var parameter.}
procedure c6p5p5b;
var
   f: file of integer;
   t: text;
   i: integer;
   c: char;
   pass: boolean;
procedure p13( var a:integer );
begin
   pass := a=13;
end;
procedure peoln( var c:char );
begin
   pass := c=' ';
end;
begin
   rewrite(f);
   f^ := 13;
   put(f);
   reset(f);
   {with lazy i/o, f^ is empty immediately after reset.
    check that f^ is correctly initialised when its address
    is evaluated as it is passed as a var parameter}
   p13(f^);

   rewrite(t);
   writeln(t, 'xyz');
   reset(t);
   read(t,c); read(t,c);  read(t,c);
   peoln(t^);
   if pass then
      writeln(' PASS ... 6.5.5b buffer variable')
   else
      writeln('FAIL ... 6.5.5b buffer variable')
end;


{------- 6.6 Procedure and function declarations -------}

{------- 6.6.1 Procedure-declarations -------}

{TEST 6.6.1a}
{Test the syntax for procedures as defined by the Pascal Standard.}
procedure c6p6p1a;
var
   a : integer;
   b : real;
procedure withparameters(g: integer; h: real);
var
   c : integer;
   d : real;
begin
   c := g;
   d := h
end;
procedure parameterless;
begin
   write(' PASS')
end;
begin
   a := 1;
   b := 2;
   withparameters(a,b);
   parameterless;
   writeln(' ... 6.6.1a, procedure parameters')
end;


{TEST 6.6.1b}
{Test the implementation of FORWARD declaration, recursive activation,
and multilevel referencing of a var parameter in procedures }
procedure c6p6p1b;
var
   c : integer;
procedure one(var a: integer);    forward;
procedure two (var b: integer);
begin
   b := b+1;
   one (b)
end;
procedure one;
begin
   a := a+1;
   if a = 1 then two(a)
end;
begin
   c := 0;
   one(c);
   if c= 3 then
      writeln(' PASS ... 6.6.1b, FORWARD')
end;


{TEST 6.6.2a}
{ Test the syntax for functions as defined by the Pascal Standard.}
procedure c6p6p2a;
var
   a, twopisquared : real;
   b : integer;
function power(x : real; y: integer) :real; {y>=0}
var
   w,z : real;
   i : 0 .. maxint;
begin
   W := X;
   z := 1;
   i := y;
   while i > 0 do begin
      { z*(w tothepower i)=x tothepower y }
      if odd(i) then z := z*w;
      i := i div 2;
      w := sqr(w)
   end;
   { z=x tothepower y }
   power := z
end;
function twopi : real;
begin
   twopi := 2*pi;
end;
begin
   a := twopi;
   b := 2;
   twopisquared := power (a,b);
   if (twopisquared > 39) and (twopisquared < 40) then
       writeln(' PASS ... 6.6.2a, FUNCTIONS')
   else
      writeln('FAILED ... 6.6.2a, FUNCTIONS')
end;


{TEST 6.6.2b}
{ Check that forward declaration and recursion in functions is permitted.}
procedure c6p6p2b;
var
   c : integer;
function one(a: integer): integer;  forward;
function two(b: integer): integer;
var
   x : integer;
begin
   x := b+1;
   x := one(x);
   two := x
end;
function one;
var
   y : integer;
begin
   y := a+1;
   if y=1 then y := two(y);
   one := y
end;
begin
   c := 0;
   c := one(c);
   if c = 3 then
      writeln(' PASS ... 6.6.2b, FORWARD')
end;


{TEST 6.6.2c}
{ Check that the simple types and pointer types are permitted as the result type of a function }
procedure c6p6p2c;
type
   subrange = 0 .. 3;
   enumerated = (red,yellow,green);
   rectype = record
		a : integer
	     end;
   ptrtype = ^rectype;
var
   a: real;
   b: integer;
   c: boolean;
   d: subrange;
   e: enumerated;
   f: char;
   g: ptrtype;
function one : real;
begin
   one := 2.63
end;
function two: integer;
begin
   two := 2
end;
function three : boolean;
begin
   three := false
end;
function four : subrange;
begin
   four := 2
end;
function five : enumerated;
begin
   five := yellow
end;
function six : char;
begin
   six := '6'
end;
function seven : ptrtype;
begin
   seven := nil
end;
begin
   a := one;
   b := two;
   c := three;
   d := four;
   e := five;
   f := six;
   g := seven;
   writeln(' PASS ... 6.6.2c, FUNCTION RESULT TYPE')
end;


{TEST 6.6.2d}
{ Check that the result of a function is the value of the
  most recent assignment to its result variable }
procedure c6p6p2d;
function f: integer;
begin
    f := 3;
    f := 4;
end;
begin
    if f = 4 then
        writeln(' PASS ... 6.6.2d, FUNCTION RESULT')
    else
       writeln('FAIL ... 6.6.2d, FUNCTION RESULT')
end;


{TEST 6.6.2e}
{verify that when a function is terminated with a goto,
 there is no error if the function result is undefined}
procedure c6p6p2e;
label 1;
var b : boolean;
function f: char;
begin
    if b then goto 1; {==> f is undefined, legally}
    f := ' ';
end;

begin
    b := true;
    write(f);   {result of f is undefined, but unused}
1:
    b := false;
    writeln( f, 'PASS ... 6.6.2e: undefined function result');
end;


{TEST 6.6.2g}
{Check that functions allow side effects (ie. altering their environment).
 Though side effects are generally discouraged, they are part of
 standard Pascal and do have genuine uses }
procedure c6p6p2g;
type
   ptrtochar = ^char;
var
   c1,c2,c3,dummy:char;
   p1,p2:ptrtochar;
function testa(ptr:ptrtochar):char;
{sneakiest, uses pointers}
var
   pp:ptrtochar;
begin
   pp := ptr;
   pp^ := 'P';
   testa := '1'
end;
procedure assign;
{used by testb}
begin
   c1 := 'A'
end;
function testb:char;
{sneaky, calls a procedure}
begin
   assign;
   testb := '2'
end;
function testc:char;
{blatantly changes the environment via write}
begin
   write(' ',p1^,c1,c2,c3,p2^);
   testc := '6'
end;
function testd:ptrtochar;
{blatantly sneaky:
 modify the environment via new and then pass it out}
var
   pp:ptrtochar;
begin
   new(pp);
   pp^ := '.';
   testd := pp
end;
function teste:char;
{the most used side effect :globa1 access}
begin
   c2 := 'S';
   teste := '3'
end;
function testf(var c:char) :char;
{straightforward}
begin
   c := 'S';
   testf := '4'
end;
begin {c6p6p2g}
   new(p1);
   p1^ := 'F'; c1 := 'A'; c2 := 'I'; c3 := 'L';
   p2 := nil;
   {which defines all variables}
   dummy := testa(p1);
   dummy := testb;
   dummy := teste;
   dummy := testf(c3);
   p2 := testd;
   dummy := testc;
   dispose(p1);
   dispose(p2);
   writeln(' .. 6.6.2g, SIDE EFFECTS')
end;


{TEST 6.6.3.1a,}
{Test that parameters as described by the Pascal Standard are permitted by the
compiler, especially long identifier 1ists. A parameter list with 30 elements is
thought long enough to test most applications using procedure/function parameter lists.
This test occurs elsewhere in the suite, but is included here for consistency }
procedure c6p6p3p1a;
type
   colour = (red, yellow, green, blue, tartan);
   subrange  =  red .. blue;
   recType =  record
		a : integer
	     end;
   ptrtype  = ^recType;
var
   a,b,c,d,e,f,g,h,i,j,
   k,l,m,n,o,p,q,r,s,t:	   integer;
   colone : subrange;
   coltwo : colour;
   colthree : colour;
   u,v,w,x : real;
   y,z : boolean;
   ptr: ptrtype;
   pass : boolean;
procedure assign(var a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,
		  l1,m1,n1,o1,p1,q1,r1,s1,t1 : integer;
		  var colourone : subrange;
		  var colourtwo,colourthree : colour;
		  var u1,v1,w1,x1 : real;
		  var y1,z1 : boolean;
		  var ptr : ptrtype);
begin
   {assign values here}
   a1 := 100; b1 := 101; c1 := 102; d1 := 103; e1 := 104; f1 := 105; g1 := 106;
   h1 := 0; i1 := 0; j1 := 0; k1 := 0; l1 := 0; m1 := 0; n1 := 0;
   o1 := 0; p1 := 0; q1 := 0; r1 := 0; s1 := 0; t1 := 5;
   colone := yellow;
   coltwo := tartan;
   colthree := red;
   u1 := 0; v1 := 0; w1 := 0; x1 := 0;
   y1 := true;
   z1 := false;
   new(ptr);
   ptr^.a := 42;
end;
procedure check( a1,b1,c1,d1,e1, f1, g1,h1, i1, j1, k1,
                   l1, m1, n1, o1, p1, q1, r1, s1, t1 : integer;
                   colourone : subrange;
                   colourtwo,colourthree : colour;
                   u1,v1,w1,x1 : real;
                   y1,z1 : boolean;
                   ptr : ptrtype);
begin
      {check values }
   pass := (a1=100) and (b1=101) and (c1=102) and (d1=103) and (e1=104) and
           (f1=105) and (g1=106) and (h1=0) and (i1=0) and (j1=0) and (k1=0)
                  and (l1=0) and (m1=0) and (n1=0) and (o1=0) and (p1=0)
                  and (q1=0) and (r1=0) and (s1=0) and (t1=5)
                  and (colone=yellow) and (coltwo=tartan) and (colthree=red)
                  and (u1=0) and (v1=0) and (w1=0) and (x1=0)
                  and y1 and not z1 and (ptr^.a = 42);

   if a1<>100 then writeln( 'a1 failed' );
   if b1<>101 then writeln( 'b1 failed' );
   if c1<>102 then writeln( 'c1 failed' );
   if d1<>103 then writeln( 'd1 failed' );
   if e1<>104 then writeln( 'e1 failed' );
   if f1<>105 then writeln( 'f1 failed' );
   if g1<>106 then writeln( 'g1 failed' );
   if h1<>0 then writeln( 'h1 failed' );
   if i1<>0 then writeln( 'i1 failed' );
   if j1<>0 then writeln( 'j1 failed' );
   if k1<>0 then writeln( 'k1 failed' );
   if l1<>0 then writeln( 'l1 failed' );
   if m1<>0 then writeln( 'm1 failed' );
   if n1<>0 then writeln( 'n1 failed' );
   if o1<>0 then writeln( 'o1 failed' );
   if p1<>0 then writeln( 'p1 failed' );
   if q1<>0 then writeln( 'q1 failed' );
   if r1<>0 then writeln( 'r1 failed' );
   if s1<>0 then writeln( 's1 failed' );
   if t1<>5 then writeln( 't1 failed' );
   if colone<>yellow then writeln( 'colone failed' );
   if coltwo<>tartan then writeln( 'coltwo failed' );
   if colthree<>red then writeln( 'colthree failed' );
   if u1<>0 then writeln( 'u1 failed' );
   if v1<>0 then writeln( 'v1 failed' );
   if w1<>0 then writeln( 'w1 failed' );
   if x1<>0 then writeln( 'x1 failed' );
   if not y1 then writeln( 'y1 failed' );
   if z1 then writeln( 'z1 failed' );
   if ptr^.a<>42 then writeln( 'ptr failed' )

end;
begin
   assign(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,
	   colone,coltwo,colthree,u,v,w,x,y,z,ptr);
   check(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,
	   colone,coltwo,colthree,u,v,w,x,y,z,ptr);
   dispose(ptr);
   if pass then
      writeln(' PASS ... 6.6.3.1a LONG PARAMETER LIST')
   else
      writeln('FAIL ... 6.6.3.1a LONG PARAMETER LIST')
end;


{TEST 6.6.3.1b}
{ This procedure also tests var parameters,
  here set, record and array parameters are tested }
procedure c6p6p3p1b;
type
   setType =   set of 0 .. 20;
   recType =   record
      a : integer
   end;
   arrType =  array[boolean] of boolean;
var
   setone, settwo,setthree,setfour,setfive,setsix:   setType;
   recone,rectwo,recthree,recfour,recfive : recType;
   testArrayone,testArraytwo,testArraythree,testArrayfour : arrType;
procedure assign(var set1, set2, set3, set4, set5, set6 : setType;
		  var rec1, rec2, rec3, rec4, rec5 : recType;
		  var testArray1, testArray2, testArray3, testArray4 : arrType);
begin
   set1 := [1];
   set2 := [2];
   set3 := [3];
   set4 := [4];
   set5 := [5];
   set6 := [6];
   rec1.a := 1;
   rec2.a := 2;
   rec3.a := 3;
   rec4.a := 4;
   rec5.a := 5;
   testArray1[true] := false;
   testArray2[true] := false;
   testArray3[true] := false;
   testArray4[true] := false;
end;
procedure check( set1, set2, set3, set4, set5, set6 : setType;
		  rec1, rec2, rec3, rec4, rec5 : recType;
		  testArray1, testArray2, testArray3, testArray4 : arrType);
begin

   if (set1 = [1]) and (set2 = [2]) and (set3 = [3]) and (set4 = [4]) and ( set5 = [5]) and ( set6 = [6])
	 and (rec1.a = 1) and (rec2.a = 2) and (rec3.a = 3) and (rec4.a = 4) and (rec5.a = 5)
	 and (not testArray1[true]) and (not testArray2[true]) and (not testArray3[true]) and (not testArray4[true])
   then
      writeln( ' PASS ... 6.6.3.1b, AGGREGATE PARAMS')
   else
      writeln( 'FAIL ... 6.6.3.1b, AGGREGATE PARAMS');
end;
begin
   assign(setone,settwo,setthree,setfour,setfive,setsix,
          recone,rectwo,recthree,recfour,recfive,
          testArrayone,testArraytwo,testArraythree,testArrayfour);
   check(setone,settwo,setthree,setfour,setfive,setsix,
         recone,rectwo,recthree,recfour,recfive,
         testArrayone,testArraytwo,testArraythree,testArrayfour);
end;


{TEST 6.6.3.1c}
{Test that files may be passed to procedures as var parameters }
procedure c6p6p3p1c;
var
   f: text;
procedure test(var afile: text);
begin
   rewrite(afile);
   writeln(afile,'THIS FILE WAS A PARAMETER');
   writeln(' PASS ... 6.6.3.1c file var parameter')
end;
begin
   test (f)
end;


{TEST 6.6.3.1e}
{When a procedure (or function) with a parameter list is included in the
formal parameter list of another procedure (or function), the identifiers
in the parameter list of the procedure parameter have defining
occurences for that list and the corresponding block for the procedure
only, and not for the block of the procedure to which it is passed.}
procedure c6p6p3p1e;
var
   i : integer;
procedure alsoconforms(x : integer);
begin
   writeln(' PASS ... 6.6.3.1e, FUNCTION PARAMETER NAMES')
end;
procedure conforms(procedure alsoconforms(x: integer));
var x : boolean;
begin
   x := true;
   alsoconforms(1)
end;
begin {c6p6p3p1e}
   i := 2;
   conforms(alsoconforms)
end; {c6p6p3p1e}


{TEST 6.6.3.2a}
{Test that the actual parameters to a procedure/function are assignment compatible
with the type of the formal parameter.   See also 6.4.6b }
procedure c6p6p3p2a;
type
   colour = (red, yellow, green, blue, tartan);
   subcol1 = green.. tartan;
   subcol2 = set of colour;
   subcol3 = set of yellow ..tartan;
var
   a   : integer;
   b   : real;
   colour1:   colour;
   colour2:   yellow ..tartan;
   colour3 : set of colour;
   colour4 : set of green.. tartan;
procedure compat(i : integer; j : real;
                 col1 : colour; col2 : subcol1;
                 col3 : subcol2; col4 : subcol3);
begin
end;
begin
   compat(2,2.4,green,green,[yellow],[yellow]);
   a := 2;
   b := 3.1;
   colour1 := yellow;
   colour2 := tartan;
   colour3 := [green];
   colour4 := [green];
   compat(a,b,colour1,colour2,colour3,colour4);
   compat(a,a,colour2,colour2,colour4,colour4);
   writeln(' PASS ... 6.6.3.2a, ASSIGNMENT COMPATIBLE PARAMETERS')
end;


{TEST 6.6.3.2e}
{Test that dynamic memory with a file component is allowed as an actual value
 parameter, since no new copy of the file variable is created.}
procedure c6p6p3p2e;
type
   prec = ^myRecord;
   myRecord = record
               f: text;
               a : char
            end;
var
   p : prec;

procedure pv(var r: myRecord); { OK }
begin
   write( r.a:1 );
end;
procedure pok(r: prec);     { file type inside value parameter pointer allowed }
begin
   write( r^.a:1 );
end;
begin
   new(p);
   p^.a := ' ';
   pv(p^);   { OK: file type inside actual var parameter is allowed }
   p^.a := 'P';
   pok(p);
   dispose(p);
   writeln('ASS ... 6.6.3.2e VALUE PARAMETER POINTS TO A FILE')
end; {c6p6p3p2e}


{TEST 6.6.3.3a}
{Test that the actual parameters to a procedure/function are identical to the type of the formal parameters.
See also test 6.4.5a }
procedure c6p6p3p3a;
type
   t1 = array[1 .. 5] of boolean;
   t2 = t1;
   t3 = t2;
var
   a : t1;
   b : t2;
   c : t3;
procedure identical(var a: t1; var b: t2; var c: t3);
begin
   a[1] := true;
   b[1] := false;
   c[1] := true
end;
begin
   a[1] := true;
   b[1] := false;
   c[1] := false;
   identical (a,b,c);
   identical(c,a,b);
   identical(b,c,a);
   writeln(' PASS ... 6.6.3.3a, TYPE EQUIVALENCE')
end;


{TEST 6.6.3.3b}
{Test that any operation on a formal parameter is performed immediately on the actual parameter }
procedure c6p6p3p3b;
var
   direct : integer;
   pass : boolean;
procedure indirection(var indirect: integer; var result: boolean);

begin
   indirect := indirect + 1;
   pass := indirect = direct;
end;

begin
   direct := 1;
   pass := false;
   indirection(direct,pass);
   if pass then
      writeln(' PASS ... 6.6.3.3b, VAR PARAMETERS')
   else
      writeln('FAIL ... 6.6.3.3b, VAR PARAMETERS')
end;


{TEST 6.6.3.3c}
{If the variable passed as a parameter involves the indexing
 of an array, or the dereferencing of a pointer, then these
 actions are executed before the activation of the block }
procedure c6p6p3p3c;
type
   pr     =  ^recType;
   recType = record
               a    : integer;
               link : pr;
               back : pr
            end;
var
   testArray: array[1 .. 2] of integer;
   i:   integer;
   temptr,ptr : pr;

procedure call(arrayVal : integer; ptrderef:   integer);
begin
   i := i+1;
   ptr := ptr^.link;
   if (testArray[i-1] <> arrayVal) or
         (ptr^.back^.a <> ptrderef) then
      writeln('FAIL ... 6.6.3.3c, PARAMETER VALUES')
   else
      writeln(' PASS ... 6.6.3.3c, PARAMETER VALUES')
end;

begin {c6p6p3p3c}
   testArray[1] := 101;
   testArray[2] := 201;
   i := 1;
   new(ptr);
   ptr^.a := 1001;
   new(temptr);
   temptr^.a := 2001;
   ptr^.link := temptr;
   temptr^.back := ptr;
   call(testArray[i], ptr^.a);
   dispose(temptr^.back);
   dispose(temptr);
end; {c6p6p3p3c}


{TEST 6.6.3.4a}
{Test that procedures may be passed to other procedures and functions as
 parameters.}
procedure c6p6p3p4a;
var
   i : integer;
procedure a(procedure b);
begin
   write(' PASS');
   b
end;
procedure c;
begin
   write(' .')
end;
function d(procedure b) : integer;
begin
   b;
   d := 2
end;
begin
   a(c);
   i := d(c);
   if i=2 then
      writeln('.6.6.3.4a PROCEDURE PARAMS')
end; {c6p6p3p4a}


{TEST 6.6.3.4b}
{ Test that the environment of procedure parameters conforms to the Pascal
  Standard }
procedure c6p6p3p4b;
var
   globalone, globaltwo : integer;
procedure p( procedure f(procedure ff; procedure gg); procedure g);
var
   localtop : integer;
procedure r;
begin { r }
   if globalone=1 then begin
      if (globaltwo<>2) or (localtop<>1) then
	 writeln('FAIL1 ... 6.6.3.4b')
   end
   else if globalone=2 then begin
      if (globaltwo<>2) or (localtop<>2) then
	 writeln('FAIL2 ... 6.6.3.4b')
      else
	 writeln(' PASS ... 6.6.3.4b PROCEDURE ENVIRONMENT')
   end
   else
      writeln('FAIL3 ... 6.6.3.4b');
   globalone := globalone+1;
end; { r }
begin { p }
   globaltwo := globaltwo+1;
   localtop := globaltwo;
   if globaltwo=1 then
      p(f,r)
   else
      f(g,r)
end; { p }
procedure q(procedure f; procedure g);
begin
   f;
   g;
end; { q }
procedure sayfail;
begin
   writeln('FAIL4 ... 6.6.3.4b')
end;
begin
   globalone := 1;
   globaltwo := 0;
   p(q,sayfail)
end; {c6p6p3p4b}


{TEST 6.6.3.4c}
{ Test that a procedure parameter is called with the correct environment
  ( see also c6p6p3p4b ) }
procedure c6p6p3p4c;

const maxLevel = 5;
type
   levelCount = 0..maxlevel;
var
   levCount : levelCount;
   testLevel : levelCount;
   pass, check: boolean;

function test( function f: levelCount ): levelCount;
begin
   test := f;
end;

{ call procedure p0 recursively to create several environment levels
  make function getLevel a parameter at exactly one of these levels,
  otherwise just keep passing the parameter down to the next level
  at the end of recursion, test that getlevel has correct environment level
}
procedure p0( function fa0: levelCount );
var
   thisLevel : 0..maxlevel;

function getLevel: levelCount;
begin
   { writeln( '>level count is ', levCount:1, ', this level is ', thisLevel:1 ); }
   getLevel := thisLevel;
end;
begin { p0 }
   levCount := levCount+1;
   thisLevel := levCount;
   if thisLevel >= maxLevel then begin
      check := true;
      if testLevel = thislevel then begin
	 if test( getLevel ) <> testLevel then
            pass := false;
         if test(fa0) <> 0 then
            pass := false
      end
      else if test(fa0) <> testLevel then
	 pass := false
   end
   else if thisLevel = testLevel then
      p0( getLevel )
   else
      p0( fa0 )      { pass fa0 to p0 at next level }
end; {p0}

function outer: levelCount;
begin
   { writeln( '>level count is ', levCount:1, ', this level is 0' ); }
   outer := 0;
end;

begin
   pass := true;
   check := false;
   for testLevel := 0 to maxLevel do begin
      levCount := 0;
      p0( outer );
   end;
   if pass and check then
      writeln(' PASS ... 6.6.3.4c PROCEDURE ENVIRONMENT')
   else
      writeln('FAIL ... 6.6.3.4c PROCEDURE ENVIRONMENT')
end; { c6p6p3p4c }


{TEST 6.6.3.4d}
{ stress test for procedure parameters (fay test) }
procedure c6p6p3p4d;
type
   integer = -32767..32767;
   node = 0..4500;
var Debug: boolean;

procedure EachUSCC( { of relation R }
      { Pass in:
        an iterator to generate the nodes to be searched,
        the relation on the nodes,
        a procedure to do information propagation when V R W is discovered,
        a procedure to take each SCC found, and
        a procedure to yield each node in the graph.
        We require that the nodes be of a scalar type so that
        an array may be indexed by them.
        Also passed in is the upper bound of the node type }
      procedure EachUnode(procedure P(T:node)); { Yields each node in graph }
      procedure EachUnodeUtoUsearch(procedure SearchU(V:node));
      procedure R(V:node; procedure DoUsuccessor(W:node));
      procedure Propagate(V,W:node); { called when V R W is discovered }
      procedure TakeUSCC(Root:node; procedure Each(procedure P(T:node)));
      LastUnode: integer
      );

type
   A = array[node] of integer; { range 0..Infinity (below) }
var
   N: ^A;  SP: integer;
   Stack: array[node {1..LastUnode}] of node;
   Infinity: integer; { LastUnode+1 }

procedure P(T:node);
begin
   N^[T] := 0;
end;

procedure Search(V:node);
var
   I,T:integer;
procedure DoUsuccessor(W:node);
begin
   Search(W);
   if N^[W] < N^[V] then
      N^[V] := N^[W];
   Propagate(V,W);
end;

      { EachUmember is yielded by EachUSCC when an SCC has been found }
procedure EachUmember(procedure P(TU:node));
var
   I:integer;
begin { yield each member of current SCC }
   for I := SP downto T do
      P( Stack[I] );
end;

procedure YieldUSCC;
begin
   if Debug then
      writeln('YieldUSCC passes ',V,' to TakeUSCC');
   TakeUSCC( V, EachUmember );
end;

begin { Search }
   if N^[V] = 0 then begin { stack the node }
      if Debug then writeln('stacking ',V);
      SP := SP+1;
      Stack[SP] := V;  N^[V] := SP;
      if Debug then writeln('Doing successors of ',V);
      R(V,DoUsuccessor);
      if Debug then writeln('Now checking if ',V,' is an SCC root');
      if V = Stack[N^[V]] then begin { V is root of an SCC }
         T := N^[V];
         if Debug then writeln(V,' is an SCC root; SP=',SP,' T=',T);
         for I := SP downto T do N^[Stack[I]] := Infinity;
         if SP <> T then begin
            if Debug then writeln('Yield SCC should pass ',V,' out to TakeUSCC');
            YieldUSCC;
         end;
         SP := T-1;
      end;
   end;
end; { Search }

begin { EachUSCC }
   Infinity := LastUnode+1;
   new(N); EachUnode(P);
   SP := 0;
   EachUnodeUtoUsearch(Search);
   dispose(N);
end; { EachUSCC }

procedure Outer; { this is needed to reproduce bug in Berkeley Pascal compiler }
procedure q;
procedure EachUnodeUtoUsearch(procedure Search(T:node));
begin
   Search(1);
end;
procedure EachUnode(procedure P(T:node));
begin
   P(1);
   P(2);
end;
procedure R(V:node; procedure P(W:node));
begin
         { Defines graph with edges 1->2 and 2->1 }
         { Thus, the graph contains one SCC:  [1,2] }
   case V of
   1: P(2);
   2: P(1);
   end;
end;
procedure Propagate(V,W:node);
begin
end;
procedure TakeUSCC(Root:node; procedure Each(procedure P(T:node)));
type
   index = 0..10;
var
   k: index;
   res: array[index] of node;
procedure P(T:node);
begin
   res[k] := T;
   k := k+1;
   write(T:2);
end;

procedure P1(T:node);
begin
   res[k] := T;
   k := k+1;
end;

begin { TakeUSCC }
   k := 0;
   if Debug then begin
      writeln('TakeUSCC receives V=', Root, ' from YieldUSCC');
      write('The SCC''s constituents are:');
      Each(P);
      writeln;
   end
   else
      Each(P1);
   if (Root = 1) and (k=2) and (res[0] = 2) and (res[1] = 1) then
      writeln( ' PASS ... 6.6.3.4d PROCEDURE PARAMS' )
   else
      writeln( 'FAIL ... 6.6.3.4d PROCEDURE PARAMS;',
               'Root is ', Root, ', k is ', k, ', res[0] is ', res[0], ', res[1] is ', res[1] );
end; { TakeUSCC }

begin { q }
   EachUSCC( EachUnode, EachUnodeUtoUsearch, R, Propagate, TakeUSCC, 2);
end; { q }

procedure Doit;
begin
   q;
end;

begin { Outer }
   Doit;
end; { Outer }

begin { test }
   Debug := false;
   Outer;
end; { c6p6p3p4d }


{------- 6.6.3.5 Functional parameters -------}

{TEST 6.6.3.5a}
{ test that functions may be passed to procedures and functions as parameters }
procedure c6p6p3p5a;
var
   c : char;
function f1(function af: char): char;
begin
   f1 := af
end;
procedure p1(function af: char);
begin
   write(' ', af, 'ASS')
end;
function func : char;
begin
   func := 'P'
end;
begin
   c := f1(func);
   if c<>'P' then
      write('FAIL')
   else
      p1(func);
   writeln(' ... 6.6.3.5a, function parameters')
end;


{TEST 6.6.3.5b}
{ test that function parameters may be passed to procedures and functions as
  parameters }
procedure c6p6p3p5b;
var
   c : char;
function f1(function af: char): char;
procedure p1(function af: char);
begin
   write(' ', af, 'ASS')
end;
begin {f1}
   p1(af);
   f1 := 'A';
end;
function func : char;
begin
   func := 'P'
end;
begin
   c := f1(func);
   if c<>'A' then
      write('FAIL');
   writeln(' ... 6.6.3.5b, function parameters')
end;


{ ------- 6.6.4 Required procedures and functions ------- }

{TEST 6.6.4.1a}
{Test that predefined standard procedures may be redefined with no conflict.}
procedure c6p6p4p1a;
var
   i : integer;
procedure write(var a : integer);
begin
   a := a+2
end;
procedure get(var a: integer);
begin
   a := a*2
end;
begin
   i := 0;
   write(i);
   get(i);
   if i=4 then
      writeln(' PASS ... 6.6.4.1a, redefine standard procedure')
   else
      writeln('FAIL ... 6.6.4.1a, redefine standard procedure')
end;


{ ------- 6.6.5 Required procedures ------- }

{ ------- 6.6.5.2 File handling procedures ------- }

{TEST 6.6.5.2c}
{ Test if true is assigned to eof if the file f is empty when reset }
procedure c6p6p5p2c;
var
   f : text;
begin
   rewrite(f);  {file exists and is empty}
   reset (f);
   if eof(f) then
      writeln(' PASS ... 6.6.5.2c, EOF on empty file')
   else
      writeln('FAIL ... 6.6.5.2c, EOF on empty file')
end;


{TEST 6.6.5.2d}
{Test that the first element of a file f is assigned to the
 buffer variable f^ when the procedure reset is used with the file f }
procedure c6p6p5p2d;
var
   f : text;
begin
   rewrite(f);
   writeln(f,'ABC');
   writeln(f,'DEF');
   reset (f);
   if f^='A' then
      writeln(' PASS ... 6.6.5.2d, FILE BUFFER VARIABLE')
   else
      writeln('FAIL ... 6.6.5.2d, FILE BUFFER VARIABLE')
end;


{TEST 6.6.5.2e}
{ Check that a rewrite on the file f sets eof(f) to true }
procedure c6p6p5p2e;
var
   f1   : text;
   f2   : file of real;
   pass : boolean;
begin
   pass := true;
   rewrite(f1);
   if not eof(f1) then begin
      pass := false;
      writeln('FAIL ... 6.6.5.2e, EOF AFTER REWRITE on TEXT FILE')
   end;
   rewrite(f2);
   if not eof(f2) then begin
      pass := false;
      writeln('FAIL ... 6.6.5.2e, EOF AFTER REWRITE on BINARY FILE')
   end;

   if pass then
      writeln(' PASS ... 6.6.5.2e, EOF AFTER REWRITE')
end;


{TEST 6.6.5.2h}
{Check if reading a component of a packed variable is allowed }
procedure c6p6p5p2h;
type
   percent = 0..100;
var
   f : file of percent;
   pr : packed record
                  a: 1..6;
                  b: percent;
                  k: integer;
               end;
begin
   rewrite(f);
   write(f, 50, 0, 100);
   reset(f);
   if not eof(f) then
      read(f, pr.b);
   if pr.b = 50 then
      writeln(' PASS ... 6.6.5.2h, READ PACKED VAR')
   else
      writeln('FAIL ... 6.6.5.2h, READ PACKED VAR')
end;


{TEST 6.6.5.2i}
{Check if reading a component of a packed variable is allowed.
 similar to test 6.6.5.2h, but this time read from a text file }
procedure c6p6p5p2i;
type
   percent = 0..100;
var
   f : text;
   pr : packed record
                  a: 1..6;
                  b: percent;
                  x: real;
               end;
   c: char;
begin
   rewrite(f);
   write(f, 2:4, 50:4, 100.0:7:1);
   reset(f);
   with pr do begin
      read(f, a, b, x);
      if (a = 2) and (b = 50) and (x=100) then
         writeln(' PASS ... 6.6.5.2i, READ PACKED VAR')
      else
         writeln('FAIL ... 6.6.5.2i, READ PACKED VAR, a is ', a:1, ', b is ', b:1, ', x is ', x:1:1 )
   end;
end;


{TEST 6.6.5.2k}
{Check that a write statement with many variables evaluates the file variable exactly once }
procedure c6p6p5p2k;
var
   f : array[1..5] of file of integer;
   i : integer;
   i1, i2, i3, i4: integer;

function side: integer;
begin
   i := i+1;
   side := i;
end;

begin
   for i1 := 1 to 5 do
      rewrite(f[i1]);
   i := 1;
   write(f[i], side, side, side, side);
   if i <> 5 then
      writeln( 'test 6.6.5.2k internal error' );
   reset (f[1]);
   i1 := 0; i2 := 0; i3 := 0; i4 := 0;
   if not eof( f[1] ) then read(f[1], i1 );
   if not eof( f[1] ) then read(f[1], i2 );
   if not eof( f[1] ) then read(f[1], i3 );
   if not eof( f[1] ) then read(f[1], i4 );
   if (i1=2) and (i2=3) and (i3=4) and (i4=5) then
      writeln(' PASS ... 6.6.5.2k, write file variable')
   else
      writeln('FAIL ... 6.6.5.2k, write file variable');
end;


{TEST 6.6.5.2l}
{Check that a read statement with many variables evaluates the file variable exactly once.
 (this test assumes 6.6.5.2k passes) }
procedure c6p6p5p2l;
const n = 5;
var
   f : array[1..n] of file of integer;
   i : integer;
begin
   for i := 2 to n do begin
      rewrite(f[i]);
      write( f[i], n, n, n);
      reset( f[i] );
   end;
   i := 1;
   rewrite( f[i] );
   write(f[i], 4, 3, 2);
   reset (f[i]);
   read(f[i], i, i, i );
   if i = 2 then
      writeln(' PASS ... 6.6.5.2l, READ file variable')
   else
      writeln('FAIL ... 6.6.5.2l, READ file variable, i is ', i:1);
end;


{ ------- 6.6.5.3 Dynamic allocation procedures ------- }

{TEST 6.6.5.3a}
{Check that both forms of the procedure new and dispose have been implemented }
procedure c6p6p5p3a;

type
   two = (a,b);
   recone = record
	       i : integer;
	       j : boolean
	    end;
   rectwo = record
	       c : integer;
	       case tagfield : two of
		  a: (m: integer);
		  b: (n: boolean)
	    end;
   recthree = record
		 c : integer;
		 case tagfield : two of
		    a : (case tagfeeld : two of
			 a : (o : real);
			 b : (p : char));
		    b: (q: integer)
	      end;

var
   ptrone: ^recone;
   ptrtwo: ^rectwo;
   ptrthree: ^recthree;
   pass: boolean;
begin
   new(ptrone);
   new(ptrtwo,a);
   ptrtwo^.tagfield := a;
   ptrtwo^.m := 42;
   pass := ptrtwo^.m = 42;
   new(ptrthree,a,b);
   ptrthree^.tagfield := a;
   ptrthree^.tagfeeld := b;
   ptrthree^.p := 'w';
   pass := pass and (ptrthree^.p = 'w');
   dispose(ptrone);
   dispose(ptrtwo,a);
   dispose(ptrthree,a,b);
   if pass then
      writeln(' PASS ... 6.6.5.3a PROCEDURE NEW()')
   else
      writeln('FAIL ... 6.6.5.3a PROCEDURE NEW()')
end;


{TEST 6.6.5.3b}
{Test that new and dispose conform to the Standard,
however the undefinition of the pointer variable by dispose is not tested }
procedure c6p6p5p3b;
const n=100;
type
   pr = ^real;
   ppr = ^pr;
var
   i: -n..n;
   a: array[-n..n] of ^integer;
   pass: boolean;
   ptr: ppr;
   ptr0: pr;

function test: pr;
var p : pr;
begin
   new(p);
   p^ := 10.5;
   test := p;
end; {test}

function test1: ppr;
var p : ppr;
begin
   new(ptr);
   new(ptr^);
   ptr^^ := 1.5;
   ptr0 := ptr^;
   test1 := ptr;
end; {test1}

begin
   pass := true;
   for i := -n to n do begin
      new(a[i]);
      a[i]^ := i ;
      if a[i]^ <> i then begin
         pass := false;
         writeln('FAIL ... 6.6.5.3b (POINTER ACCESS)');
      end;
   end;

   for i := -n to n do begin
      if a[i]^ <> i then begin
         pass := false;
         writeln('FAIL ... 6.6.5.3b (POINTER ACCESS)');
      end;
      dispose(a[i])
   end;

   {dispose must accept an expression}
   dispose(test);   {func returning pointer}
   dispose(test1);  {func returning pointer to pointer}
   dispose(ptr0);

   if pass then
      writeln(' PASS ... 6.6.5.3b POINTER ACCESS')
end;


{ ------- 6.6.5.4 Transfer procedures ------- }

{TEST 6.6.5.4a}
{Test that pack and unpack are implemented correctly.}
procedure c6p6p5p4a;
type
   colour = (red, yellow, green, blue, tartan);
var
   ac:   array[colour] of char;
   pac:  packed array[1 .. 4] of char;
   ai:   array[4 .. 18] of integer;
   pai:  packed array[colour] of integer;
   i:    integer;
   c:    colour;
   pass: boolean;
begin
   pac := 'ABCD';
   for c := red to tartan do
      ac[c] := chr(ord(c) + ord('a') );
   unpack(pac,ac,yellow); { ... into element yellow of ac }
   pass := (ac[yellow]='A') and (ac[green]='B') and (ac[blue]='C') and (ac[tartan]='D')
           and (ac[red] = 'a');
   if not pass then begin
      writeln('FAIL ... 6.6.5.4a, unpack (1)')
   end;

   pack( ac, red, pac ); { ... from element red of ac }
   if pac <> 'aABC' then begin
      pass := false;
      writeln('FAIL ... 6.6.5.4a, pack (1)')
   end;

   for i := 4 to 18 do
      ai[i] := 11*i;
   pack(ai, 5, pai); { ... from element 5 of ai }

   for c := red to tartan do begin
      pass := pass and (pai[c] = (5 + ord(c))*11);
   end;
   if not pass then begin
      writeln('FAIL ... 6.6.5.4a, pack (2)')
   end;

   unpack( pai, ai, 8 ); { ... into element 8 of ai }
   if (ai[7] <> 77) or  (ai[8] <> 55) or  (ai[9] <> 66)
         or  (ai[12] <> 99) or  (ai[13] <> 143) then begin
      pass := false;
      writeln('FAIL ... 6.6.5.4a, unpack (2)')
   end;

   if pass then
      writeln(' PASS ... 6.6.5.4a, PACK & UNPACK')

end; {c6p6p5p4a}


{TEST 6.6.5.4j}
{Test that pack and unpack have src & dst arrays evaluated exactly once}
procedure c6p6p5p4j;
var
   ac:   array['A'..'D', 1..7] of char;
   pac:  array ['1'..'4'] of packed array[1 .. 4] of char;
   i:    integer;
   pass: boolean;
begin
   pac['1'] := 'ABCD';
   pac['2'] := 'klmn';
   pac['3'] := '0123';
   pac['4'] := '+-/*';
   for i := 1 to 7 do  { ac = '1234567' }
      ac['A',i] := chr(ord(i) + ord('0') );

   pack( ac[pac['1',1]], 2, pac['1'] ); { ... from element 2 of ac['A'] }
   if pac['1'] <> '2345' then begin
      pass := false;
      writeln('FAIL ... 6.6.5.4j, pack')
   end;

   unpack(pac[ac['A',4]], ac['A'], 3); { ... into elements 3..6 of ac['A'] }
   pass := (ac['A',3]='+') and (ac['A',4]='-') and (ac['A',5]='/') and (ac['A',6]='*')
           and (ac['A',1] = '1') and (ac['A',2] = '2') and (ac['A',7] = '7');
   if not pass then begin
      writeln('FAIL ... 6.6.5.4j, unpack')
   end;

   if pass then
      writeln(' PASS ... 6.6.5.4j, PACK & UNPACK reference')

end; {c6p6p5p4j}


{ ------- 6.6.6 Required functions ------- }

{ ------- 6.6.6.2 Arithmetic functions ------- }

{TEST 6.6.6.2a}
{ Test abs() for both real and integer arguments }
procedure c6p6p6p2a;
const
   step = 0.9;
   nrTests = 1000;
var
   i : integer;
   x : real;
   pass : boolean;

begin
   pass := true;
   for i := 0 to nrTests do begin
      if abs(i) <> i then begin
	 pass := false;
	 writeln('FAIL ... 6.6.6.2a : abs(', i, ')');
      end;
   end;

   for i := 0 downto -nrTests do begin
      if abs(i) <> -i then begin
	 writeln('FAIL ... 6.6.6.2a : abs(', i, ')');
	 pass := false;
      end;
   end;

   x := 0.0;
   while x < nrTests * step do begin
      if abs(x) <> x then begin
	 pass := false;
	 writeln('FAIL ... 6.6.6.2a : abs(', x:8:3, ')');
	 pass := false;
      end;
      if abs(-x) <> x then begin
	 pass := false;
	 writeln('FAIL ... 6.6.6.2a : abs(', -x:8:3, ')');
	 pass := false;
      end;
      x := x + step;
   end;

   if pass then
      writeln(' PASS ... 6.6.6.2a ABS()')
   else
end;


{TEST 6.6.6.2b}
{ Test sqr() for both real and integer arguments }
procedure c6p6p6p2b;
const
   step = 0.9;
   nrTests = 180;  { assume maxint >= sqr(nrTests) = 32400 }
var
   i, testValue : integer;
   x,y,z : real;
   pass : boolean;

begin
   pass := true;
   testValue := 0;
   for i := 0 to nrTests do begin
      if sqr(i) <> testValue then begin
	 pass := false;
	 writeln('FAIL ... 6.6.6.2b : (1) sqr(', i, ')');
      end;
      testValue := testValue + 2*i + 1;
   end;

   testValue := 0;
   for i := 0 downto -nrTests do begin
      if sqr(i) <> testValue then begin
	 writeln('FAIL ... 6.6.6.2b : (2) sqr(', i, ')');
	 pass := false;
      end;
      testValue := testValue - 2*i + 1;
   end;

   { find largest integer whose square is <= maxint}

   i := 1;
   while i*i <= maxint div 4 do
      i := 2*i;

   testValue := i;
   {sqr(testValue) <= maxint < sqr(testValue+i)}
   while i > 1 do begin
      i := i div 2;
      if sqr(testValue) <= maxint -sqr(i) - 2*testValue*i then
         testValue := testValue+i;
   end;

   if sqr(testValue) < maxint - 2*testValue - 1 then begin
      {failed to find the correct number}
      pass := false;
      writeln('FAIL ... 6.6.6.2b : (3) sqr(', testValue, ')');
   end;

   { now test sqr(i) for i ranging from max allowable down to 1 }
   i := testValue;
   while i > 0 do begin
      if sqr(i) <> sqr(i-1) + 2*i - 1 then begin
         pass := false;
         writeln('FAIL ... 6.6.6.2b : (4) sqr(', i, ')');
      end;
      i := i div 2;
   end;

   { similarly for negative nrs }
   i := -testValue;
   if sqr(i) < maxint + 2*i - 1 then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2b : (5) sqr(', i, ')');
   end;

   while i < -1 do begin
      if sqr(i+1) <> sqr(i) + 2*i + 1 then begin
         pass := false;
         writeln('FAIL ... 6.6.6.2b : (6) sqr(', i, ')');
      end;
      i := i div 2;
   end;

   x := 0.0;
   y := 0.0;
   z := 0.0;
   while x < nrTests * step do begin
      if abs(sqr(x) - z) > 4*eps*z then begin
         pass := false;
         writeln('eps is ', eps);
         writeln('FAIL ... 6.6.6.2b : sqr(', x:8:3, '), error is eps*', abs(sqr(x) - z)/(eps*z):9:1 );
      end;
      if abs(sqr(y) - z) > 4*eps*z then begin
         pass := false;
         writeln('FAIL ... 6.6.6.2b : sqr(', y:8:3, '), error is eps*', abs(sqr(x) - z)/(eps*z):9:1);
      end;
      z := x*(x + 2*step) + step*step;
      x := x + step;
      y := y - step;
   end;

   {test sqr(x) over the range minReal .. maxReal }
   x := 1; y := 1; z := 1;
   repeat
      if abs(sqr(x)*z - 1) > 4*eps then begin
         pass := false;
         writeln('FAIL ... 6.6.6.2b : sqr(', y, ')*sqr(', x, ')' );
      end;
      x := 2*x;
      y := y/2;
      z := sqr(y)*(1+eps)
   until (z = 0) or (z<=sqr(y));

   if pass then
      writeln(' PASS ... 6.6.6.2b SQR()')
   else
end;


{TEST 6.6.6.2c}
{ Test predefined functions sin(), cos(), exp(). ln(), sqrt(), & arctan() }
procedure c6p6p6p2c;
var
   i, n : integer;
   x, y : real;
   xd, yd : real;
   tol    : real;
   minReal: real;
   pass : boolean;
   pass1: boolean;

procedure testsin355;
{
 *
 *  Classified Tydeman Consulting Proprietary
 *  Copyright (C) 1996, 2014 Tydeman Consulting.  All rights reserved.
 *
 *  Fred J. Tydeman     tydeman@tybor.com
 *
 * Any person is hereby authorized to copy, use, and distribute, this
 * one sample test, subject to the following conditions:
 *
 *      1.  the software may not be redistributed for a fee except as
 *          reasonable to cover media costs;
 *      2.  any copy of the software must include this notice, as well as
 *          any other embedded copyright notices; and
 *      3.  any distribution of this software or derivative works thereof
 *          must comply with all applicable U.S. export control laws.
 *
 * Floating-Point C Extensions (FPCE) have been added to C99 (the
 * revision of the C language finished in late 1999).  If you are
 * interested in other sample tests of the FPCE Test Suite, which
 * tests the floating-point and numerics capabilities of C/C++
 * compilers and libraries, please see the FTP site:
 *      ftp://ftp.tybor.com
 *     user ID: anonymous
 *    password: your email address
 *
 *****************************************************************
 *
 * How accurate is sin(355.0)?
 *
 * This prodedure computes the approximate number of bits in error in the
 * answer returned from the sin() math function for one particular
 * argument. The number of ULPs (Units in Last Place) of error would be
 * about 2 ** BitsWrong.  So, the entries with 7.09 bits wrong have about
 * 135 ULPs error.
 *
 * The old C standard, C89 as amended, had no requirements on the
 * accuracy of the math library; it is a quality of implementation issue.
 * C99, the revision of C89 finished in late 1999, has added the requirement
 * that implementations document the accuracy of their math library.
 * C11 (the current C standard) has retained that requirement.
 *
 * While C99 has no requirement on the accuracy of the math library that
 * all implementations must follow (such as 5 ULP accuracy), there are
 * other "standards" that do have accuracy requirements on the math library.
 *
 * One "standard" is Draft international standard ISO/IEC 10967-2,
 * Language Independent Arithmetic (LIA) Part 2: Elementary Numerical
 * Functions.  LIA-2 should be added to ISO/ANSI C sometime in the future
 * (it may be several years). LIA-2 says the error limit on sin() is
 * 1.5 * rounding_error as long as the magnitude of the argument is
 * less than max_arg_sin, an implementation defined value.
 *
 * Proposed Standard for a Generic Package of Elementary Functions for Ada,
 * ISO-IEC/JTC1/SC22/WG9 (Ada) Numerics Rapporteur Group, 1990 is another
 * "standard".  It says that the maximum relative error allowed is
 * 2.0 * epsilon as long as the magnitude of the argument is less than
 * an implementation-dependent threshold, which must not be less than
 * radix ** (mantissa digits/2).
 *
 * Both "standards" have similar requirements of about 2 ULPs error. In
 * terms of this program, for IEEE-754 DBL which has 53 mantissa bits,
 * an error of 2 bits or less for arguments smaller than 94,906,265 would
 * meet Ada.  So, testing with an argument of 355 is well within the domain
 * where sin() must be accurate.  The integer value 355 was chosen for a
 * reason; for the details, see the file v1150001.h on the above FTP site.
 *
 * Depending upon how floating-point numbers are represented internally,
 * the number of bits wrong can vary by as much as one.  For machines
 * that use the same representation (such as all the IEEE-754 ones), that
 * is not a problem for using these numbers for comparison.
 *
 * For example, consider the 15-bit binary numbers (one near the top and
 * the other near the bottom of the same binade):
 *
 * 111111111000001      100000000001001         F = computed value
 * 111111111000000      100000000001000         f = correct value
 *               1                    1         absolute error
 * 1/111111111000000    1/100000000001000       relative error
 * (3.06e-5)            (6.10e-5)               relative error in decimal
 * -10.395              -9.704                  log(relative error)
 * 14.9972              14.0007                 bits "correct"
 *  0.0028               0.9993                 bits "wrong"
 *
 * I wish to acknowledge the following people for taking the time and effort
 * to run this test and sending me their results:
 *      Nelson H. F. Beebe, Center for Scientific Computing, University of Utah
 *      L. Busby
 *      Rex Jaeschke, consultant
 *      Larry Jones
 *      David S. Schwab
 *      Jonathan Ziebell
 *
 ***********************************************************************
}
const
   correct = -3.01443533594884492143302800086500995902558070663246491057898482406735383654727128353102367000340e-5;
   verbose = false;
var
   prec        : real;  { total number of bits in real     }
   calculate   : real;  { sin(355.0)                       }
   absError    : real;  { absolute error                   }
   relError    : real;  { relative error                   }
   ulpError    : real;  { unit last place error            }
   eps2        : real;  { epsilon in terms of bits         }
   bitsCorrect : real;  { number of bits correct in answer }
   bitsBad     : real;  { number of bits bad in answer     }

begin

   eps2 := eps / 2;     { 2 ** -precision                   }
   prec := -ln(eps2) / ln2;
   {writeln( 'precision is ', prec:9:2 );}
   if prec < 33.22 then  begin      { base-2 log of 10**10                 }
      writeln( 'Sin(355) test skipped: real numbers have too small precision: ', prec:1:2 )
   end
   else begin

      calculate := sin(355.0);
      {writeln( 'sin(355) = ', calculate, ' from maths library');}

      absError := abs(calculate - correct);
      {writeln( 'absolute err is ', absError);}

      relError := abs(absError / correct);
      {writeln( 'relative  err is ', relError);}

      { eps2 * 2**bitsBad > relError }
      if relError < eps2 then
         bitsBad := 0.0
      else begin
         bitsCorrect := -ln(relError) / ln2;
         bitsBad := prec - bitsCorrect;
      end;

      {
      * 2**-16 < |sin(355)| < 2**-15
      * |sin(355)| * 32768 = 0.98777, eg, in binade just below 1.0
      * eps2 = 2 ** -prec = ULP spacing in binade just below 1.0
      * eps2 / 32768 = ULP spacing of sin(355) in terms of base-2
      * Absolute error / spacing of correct answer = ULPs error w.r.t. correct
      }
      ulpError := absError * 32768.0 / eps2;
      if 2.0 < ulpError then begin
         writeln( 'sin(355) = ', correct:11, ' is correct answer.');
         writeln( 'About ', bitsBad:1:2, ' bits are wrong out of ', prec:1:2, ' total bits.' );
         writeln( 'That is about ', ulpError:1:2, ' ULPs (Units Last Place) bits error.' );
      end;

      if verbose then begin
         writeln( 'eps2 = ', eps2);
         writeln( 'abs = ', absError);
         writeln( 'rel = ', relError);
         writeln( 'ulp = ', ulpError);
         writeln( 'prec = ', prec:1:2);
      end;

      if ulpError <= 2.0  then begin
         if verbose then
            writeln( 'sin(255) Test ( Pass ) ' )
      end
      else if ulpError < 200 then begin
         writeln( 'warning: sin(355) Test is OK, but is slightly inaccurate.' );
      end
      else begin
         pass := false;
         writeln( 'fail: sin(355) Test Failed due to ULPs error being too large.' );
      end;
   end;
end; {testsin355}

begin
   pass := true;

   x := 1;
   repeat
      minReal := x;
      x := x/2;
      y := x*(1+eps);
   until (x = 0) or (y <= x);
   {writeln( 'minReal is ', minReal, ', eps is ', eps );}

   {assume tolerance of floating point calculations is two units of last place }
   tol := 2*eps;

   {TODO: review tolerance calcs}

   {other tests need sqrt so test this first}
   if abs(sqrt(1.69) - 1.3) > 1.3*tol/2 then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : sqrt(1.69)');
   end;
   if abs(sqrt(0.81) - 0.9) > 0.9*tol/2 then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : sqrt(0.81)');
   end;

   {split range 0.5 .. 2.0 into n values, then test each one}
   n := 3000;
   for i := 0 to n do begin
      xd := 0.5 + i*1.5/n;
      x := sqrt(xd);
      if x <> 0 then
         if abs(xd/x - x) > 2.5*tol*x then begin
            pass := false;
            writeln('FAIL ... 6.6.6.2c : x/sqrt(x)');
         end;
      if abs(sqr(1 - x) - (1 - 2*x + xd)) > tol*(1 + 4*x + 3*xd) then begin
         pass := false;
         writeln('FAIL ... 6.6.6.2c : sqrt(', xd:5:3, ')');
      end;
      if abs( 1 + x - sqrt(1 + 2*x + xd) ) > tol*(2 + 4*x + xd*(3+x)) then begin
         pass := false;
         writeln('FAIL ... 6.6.6.2c : sqrt(', 1 + 2*x + xd:5:3, ')');
      end;
      if abs(5*xd - sqrt(sqr(4*xd) + sqr(3*xd))) > tol*(51 + 25*xd)/10 then begin
         pass := false;
         writeln('FAIL ... 6.6.6.2c : sqrt(', 5*xd:5:3, ')');
      end;

   end;

   {test sqrt over the whole range of real values}
   xd := 1; {vary xd over range 1 .. min real}
   yd := 1; {vary yd over range 1 .. max real}
   pass1 := true;
   repeat
      x := sqrt(xd);
      if abs(xd - sqr(x)) > tol*xd then begin
         if pass1 then
            writeln( 'fail: sqrt( ', x, '), err is ', abs(xd-sqr(x))/(tol*xd):1:1 );
         pass1 := false;
      end;
      xd := xd/1.5;
      y := sqrt(yd);
      if abs(yd - sqr(y)) > tol*yd then begin
         if pass1 then
            writeln( 'fail: sqrt( ', y, '), err is ', abs(yd-sqr(y))/(tol*yd):1:1 );
         pass1 := false;
      end;
      yd := yd*1.5;
   until xd < minReal;
   pass := pass and pass1;

   if abs(sqrt(1) - 1 ) > tol then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : sqrt(1.0)');
   end;
   if abs(sqrt(0)) > tol then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : sqrt(0)');
   end;

   if abs(pi - 4*arctan(1.0)) > 5*tol then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : pi = arctan(1)');
   end;


   if abs(arctan(1/2) + arctan(1/3) - pi/4 ) > 2.25*tol then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : pi (a)');
   end;

   if abs(16*arctan(1/5) -  4*arctan(1/239) - pi ) > 21*tol then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : pi (b)');
   end;

   if abs(arctan(0)) > tol then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : arctan(0)');
   end;

   if abs(arctan(1/sqrt(3)) - pi/6) > tol*8/sqrt(27) then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : arctan(1/sqrt(3))');
   end;

   if abs(arctan(-sqrt(3)) + pi/3) > tol*(4*pi + sqrt(27))/12 then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : arctan(-sqrt(3)), error is tol*', (arctan(-sqrt(3)) + pi/3)/tol:7:2 );
   end;

   n := 3000;
   xd := (pi/2 - 1/n)/n;
   for i := -n to n do begin
      x := xd*i;           { need -pi/2 < x < pi/2 }
      if abs(arctan(sin(x)/cos(x)) - x) > tol*(abs(x)+abs(3*sin(x)*cos(x))) then begin
	 pass := false;
         writeln('FAIL ... 6.6.6.2c : arctan(sin(', x:1:3, ')/cos(x)), error is tol*',
                      (arctan(sin(x)/cos(x)) - x)/tol:7:2 );
      end;

      { sin(arctan(x)) = x/sqrt(1+x**2) }
      if abs(sqr(sin(arctan(x))) * (1+sqr(x)) - sqr(x))
            > tol*((1+sqr(x)* abs(2*x*(sin(x) + arctan(x)*cos(x)) + x)  + 1 ))
      then begin
         pass := false;
         writeln('FAIL ... 6.6.6.2c : sin(arctan(x))');
      end;

      { cos(arctan(x)) = 1/sqrt(1+x**2) }
      if abs(sqr(cos(arctan(x))) * (1+sqr(x)) - 1 )
            > tol*((1+sqr(x))*(2*(x/(1+sqr(x)))*arctan(x) + 1/sqrt(1+sqr(x)))
                               + sqr(1/sqrt(1+sqr(x))) + sqr(arctan(x))*(1+2*x) + 1 )
      then begin
         pass := false;
         writeln('FAIL ... 6.6.6.2c : cos(arctan(', x:6:3, ')), err is tol*',
                   abs(sqr(cos(arctan(x))) * (1+sqr(x)) - 1 )/tol:6:2 );
      end;

      {	tan(x) = 1/tan(pi/2 - x) }
      if x > 0 then begin
	 if abs(arctan(1/x) - pi/2 + arctan(x)) > tol*(x/(1+sqr(x)) + pi/2 ) then begin
	    writeln('FAIL ... 6.6.6.2c : arctan(pi/2 - ', x, ')');
	    pass := false
	 end
      end
      else if x < 0 then begin
         if abs(arctan(1/x) + pi/2 + arctan(x)) > tol*(x/(1+sqr(x)) + pi/2 ) then begin
	    writeln('FAIL ... 6.6.6.2c : arctan(pi/2 - ', x, ')');
	    pass := false
	 end
      end;
   end;

   if abs(sin(pi)) > pi*tol then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : sin(pi)');
   end;

   if abs(sin(pi/2) - 1) > sqr(tol) then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : sin(pi/2)');
   end;

   if abs(cos(pi) + 1) > pi*tol then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : cos(pi)');
   end;

   if abs(cos(pi/2)) > pi*tol/2 then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : cos(pi/2)');
   end;

   if sin(0) <> 0 then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : sin(0)');
   end;

   if cos(0) <> 1 then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : cos(0)');
   end;

   if abs(cos(-pi/2)) > tol*pi/2 then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : cos(-pi/2)');
   end;

   if abs(sin(-pi/2) + 1) > sqr(tol) then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : sin(-pi/2)');
   end;

   if abs(sin(-pi/6) + 0.5) > tol/2 then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : sin(pi/6)');
   end;

   if abs(cos(3*pi/4) + sqrt(0.5)) > tol/sqrt(2) then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : cos(pi)');
   end;

   if abs(cos(pi/9)*cos(2*pi/9)*cos(4*pi/9) - 1/8) > tol*5/8 then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : cos(pi/9)');
   end;

   n := 3000;
   xd := cos(pi/(2*n));
   yd := sin(pi/(2*n));
   for i := -n to n do begin
      x := cos(i*pi/n);
      y := sin(i*pi/n);
      if abs(cos(-i*pi/n) - x) > 2*tol*abs(x) then begin
	 pass := false;
	 writeln('FAIL ... 6.6.6.2c : cos(-x)');
      end;
      if abs(sin(-i*pi/n) + y) > 2*tol*abs(y) then begin
	 pass := false;
	 writeln('FAIL ... 6.6.6.2c : sin(-x)');
      end;
      if abs(cos(pi-i*pi/n) + x) > tol*(abs(x) + abs(y)*pi*(abs(i)+1+abs(n-i))/n) then begin
	 pass := false;
         writeln('FAIL ... 6.6.6.2c : cos(pi-x), err is tol*', abs(cos(pi-i*pi/n) + x)/tol:6:2 );
      end;
      if abs(sin(pi-i*pi/n) - y) > tol*(abs(x)*pi*(abs(i)+1+abs(n-i))/n    + abs(y)) then begin
	 pass := false;
         writeln('FAIL ... 6.6.6.2c : sin(pi-x), err is tol*', abs(cos(pi-i*pi/n) + x)/tol:6:2 );
      end;
      if abs(sqr(x) + sqr(y) - 1) > 3*tol then begin
	 pass := false;
	 writeln('FAIL ... 6.6.6.2c : cos(',x:6:3, ')**2 + sin**2');
      end;
      if abs(cos(i*pi/n + pi/(2*n)) - x*xd + y*yd)
            > tol*((1+ y*xd + x*yd)*(n+ pi*abs(2*i+1))
                   + (x*(n+yd*pi/2) + xd*(n+y*i*pi) + y*(n+xd*pi/2) + yd*(n+x*i*pi) ))/n then begin
	 pass := false;
	 writeln('FAIL ... 6.6.6.2c : cos(x+d)');
      end;
      if abs(sin(i*pi/n + pi/(2*n) ) - y*xd - x*yd)
            > tol*((1 + x*xd + y*yd)*(n+ pi*abs(2*i+1))
                   + abs(y*(n+yd*pi/2)) + abs(xd*(n+x*i*pi)) + abs(x*(n+xd*pi/2)) + abs(yd*(n+y*i*pi)))/n then begin
	 pass := false;
	 writeln('FAIL ... 6.6.6.2c : sin(x+d)');
      end;
   end;

   testsin355;

   { test exp(delta) = 1+delta (delta < sqrt(tol)) }
   x := sqrt(tol);
   if abs(exp(x) - 1 -x) > tol*(1+x) then begin
      pass := false;
      writeln( 'FAIL ... 6.6.6.2c : exp(small)' );
   end;

   if abs(exp(0) - 1) > tol then begin
      pass := false;
      writeln( 'FAIL ... 6.6.6.2c : exp(0)' );
   end;
   if abs(ln(1)) > tol then begin
      pass := false;
      writeln( 'FAIL ... 6.6.6.2c : ln(1)' );
   end;
   if abs(ln(1+tol) - tol) > sqr(tol) then begin
      pass := false;
      writeln( 'FAIL ... 6.6.6.2c : ln(1+tol)' );
   end;
   if abs(exp(-1) - erec) > tol then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : exp(1)');
   end;
   if abs(ln(erec) + 1) > tol then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : ln(e)');
   end;
   if abs(exp(ln2) - 2) > tol then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : exp(ln2)');
   end;
   if abs(ln(2) - ln2) > tol then begin
      pass := false;
      writeln('FAIL ... 6.6.6.2c : ln(2)');
   end;

   y := exp(0.5);
   n := 3000; 	{ nr steps }
   for i := -n to n do begin
      xd := i*10/n;	{ step size for range = -10.0 .. +10.0 }
      x := exp(xd+0.5);
      if abs(y*exp(xd) - x) > tol*y*exp(xd)*(abs(xd)+3) then begin
	 pass := false;
	 writeln( 'FAIL ... 6.6.6.2c :exp(', (xd+0.5):5:1, ')' );
      end;
      if abs(x*exp(-0.5-xd) - 1.0) > tol*(abs(xd)+2) then begin
	 pass := false;
	 writeln( 'FAIL ... 6.6.6.2c :exp(', (-xd-0.5):5:1, ')' );
      end;
      if abs(sqr(y)*exp(xd) - exp(xd+1)) > tol*y*exp(xd)*(abs(xd)+2 + abs(2*y)) then begin
	 pass := false;
	 writeln( 'FAIL ... 6.6.6.2c :exp(', xd:5:1, ' +1)' );
      end;
      if abs(ln(x) - (xd+0.5)) > tol*(abs(xd+0.5) + 1) then begin
	 pass := false;
         writeln( 'FAIL ... 6.6.6.2c : ln(x=', x:5:1, '), error is tol*',
                  (ln(x) - (xd+0.5))/tol:9, ', expected error is ', (abs((xd+0.5)/x) + 1):9 );
      end;
      if abs(ln(sqrt(x)) - (xd/2+0.25)) > tol*(1 + abs(xd/2+0.5)) then begin
         pass := false;
         writeln( 'FAIL ... 6.6.6.2c : ln(sqrt(', x:5:1, '))= ', (xd/2+0.25):9 );
      end;
      if abs(ln(sqr(x)) - (2*xd+1)) > tol*(2*abs(1/x) + abs(2*xd+1)) then begin
         pass := false;
         writeln( 'FAIL ... 6.6.6.2c : ln(sqr(x', x:5:1, '))' );
      end;
      if abs(ln(1/x) + xd+0.5) > tol*(abs(ln(1/x)) + abs(xd+0.5) + 1/x) then begin
	 pass := false;
	 write( 'FAIL ... 6.6.6.2c : ln(1/x)=', x:1:2, ') ' );
      end;
      if abs(ln(x*y) - (xd+1)) > tol*(abs(3*x*y) + abs(xd+1)) then begin
	 pass := false;
	 writeln( 'FAIL ... 6.6.6.2c : ln(x*y)' );
      end;
   end;

   {test ln() & exp() over the whole range of reals}
   xd := 1;
   yd := 1;
   i := 0;
   pass1 := true;
   repeat
      x := ln(xd);
      if abs(x + i*ln(2)) > tol*(1-x) then begin
         if pass1 then
            writeln( 'fail: ln(', xd:9, '), error is tol*', abs(x + i*ln(2))/(tol*(1-x)):9:1 );
         pass1 := false;
      end;
      if abs(exp(x) -xd) > xd*tol*(2-x) then begin
         if pass1 then
            writeln( 'fail: exp(', x:9, ') error is tol*', abs(exp(x) -xd)/(xd*tol*(2-x)) );
         pass1 := false;
      end;
      y := ln(yd);
      if abs(y - i*ln(2)) > tol*(1+y) then begin
         if pass1 then
            writeln( 'fail: ln(', yd:9, '), error is tol*', abs(y - i*ln(2))/(tol*(1+y)):9:1 );
         pass1 := false;
      end;
      if abs(exp(y) -yd) > yd*tol*(2+y) then begin
         if pass1 then
            writeln( 'fail: exp(', y:9, ') error is tol*', abs(exp(y) -yd)/(yd*tol*(2+y)) );
         pass1 := false;
      end;
      xd := xd/2;
      yd := yd*2;
      i := i+1;
   until xd <= minReal;
   pass := pass and pass1;

   {savage test}
   x := 1;
   for i := 1 to 2499 do begin
      x := arctan(exp(ln(sqrt(x*x))));
      x := sin(x)/cos(x) + 1.0;
   end; { tp5c }
   {Theoretical minimum error for 64 bit ieee is 1.177e-9}
   if abs(x-2500) > 2e-9 then begin
      writeln('savage test: x is ', x:1:3, ', expected 2500, error is ', x - 2500);
      pass := false;
   end;

   if pass then
      writeln(' PASS ... 6.6.6.2c arctan(), sin(), cos(), exp(), ln(), sqrt()')
   else
      writeln('FAIL ... 6.6.6.2c arctan(), sin(), cos(), exp(), ln(), sqrt()');
end;


{ ------- 6.6.6.3 Transfer functions ------- }

{TEST 6.6.6.3a}
{ Check the transfer functions trunc and round }
procedure c6p6p6p3a;
var
   i : integer;
   x : real;
   pass : boolean;
begin
   pass := true;

   if (trunc(3.5) <> 3) or (trunc(-3.5) <> -3) then begin
      writeln('FAIL ... 6.6.6.3a : TRUNC');
      pass := false;
   end;
   if (round(3.5) <> 4) or (round(-3.5) <> -4) then begin
      writeln('FAIL ... 6.6.6.3a ROUND');
      pass := false;
   end;
   x := 0;
   for i := -333 to 333 do begin
      x := x + i/100;
      if x<0 then begin
         if (trunc(x) < x) or (trunc(x) >= x+1) then begin
            writeln('FAIL ... 6.6.6.3a : TRUNC -ve'  );
            pass := false;
         end;
         if (trunc(x-0.5) <> round(x)) then begin
            writeln('FAIL ... 6.6.6.3a : ROUND -ve');
            pass := false;
         end;
      end
      else begin
         if (trunc(x) > x) or (trunc(x) <= x-1) then begin
            writeln('FAIL ... 6.6.6.3a : ROUND +ve'  );
            pass := false;
         end;
         if (trunc(x+0.5) <> round(x)) then begin
            writeln('FAIL ... 6.6.6.3a : TRUNC +ve'  );
            pass := false;
         end;
      end;
   end;

   if pass then
      writeln(' PASS ... 6.6.6.3a, TRUNC & ROUND');
end;


{ ------- 6.6.6.4 Ordinal functions ------- }

{TEST 6.6.6.4a}
{ Check that the ord function is as described by the Standard }
procedure c6p6p6p4a;
type
   colour = (red, yellow, green, blue, tartan);
var
   c :  colour;
   some : yellow..blue;
   i :  integer;
   counter :  integer;
   ok :  boolean;
begin
   counter := 0;
   if (ord(false)=0) and (ord(true)=1) then
      counter := counter+1
   else
      writeln('FAIL ... 6.6.6.4a : FALSE/TRUE');

   if (ord(red)=0)
	 and (ord(yellow)=1)
	 and (ord(green)=2)
	 and (ord (blue) =3)
	 and (ord(tartan)=4)
   then
      counter := counter+1
   else
      writeln('FAIL ... 6.6.6.4a COLOUR');

   i := -11;
   ok := true;
   while ok do begin
      i := i+1;
      if i>10 then
	 ok := false
      else if ord(i)=i then
	 counter := counter+1
      else begin
	 ok := false;
	 writeln('FAIL ... 6.6.6.4a I')
      end
   end;

   c := blue;
   some := yellow;
   if ord(c)=3 then
      counter := counter+1
   else
      writeln('FAIL ... 6.6.6.4a COLOUR');

   if ord(some)=1 then
      counter := counter+1
   else
      writeln('FAIL ... 6.6.6.4a SOME');

   if counter=25 then
      writeln(' PASS ... 6.6.6.4a, ORD function')
end;


{TEST 6.6.6.4b }
{ Check the implementation of chr() }
procedure c6p6p6p4b;
const
   n = 18; { nr special chars}
   specialChars = '+-*/=<>[].,:;''()^ ';
var
   ch : char;
   pass: boolean;
   s : packed array[1..n] of char;
   i : integer;

procedure testc(ch : char);
begin
   if chr(ord(ch)) <> ch then begin
      if pass then
	 writeln('FAIL ... 6.6.6.4b (', ch:1, ')');
      pass := false;
   end;
end;

begin
   pass := true;
   for ch := 'O' to '9' do
      testc(ch);
   for ch := 'a' to 'z' do
      testc(ch);
   for ch := 'A' to 'Z' do
      testc(ch);
   s := specialChars;
   for i := 1 to n do
      testc(s[i]);

   if pass then
      writeln( chr(ord(' ')), chr(ord('P')), chr(ord('A')), chr(ord('S')), chr(ord('S')), ' ... 6.6.6.4b CHR()')
   else
      writeln('FAIL ... 6.6.6.4b CHR()');
end;


{TEST 6.6.6.4c}
{Test the functions pred & succ }
procedure c6p6p6p4c;
type
   colour = (red, yellow, green, blue, tartan);

var
   c : colour;
   pass: boolean;
begin
   pass := true;
   c := tartan;
   c := pred(c);
   if c <> blue then
      pass := false;
   c := pred(c);
   if c <> green then
      pass := false;

   c := red;
   c := succ( c );
   if c <> yellow then
      pass := false;
   c := succ( c );
   if c <> green then
      pass := false;

   c := succ(pred(pred(succ(succ(pred(c))))));
   if c <> green then
      pass := false;

   if not pass then
      writeln('FAIL ... 6.6.6.4c PRED & SUCC COLOUR');

   if (pred(-10)<>-11) or (succ(-1)<>0) then
      writeln('FAIL ... 6.6.6.4c PRED/SUCC -VE NUMBERS')
   else if pass then
      writeln(' PASS ... 6.6.6.4c PRED & SUCC')
end;


{ ------- 6.6.6.5 Boolean functions ------- }

{TEST 6.6.6.5a}
{ Check that the functions eoln and eof are correctly implemented }
procedure c6p6p6p5a;
var
   f :text;
   pass : boolean;
   c:char;
begin
   rewrite(f);
   pass := true;
   writeln(f, 1);
   writeln(f, 'A');
   reset(f);
   while not eoln(f) do
      read (f,c);
   read (f,c);
   if c <> ' ' then begin
      pass := false;
      writeln('FAIL ... 6.6.6.5a, EOLN char should be '' ''')
   end;
   read (f,c);
   if c <> 'A' then begin
      pass := false;
      writeln('FAIL ... 6.6.6.5a, read after EOLN')
   end;
   if not eoln(f) then begin
      pass := false;
      writeln('FAIL ... 6.6.6.5a, EOLN')
   end;
   read (f,c);
   if not eof(f) then begin
      pass := false;
      writeln('FAIL ... 6.6.6.5a, EOF')
   end;
   if pass then
      writeln(' PASS ... 6.6.6.5a, EOLN AND EOF');
end;


{TEST 6.6.6.5b }
{ Test odd() for integers around zero and +/- maxint }
procedure c6p6p6p5b;
const
   test = 1000;
var
   i : integer;
   pass: boolean;
begin
   pass := odd(2*test+1);
   if not pass then
      writeln('FAIL ... 6.6.6.5b odd(', 2*test+1,')')
   else begin
      for i := 2*test downto -2*test do
      if odd(i) <> not odd(i+1) then begin
	 writeln('FAIL ... 6.6.6.5b, odd(', i, ')');
	 pass := false;
      end;
   end;

   if odd(maxint) then begin
      i := maxint div 2;
      if maxint <> 2*i + 1 then begin
	 writeln('FAIL ... 6.6.6.5b, odd(maxint)');
	 pass := false;
      end;
   end;

   for i := maxint div 2 downto maxint div 2 - test do begin
      if odd(2*i) then begin
	 writeln('FAIL ... 6.6.6.5b, odd(', 2*i, ')');
	 pass := false;
      end;
      if not odd(2*i-1) then begin
	 writeln('FAIL ... 6.6.6.5b, odd(', 2*i-1, ')');
	 pass := false;
      end;
      if odd(-2*i) then begin
	 writeln('FAIL ... 6.6.6.5b, odd(', -2*i, ')');
	 pass := false;
      end;
      if not odd(-2*i+1) then begin
	 writeln('FAIL ... 6.6.6.5b, odd(', -2*i+1, ')');
	 pass := false;
      end;
   end;

   if pass then
      writeln(' PASS ... 6.6.6.5b ODD()')
   else
end;


{ ------- 6.7 Expressions ------- }
{ ------- 6.7.1 General ------- }

{TEST 6.7.1a}
{Check that the the boolean operators take precedence over relational operators }
procedure c6p7p1a;
var
   a, b, c, x, y : boolean;
   pass1, pass2 : boolean;
begin
   pass1 := true;
   for a := false to true do
      for b := false to true do
	 for c := false to true do begin
	    x := c > b and a;
	    y := (a and b) < c;
	    if x <> y then begin
	       pass1 := false;
	    end;
	 end;
   if not pass1 then
      writeln('FAIL ... 6.7.1a (and op)');

   pass2 := true;
   for a := false to true do
      for b := false to true do
	 for c := false to true do begin
	    x := c > b or a;
	    y := (a or b) < c;
	    if x <> y then begin
	       pass2 := false;
	    end;
	 end;

   if not pass2 then
      writeln('FAIL ... 6.7.1a (or op)')
   else if pass1 then
      writeln(' PASS ... 6.7.1a BOOLEAN OPS')
end;


{TEST 6.7.1b}
{ Check the precedence of the arithmetic operators }
procedure c6p7p1b;
var
   a,b,c,d,e,f,g:   integer;
   h,i,j,k,l,m,n : real;
begin
   a := 1;
   b := 2;
   c := 3;
   d := 4;
   e := 5;
   f := a-b+c-d;
   g := e-d div b*c;
   h := 1;
   i := 2;
   j := 3;
   k := 4;
   l := 5;
   m := h/i*j/k;
   n := l+k/i-3*j;
   if (f=-2) and (g=-1) and (n=-2) and
	 ((m<0.38) and (m>0.37)) then
      writeln(' PASS ... 6.7.1b, arithmetic operator precedence')
   else
      writeln('FAIL ... 6.7.1b, arithmetic operator precedence')
end;


{TEST 6.7.1c}
{ Check that the div operator is left associative,
  ie that a div b div c = (a div b) div c }
procedure c6p7p1c;
var
    i :  integer;
begin
    i := 5;
    if 60 div i div 4 = 3 then
       writeln(' PASS ... 6.7.1c, div associative')
    else
       writeln('FAIL ... 6.7.1c, div associative')
end;


{TEST 6.7.1d}
{ Check that the mod operator is left associative,
  ie that a mod b mod c = (a mod b) mod c }
procedure c6p7p1d;
var
   i :  integer;
begin
   i := 11;
   if 20 mod i mod 5 = 4 then
      writeln(' PASS ... 6.7.1d, mod associative')
   else
      writeln('FAIL ... 6.7.1d, mod associative')
end;


{TEST 6.7.1e}
{ Check that the / real division operator is left associative,
  ie that a / b / c = (a / b) / c }
procedure c6p7p1e;
var
   x :  integer;
begin
   x := 5;
   if abs(60 / x / 4 - 3) < eps then
      writeln(' PASS ... 6.7.1e, real divide associative')
   else
      writeln('FAIL ... 6.7.1e, real divide associative')
end;


{TEST 6.7.1f}
{ Check that the  - set difference operator is left associative,
  ie that a - b - c = (a - b) - c
  and that a + b - c = (a + b) - c }
procedure c6p7p1f;
var
   a, b, c :  set of 1..5;
begin
   a := [1,3]; b := [1,2,3]; c := a;
   if (a + b - c = [2]) and (a - b - c = []) then
      writeln(' PASS ... 6.7.1f, set difference associative')
   else
      writeln('FAIL ... 6.7.1f, set difference associative')
end;


{TEST 6.7.1g}
{ Check the set member-designator [a..b], where a>b is equivalent to the empty set}
procedure c6p7p1g;
var
   i :  integer;
begin
   i := 12;
   if [i..11] = [] then
      writeln(' PASS ... 6.7.1g, empty set')
   else
      writeln('FAIL ... 6.7.1g, empty set')
end;


{ ------- 6.7.2 Operators ------- }

{TEST 6.7.2.1a}
{ test unary sign operator
  the sign should bind to the term, not the factor, ie -a mulop b is
  equivalent to -(a mulop b) }
procedure c6p7p2p1a;
var
   pass : boolean;
begin
   pass := true;

   if -8 mod 5 <> -(8 mod 5) then begin
      pass := false;
      writeln( 'FAIL ... 6.7.2.1a, -8 mod 5 is ', -8 mod 5:1 );
   end;

   if -(-(-(8 mod 5))) <>  -8 mod 5 then begin
      pass := false;
      writeln( 'FAIL ... 6.7.2.1a, -(-(-(8 mod 5))) is ', -(-(-(8 mod 5))):1 );
   end;

   if (-8) mod 5 <> 2 then begin
      pass := false;
      writeln( 'FAIL ... 6.7.2.1a, -8 mod 5 is ', (-8) mod 5:1 );
   end;

   if (+6 <> (+6)) or (+6.0 <> (+6.0)) or (-(+(+(6.0))) <> (-6.0)) then begin
      pass := false;
      writeln('FAIL ... 6.7.2.1a, UNARY + SIGN')
   end;

   if pass then
      writeln(' PASS ... 6.7.2.1a, UNARY SIGN')
   end;


{ ------- 6.7.2.2 Arithmetic operators ------- }

{TEST 6.7.2.2a}
{Check the operators + - and * }
procedure c6p7p2p2a;
const
   bound = 10;
var
    x, counter: integer;
    pass : boolean;
begin
   counter := 0;
   for x := -bound to bound do begin
      if succ(x)=x+1 then
	 counter := counter+1;
      if pred(x) = x-1 then
	 counter := counter+1;
      if x*x=sqr(x) then
	 counter := counter+1;
   end;
   pass := counter=3*(2*bound+1);

   x := maxint - bound;
   if x + bound <> maxint then
       pass := false;

   x := -bound;
   if bound + x <> 0 then
       pass := false;

   x := -2*bound;
   if bound + x <> -bound then
       pass := false;

   x := bound - maxint;
   if x + maxint <> bound then
       pass := false;

   x := -maxint;
   if x + maxint <> 0 then
       pass := false;

   x := bound - maxint;
   if x + (-bound) <> -maxint then
       pass := false;



   x := maxint;
   if x - bound <> maxint - bound then
       pass := false;

   x := maxint;
   if bound - x <> -(maxint - bound) then
       pass := false;

   x := bound;
   if bound - x <> 0 then
       pass := false;

   x := 1 - maxint;
   if x - 1 <> -maxint then
       pass := false;

   x := -maxint;
   if x - (-maxint) <> 0 then
       pass := false;

   x := bound - maxint;
   if x - bound <> -maxint then
       pass := false;

   if pass then
      writeln(' PASS ... 6.7.2.2a, addition and subtraction')
   else
      writeln('FAIL ... 6.7.2.2a, addition and subtraction')
end;


{TEST 6.7.2.2b -- DIV and MOO }
procedure c6p7p2p2b;
var
   i, j: integer;
   r: integer;
   pass1, pass2 : boolean;
begin
   pass1 := true;

   { i can be -ve, j must be >0 }
   for i := -150 to 150 do
      for j := 1 to 13 do begin
	 r := i div j;
	 if r <> 0 then begin
	    if abs(i) < abs(j) then begin
	       if pass1 then
		  writeln('FAIL ... 6.7.2.2b: ', i, ' DIV ', j, ' is ', r, ' but should be zero' );
	       pass1 := false;
	    end
	    else if (r>0) <> ((i>0) = (j>0)) then begin
	       { r is +ve iff i & j have the same signs }
	       if pass1 then
		  writeln('FAIL ... 6.7.2.2b: ', i, ' DIV ', j, ' is ', r, ' and has wrong sign' );
	       pass1 := false;
	    end
	 end
	 else if abs(i) >= abs(j) then begin
	    writeln('FAIL ... 6.7.2.2b: ', i, ' DIV ', j, ' should not be zero' );
	 end;

         if (i >= 0) and ((i+j) div j <> 1 + i div j) then begin
            if pass1 then
               writeln('FAIL ... 6.7.2.2b: DIV (a)' );
            pass1 := false;
         end;
         if (i <= 0) and ((i-j) div j <> i div j - 1) then begin
            if pass1 then
               writeln('FAIL ... 6.7.2.2b: DIV (b), i is ', i:1, ' j is ', j:1,
                       ' lhs is ',  (i-j) div j:1, ' rhs is ', i div j - 1 );
            pass1 := false;
         end;
         if not ((abs(r * j) <= abs(i)) and (abs(i) < abs(r * j) + abs(j))) then begin
	    if pass1 then
	       writeln('FAIL ... 6.7.2.2b: DIV (c)' );
	    pass1 := false;
	 end;
      end;

      pass2 := true;
      for i := -150 to 150 do
         for j := 1 to 13 do begin
            if pass2 and (i mod j < 0) then begin
               pass2 := false;
               if (i mod j) = -((-i) mod j) then    { detect mod implemented as rem function }
                  writeln('FAIL ... 6.7.2.2b: MOD seems to be implemented as REMAINDER function' )
               else
                  writeln('FAIL ... 6.7.2.2b: ', i, ' MOD ', j, ' is ', i mod j : 1,
                          ' but should be >= 0' );
            end
            else if pass2 and ((i mod j) >= j) then begin
               if pass2 then
                  writeln('FAIL ... 6.7.2.2b: ', i, ' MOD ', j, ' is ', i mod j : 1,
                          ' but should be < ', j:1 );
               pass2 := false;
            end;
            if (i - (i mod j)) mod j <> 0 then begin
               if pass2 then
                  writeln('FAIL ... 6.7.2.2b: MOD' );
               pass2 := false;
            end;
         end;

   if pass1 and pass2 then
      writeln(' PASS ... 6.7.2.2b, DIV & MOD')
end;


{TEST 6.7.2.2e}
{Check that maxint satisfies the conditions laid down in the Pascal Standard }
procedure c6p7p2p2e;
var
   i : integer;
begin
   i := (-maxint);
   i := maxint;
   { avoid overflow checks }
   if odd(maxint) then
      i := (maxint-1-((maxint div 2)))*2
   else
      i := (maxint-1-(maxint div 2))*2+1;
   if i=maxint-1 then
      writeln(' PASS ... 6.7.2.2e: MAXINT')
   else
      writeln('FAIL ... 6.7.2.2e: MAXINT')
end;


{TEST 6.7.2.3a}
{Check boolean expressions }
procedure c6p7p2p3a;
var
   a,b,c : boolean;
   pass1, pass2, pass3, pass4 : boolean;

begin

   { OR truth table }
   a := false;
   b := false;
   pass1 := false;
   if a or b then
      pass1 := false
   else begin
      b := true;
      if a or b then begin
	 a := true;
	 if a or b then begin
	    b := false;
	    if a or b then
	       pass1 := true;
	 end
      end
   end;

   if not pass1 then
      writeln('FAIL ... 6.7.2.3a: OR');

   { AND truth table }
   a := false;
   b := false;
   if a and b then
      pass2 := false
   else begin
      a := true;
      if a and b then
	 pass2 := false
      else begin
	 b := true;
	 if a and b then begin
	    a := false;
	    if a and b then
	       pass2 := false
	    else
	       pass2 := true;
	 end
	 else
	    pass2 := false
      end
   end;

   if not pass2 then
      writeln('FAIL ... 6.7.2.3a: AND');

   pass3 := false;
   pass4 := false;
   if (not false)=true then
      pass3 := true
   else
      writeln('FAIL ... 6.7.2.3a: NOT FALSE');
   if (not true)=false then
      pass4 := true
   else
      writeln('FAIL ... 6.7.2.3a: NOT TRUE');

   pass3 := pass3 and pass4;

   pass4 := true;
   for c := false to true do begin
      for a := false to true do begin
	 for b := false to true do begin
	    if (a or b) <> (b or a) then begin
	       pass4 := false;
	       writeln('FAIL ... 6.7.2.3a: COMMUTE - OR');
	    end;
	    if (a and b) <> (b and a) then begin
	       pass4 := false;
	       writeln('FAIL ... 6.7.2.3a: COMMUTE - AND');
	    end;
	    if ((a or b)or c) <> (a or(b or c)) then begin
	       pass4 := false;
	       writeln('FAIL ... 6.7.2.3a: ASSOCIATIVE - OR');
	    end;
	    if ((a and b)and c) <> (a and(b and c)) then begin
	       pass4 := false;
	       writeln('FAIL ... 6.7.2.3a: ASSOCIATIVE - AND');
	    end;
	    if (a and(b or c)) <> ((a and b)or(a and c)) then begin
	       pass4 := false;
	       writeln('FAIL ... 6.7.2.3a: DISTRIBUTION');
	    end;
	    if not(a or b) <> ((not a) and (not b)) then begin
	       pass4 := false;
	       writeln('FAIL ... 6.7.2.3a: DEMORGAN1');
	    end;
	    if not(a and b) <> ((not a) or (not b)) then begin
	       pass4 := false;
	       writeln('FAIL ... 6.7.2.3a: DEMORGAN2');
	    end;
	    if not(not a) <> a then begin
	       pass4 := false;
	       writeln('FAIL ... 6.7.2.3a: INVERSION');
	    end;
	 end;
      end;
   end;

   if pass1 and pass2 and pass3 and pass4  then
      writeln(' PASS ... 6.7.2.3a BOOLEAN OPERATORS')
end;


{ ------- 6.7.2.4 Set operators -------}

{TEST 6.7.2.4a}
{Check the union, intersection and difference set operators.
 In this test, we check all combinations of 3 operators and set elements}
procedure c6p7p2p4a;
const n = 15;
type
   setType = set of 0 .. n;
var
   a,b,c,d: setType;
   i: integer;
   pass: boolean;

{ print a set }
procedure prSet(s : setType);
var
   i: integer;
   comma: boolean;
begin
   pass := false;
   write( 's is [' );
   comma := false;
   for i := 0 to n do begin
      if i in s then begin
         if comma then write(',');
         write(i:1);
         comma := true;
      end;
   end;
   writeln(']');
end;

begin
   pass := true;
   a := []; b := []; c := []; d := [];
   for i := 0 to n do begin
      if odd(i div 8) then a := a + [i];
      if odd(i div 4) then b := b + [i];
      if odd(i div 2) then c := c + [i];
      if odd(i) then d := d + [i];
   end;

   {prSet(a); prSet(b); prSet(c); prSet(d);}
   if a+b+c+d <> [1..15] then begin
      prSet( a+b+c+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + + +');
   end;

   if a+b+c*d <> [3..15] then begin
      prSet( a+b+c*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + + *');
   end;

   if (a+b+c)*d <> [3,5,7,9,11,13,15] then begin
      prSet( (a+b+c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (+ +) *');
   end;

   if a+(b+c)*d <> [3,5,7..15] then begin
      prSet( a+(b+c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + (+) *');
   end;

   if a+b+c-d <> [2,4,6,8,10,12,14] then begin
      prSet( a+b+c-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + + -');
   end;

   if a+b+(c-d) <> [2,4..15] then begin
      prSet( a+b+(c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + + (-)');
   end;

   if a+b*c+d <> [1,3,5..15] then begin
      prSet( a+b*c+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + * +');
   end;

   if (a+b)*c+d <> [1,3,5..7,9..11,13..15] then begin
      prSet( (a+b)*c+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (+) * +');
   end;

   if (a+b)*(c+d) <> [5..7, 9..11, 13..15] then begin
      prSet( (a+b)*(c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (+) * (+)');
   end;

   if a+b*(c+d) <> [5..15] then begin
      prSet( a+b*(c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + * (+)');
   end;

   if a+b*c*d <> [7..15] then begin
      prSet( a+b*c*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + * *');
   end;

   if (a+b)*c*d <> [7,11,15] then begin
      prSet( (a+b)*c*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (+) * *');
   end;

   if (a+b*c)*d <> [7,9,11,13,15] then begin
      prSet( (a+b*c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (+ *) *');
   end;

   if a+b*c-d <> [6,8,10,12,14] then begin
      prSet( a+b*c-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + * -');
   end;

   if (a+b)*c-d <> [6,10,14] then begin
      prSet( (a+b)*c-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (+) * -');
   end;

   if (a+b)*(c-d) <> [6,10,14] then begin
      prSet( (a+b)*(c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (+) * (-)');
   end;

   if a+(b*c-d) <> [6,8..15] then begin
      prSet( a+(b*c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + (* -)');
   end;

   if a+b*(c-d) <> [6,8..15] then begin
      prSet( a+b*(c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + (* (-))');
   end;

   if a+b-c+d <> [1,3,4,5,7,8,9,11,12,13,15] then begin
      prSet( a+b-c+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + - +');
   end;

   if a+(b-c)+d <> [1,3..5, 7..15] then begin
      prSet( a+(b-c)+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + (-) +');
   end;

   if a+b-(c+d) <> [4,8,12] then begin
      prSet( a+b-(c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + - (+)');
   end;

   if a+(b-c)+d <> [1,3,4,5,7..15] then begin
      prSet( a+(b-c)+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + (-) +');
   end;

   if a+(b-(c+d)) <> [4,8..15] then begin
      prSet( a+(b-(c+d)) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + (- (+))');
   end;

   if a+b-c*d <> [4..6,8..10,12..14] then begin
      prSet( a+b-c*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + - *');
   end;

   if (a+b-c)*d <> [5,9,13] then begin
      prSet( (a+b-c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (+ -) *');
   end;

   if (a+(b-c))*d <> [5,9,11,13,15] then begin
      prSet( (a+(b-c))*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (+ (-)) *');
   end;

   if a+((b-c)*d) <> [5,8..15] then begin
      prSet( a+((b-c)*d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + ((-) *)');
   end;

   if a+(b-c*d) <> [4,5,6,8..15] then begin
      prSet( a+(b-c*d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + (- *)');
   end;

   if a+b-c-d <> [4,8,12] then begin
      prSet( a+b-c-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + - -');
   end;

   if (a+b-c)-d <> [4,8,12] then begin
      prSet( (a+b-c)-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (+ -) -');
   end;

   if a+(b-c)-d <> [4,8,10,12,14] then begin
      prSet( a+(b-c)-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + (-) -');
   end;

   if a+b-(c-d) <> [4,5,7..9,11..13,15] then begin
      prSet( a+b-(c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + - (-)');
   end;

   if a+((b-c)-d) <> [4,8..15] then begin
      prSet( a+((b-c)-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + ((-) -)');
   end;

   if a+(b-(c-d)) <> [4,5,7,8,9,10,11,12,13,14,15] then begin
      prSet( a+(b-(c-d)) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS + (- (-))');
   end;

   if a*b+c+d <> [1,2,3,5..7,9..15] then begin
      prSet( a*b+c+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * + +');
   end;

   if a*(b+c)+d <> [1,3,5,7,9..15] then begin
      prSet( a*(b+c)+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (+) +');
   end;

   if a*(b+c+d) <> [9..15] then begin
      prSet( a*(b+c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (+ +)');
   end;

   if a*b+c*d <> [3,7,11..15] then begin
      prSet( a*b+c*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * + *');
   end;

   if (a*b+c)*d <> [3,7,11,13,15] then begin
      prSet( (a*b+c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (* +) *');
   end;

   if a*(b+c)*d <> [11, 13, 15] then begin
      prSet( a*(b+c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (+) *');
   end;

   if a*(b+c*d) <> [11..15] then begin
      prSet( a*(b+c*d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (+ *)');
   end;

   if a*b+c-d <> [2,6,10,12,14] then begin
      prSet( a*b+c-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * + -');
   end;

   if a*(b+c)-d <> [10,12,14] then begin
      prSet( a*(b+c)-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (+) -');
   end;

   if a*b+(c-d) <> [2,6,10,12..15] then begin
      prSet( a*b+(c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * + (-)');
   end;

   if a*(b+c-d) <> [10,12,14] then begin
      prSet( a*(b+c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (+ -)');
   end;

   if a*(b+(c-d)) <> [10,12..15] then begin
      prSet( a*(b+(c-d)) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (+ (-))');
   end;

   if a*b*c+d <> [1,3,5,7,9,11,13,14,15] then begin
      prSet( a*b*c+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * * +');
   end;

   if a*b*(c+d) <> [13,14,15] then begin
      prSet( a*b*(c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * * (+)');
   end;

   if a*(b*c+d) <> [9,11,13,14,15] then begin
      prSet( a*(b*c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (* +)');
   end;

   if a*b*(c+d) <> [13..15] then begin
      prSet( a*b*(c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * * (+)');
   end;

   if a*b*c*d <> [15] then begin
      prSet( a*b*c*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * * *');
   end;

   if a*b*c-d <> [14] then begin
      prSet( a*b*c-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * * -');
   end;

   if a*b*(c-d) <> [14] then begin
      prSet( a*b*(c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * * (-)');
   end;

   if a*(b*c-d) <> [14] then begin
      prSet( a*(b*c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (* -)');
   end;

   if a*b-c+d <> [1,3,5,7,9,11,12,13,15] then begin
      prSet( a*b-c+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * - +');
   end;

   if a*(b-c)+d <> [1,3,5,7,9,11,12,13,15] then begin
      prSet( a*(b-c)+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (-) +');
   end;

   if a*b-(c+d) <> [12] then begin
      prSet( a*b-(c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * - (+)');
   end;

   if a*(b-(c+d)) <> [12] then begin
      prSet( a*(b-(c+d)) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (- (+))');
   end;

   if a*(b-c+d) <> [9,11,12,13,15] then begin
      prSet( a*(b-c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (- +)');
   end;

   if a*b-c*d <> [12..14] then begin
      prSet( a*b-c*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * - *');
   end;

   if (a*b-c)*d <> [13] then begin
      prSet( (a*b-c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (* -) *');
   end;

   if a*(b-c)*d <> [13] then begin
      prSet( a*(b-c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (-) *');
   end;

   if (a*b-c)*d <> [13] then begin
      prSet( (a*b-c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (* -) *');
   end;

   if a*(b-c*d) <> [12..14] then begin
      prSet( a*(b-c*d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (- *)');
   end;

   if a*b-c-d <> [12] then begin
      prSet( a*b-c-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * - -');
   end;

   if (a*b-c)-d <> [12] then begin
      prSet( (a*b-c)-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (* -) -');
   end;

   if a*(b-c)-d <> [12] then begin
      prSet( a*(b-c)-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (-) -');
   end;

   if a*((b-c)-d) <> [12] then begin
      prSet( a*((b-c)-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * ((-) -)');
   end;

   if a*b-(c-d) <> [12,13,15] then begin
      prSet( a*b-(c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * - (-)');
   end;

   if a*(b-(c-d)) <> [12,13,15] then begin
      prSet( a*(b-(c-d)) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS * (- (-))');
   end;

   if a-b+c+d <> [1..3, 5..11, 13..15] then begin
      prSet( a-b+c+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - + +');
   end;

   if a-(b+c)+d <> [1,3,5,7,8,9,11,13,15] then begin
      prSet( a-(b+c)+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (+) +');
   end;

   if a-(b+c+d) <> [8] then begin
      prSet( a-(b+c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (+ +)');
   end;

   if a-b+c*d <> [3, 7..11,15] then begin
      prSet( a-b+c*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - + *');
   end;

   if (a-b+c)*d <> [3,7,9,11,15] then begin
      prSet( (a-b+c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (- +) *');
   end;

   if (a-(b+c))*d <> [9] then begin
      prSet( (a-(b+c))*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (- (+)) *');
   end;

   if a-(b+c)*d <> [8,9,10,12,14] then begin
      prSet( a-(b+c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (+) *');
   end;

   if a-(b+c*d) <> [8,9,10] then begin {?? xxx}
      prSet( a-(b+c*d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (+ *)');
   end;

   if a-b+c-d <> [2,6,8,10,14] then begin
      prSet( a-b+c-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - + -');
   end;

   if (a-(b+c))-d <> [8] then begin
      prSet( (a-(b+c))-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (- (+)) -');
   end;

   if a-b+(c-d) <> [2,6,8..11,14] then begin
      prSet( a-b+(c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - + (-)');
   end;

   if a-(b+c-d) <> [8, 9, 11, 13, 15] then begin
      prSet( a-(b+c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (+ -)');
   end;

   if a-(b+(c-d)) <> [8, 9, 11]  then begin
      prSet( a-(b+(c-d)) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (+ (-))');
   end;

   if a-b*c+d <> [1,3,5,7..13,15] then begin
      prSet( a-b*c+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - * +');
   end;

   if (a-b)*c+d <> [1,3,5,7,9,10,11,13,15] then begin
      prSet( (a-b)*c+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (-) * +');
   end;

   if a-(b*c+d) <> [8,10,12] then begin
      prSet( a-(b*c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (* +)');
   end;

   if (a-b)*(c+d) <> [9..11] then begin
      prSet( (a-b)*(c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (*) +');
   end;

   if a-b*(c+d) <> [8, 9..12] then begin
      prSet( a-b*(c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - * (+)');
   end;

   if a-b*c*d <> [8..14] then begin
      prSet( a-b*c*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - * *');
   end;

   if (a-b)*c*d <> [11] then begin
      prSet( (a-b)*c*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (-) * *');
   end;

   if (a-b*c)*d <> [9, 11, 13] then begin
      prSet( (a-b*c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (- *) *');
   end;

   if a-b*c-d <> [8,10,12] then begin
      prSet( a-b*c-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - * -');
   end;

   if (a-b)*c-d <> [10] then begin
      prSet( (a-b)*c-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (-) * -');
   end;

   if (a-b*c)-d <> [8,10,12] then begin
      prSet( (a-b*c)-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (- *) -');
   end;

   if (a-b)*(c-d) <> [10] then begin
      prSet( (a-b)*(c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (-) * (-)');
   end;

   if a-(b*c-d) <> [8..13, 15] then begin
      prSet( a-(b*c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (* -)');
   end;

   if a-b*(c-d) <> [8..13, 15] then begin
      prSet( a-b*(c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - * (-)');
   end;

   if a-b-c+d <> [1,3,5,7,8,9,11,13,15] then begin
      prSet( a-b-c+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - - +');
   end;

   if a-(b-c)+d <> [1,3,5,7..11,13..15] then begin
      prSet( a-(b-c)+d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (-) +');
   end;

   if (a-b)-(c+d) <> [8] then begin
      prSet( (a-b)-(c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (-) - (+)');
   end;

   if a-(b-c+d) <> [8,10,14] then begin
      prSet( a-(b-c+d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (- +)');
   end;

   if a-(b-(c+d)) <> [8..11,13..15] then begin
      prSet( a-(b-(c+d)) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (- (+))');
   end;

   if a-b-c*d <> [8..10] then begin
      prSet( a-b-c*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - - *');
   end;

   if ((a-b)-c)*d <> [9] then begin
      prSet( ((a-b)-c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS ((-) -) *');
   end;

   if (a-(b-c))*d <> [9, 11, 15] then begin
      prSet( (a-(b-c))*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (- (-)) *');
   end;

   if (a-b)-c*d <> [8,9,10] then begin
      prSet( (a-b)-c*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (-) - *');
   end;

   if a-(b-c)*d <> [8..12,14,15] then begin
      prSet( a-(b-c)*d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (-) *');
   end;

   if a-(b-c*d) <> [8..11, 15] then begin
      prSet( a-(b-c*d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (- *)');
   end;

   if a-b-c-d <> [8] then begin
      prSet( a-b-c-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - - -');
   end;

   if (a-(b-c))-d <> [8, 10, 14] then begin
      prSet( (a-(b-c))-d );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (- (-)) -');
   end;

   if (a-b)-(c-d) <> [8, 9, 11] then begin
      prSet( (a-b)-(c-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS (-) - (-)');
   end;

   if a-((b-c)-d) <> [8..11, 13,14,15] then begin
      prSet( a-((b-c)-d) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - ((-) -)');
   end;

   if a-(b-(c-d)) <> [8..11,14] then begin
      prSet( a-(b-(c-d)) );
      writeln('FAIL ... 6.7.2.4a SET OPERATORS - (- (-))');
   end;

   if pass then
      writeln(' PASS ... 6.7.2.4a, SET OPERATORS');
end;


{TEST 6.7.2.4b}
{set operations confidence test }
procedure c6p7p2p4b;
const
   amax =  41;
   amin = -amax;  {change this to zero if -ve set elements are not allowed}
type
   aset = set of amin..amax;

var
   set1, set2 : aset;
   ptr        : ^aset;
   i          : amin..amax;
   pass       : boolean;

{ count nr members in a set }
function card( s: aset ) : integer;
var
   i, n : integer;
begin
   n := 0;
   for i := amin to amax do
      if i in s then
         n := n + 1;
   card := n;
end;

{ invert a set }
procedure inv( var s: aset );
begin
   s := [amin..amax] - s;
end;

begin { c6p7p2p4b }
   pass := true;
   if card([]) <> 0 then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4b,card([])')
   end;
   set1 := [5..15];
   if card(set1) <> 11 then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4b,card(set1)')
   end;
   set2 := [10];
   if card(set2) <> 1 then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4b,card(set2)')
   end;
   if set1 * [23] <> [] then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4b,[]')
   end;
   i := 9;
   if set1-set2 <> [5..i,11..15] then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4b, -')
   end;

   i := 15;
   if not (17 in [10..13,i..20,25..30]) then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4b, not in')
   end;
   i := 22;
   if i in [1..21,23,36..amax] then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4b, in')
   end;

   new(ptr);

   for i := amin to amax do begin
      ptr^ := [amin+2,10,37,i];
      set1 := ptr^ - [amin+amax-3..amin+amax-1];
      set2 := ptr^ + [10..12,17];
      if ptr^ * set1 <> set1 then begin
         pass := false;
         writeln('FAIL ... 6.7.2.4b, mul minus (', i:1, ')')
      end;
      if not (ptr^ * set2 = ptr^) then begin
         pass := false;
         writeln('FAIL ... 6.7.2.4b, mul plus (', i:1, ')')
      end;

      if set1 - (set2 - set1) <> set1 * set2 then begin
         pass := false;
         writeln('FAIL ... 6.7.2.4b, set difference (', i:1, ')')
      end;

      if not ((set1 <> set2) and
              (set2 >= ptr^) and
              (set1 <= set2) and
              (set1 >= set1) and
              (set1 <= set1) and
              (17 in set2))
      then begin
         pass := false;
         writeln('FAIL ... 6.7.2.4b, and relop (', i:1, ')')
      end;

      if card(set2) <> 7 - ord( [i]*[amin..amax] <= [amin+2,10..12,17,37] ) then begin
         pass := false;
         writeln('FAIL ... 6.7.2.4b, card (', i:1, ')')
      end;

      if (set1 <> set1)   or
         (ptr^ >= set2)   or
         (set2 <= set1)   or
         (set1 =  set2)   or
         not (i in set2)
      then begin
         pass := false;
         writeln('FAIL ... 6.7.2.4b, or relop (', i:1, ')')
      end;

      ptr^ := set1 * set2;
      inv( set2 );
      inv( set1 );
      inv( ptr^ );
      if ptr^ <> set1 + set2 then begin
         pass := false;
         writeln('FAIL ... 6.7.2.4b, de Morgan (', i:1, ')')
      end;

   end; { for }
   dispose( ptr );

   if pass then
      writeln(' PASS ... 6.7.2.4b, SET OPERATORS');

end; { c6p7p2p4b }


{TEST 6.7.2.4c}
{Check the union, intersection and difference set operators }
procedure c6p7p2p4c;
var
   a,b,c,d:set of 0 .. 10;
   pass: boolean;
begin
   pass := true;
   a := [0,2,4,6,8,10];
   b := [1,3,5,7,9];
   c:=[];
   d := [0..10];

   if a+b <> d then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 1')
   end;

   if d-b <> a  then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 2')
   end;

   if d*b <> b then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 3')
   end;

   if d*b-b <> c then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 4')
   end;

   if a+b+c <> d then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 5')
   end;

   if a+[] <> a then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 6')
   end;

   if a-b <> a then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 7')
   end;

   if a+[1,3,5,7,9] <> d then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 8')
   end;

   if a-[] <> a then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 9')
   end;

   if d-a <> b then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 10')
   end;

   if d-[0,2,4,6,8,10] <> b then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 11')
   end;

   if a*a <> a then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 12')
   end;

   if a*[] <> [] then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 13')
   end;

   if a*b <> [] then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 14')
   end;

   if d*[1,3,5,7,9] <> b then begin
      pass := false;
      writeln('FAIL ... 6.7.2.4c SET OPERATORS - 15')
   end;

   if pass then
      writeln(' PASS ... 6.7.2.4c, SET OPERATORS');
end;


{ ------- 6.7.2.5 Relational operators ------- }

{TEST 6.7.2.5a}
{ Test relational operators on strings }
procedure c6p7p2p5a;
const strlen = 7;
var
   string1 : packed array[1 .. strlen] of char;
   string2 : packed array[1 .. strlen] of char;
   pass    : boolean;
begin
   pass := true;

   { test with lhs = rhs }
   string1 := 'STRING$';
   string2 := 'STRING$';
   if not (string1 = string2) then
      pass := false;
   if string1 <> string2 then
      pass := false;
   if not (string1 <= string2) then
      pass := false;
   if not (string1 >= string2) then
      pass := false;
   if string1 < string2 then
      pass := false;
   if string1 > string2 then
      pass := false;

   { test with lhs < rhs }
   string1 := 'STRING1';
   string2 := 'STRING2';
   if string1 = string2 then
      pass := false;
   if not (string1 <> string2) then
      pass := false;
   if not (string1 <= string2) then
      pass := false;
   if string1 >= string2 then
      pass := false;
   if not (string1 < string2) then
      pass := false;
   if string1 > string2 then
      pass := false;

   { test with lhs > rhs }
   string1 := 'STRINGB';
   string2 := 'STRINGA';
   if string1 = string2 then
      pass := false;
   if not (string1 <> string2) then
      pass := false;
   if string1 <= string2 then
      pass := false;
   if not (string1 >= string2) then
      pass := false;
   if string1 < string2 then
      pass := false;
   if not (string1 > string2) then
      pass := false;

   if pass then
      writeln(' PASS ... 6.7.2.5a, STRING COMPARE')
   else
      writeln('FAIL ... 6.7.2.5a, STRING COMPARE')
end;


{TEST 6.7.2.5b}
{Check the use of relational operators on sets }
procedure c6p7p2p5b;
var
   a,b:set of 0 .. 10;
   c:integer;
   pass: boolean;
begin
   pass := true;
   a := [0,1,2,3,4,5];
   b := [2,3,4];
   c := 3;
   if a <> [0..5] then
      pass := false;
   if not (a <> [0,1,2,3,4,5,6]) then
      pass := false;
   if not (a <> [0,1,2,3,4]) then
      pass := false;

   if a = b then
      pass := false;
   if b = [1,2,3,4,5] then
      pass := false;
   if b = [2,4] then
      pass := false;
   if not (b = [2,3,4]) then
      pass := false;

   if not (a <= [0..5]) then
      pass := false;
   if not (b <= a) then
      pass := false;
   if not ([0,1] <= a) then
      pass := false;
   if [0,1,7] <= a then
      pass := false;

   if not (a >= b) then
      pass := false;
   if not ([2..4] >= b) then
      pass := false;
   if not ([1,2,3,4,5,6,10] >= b) then
      pass := false;
   if [1,2,3,5,6,10] >= b then
      pass := false;
   if [2,3] >= b then
      pass := false;

   if not (1 in a) then
      pass := false;
   if not (c in b) then
      pass := false;
   if 7 in a then
      pass := false;

   if pass then
      writeln(' PASS ... 6.7.2.5b, SET COMPARE')
   else
      writeln('FAIL ... 6.7.2.5b, SET COMPARE');
end;


{TEST 6.7.2.5c}
{ Test relational operators on sets }
procedure c6p7p2p5c;
var
   set1 : set of 1..10;
   set2 : set of 1 .. 10;
   pass    : boolean;
begin
   pass := true;

   { test with lhs = rhs }
   set1 := [2,4,5,7];
   set2 := [2,4,5,7];
   if not (set1 = set2) then
      pass := false;
   if set1 <> set2 then
      pass := false;
   if not (set1 <= set2) then
      pass := false;
   if not (set1 >= set2) then
      pass := false;

   { test with lhs < rhs }
   set1 := [3,6,9];
   set2 := [3,5,6,9];
   if set1 = set2 then
      pass := false;
   if not (set1 <> set2) then
      pass := false;
   if not (set1 <= set2) then
      pass := false;
   if set1 >= set2 then
      pass := false;

   { test with lhs > rhs }
   set1 := [1,3,8,10];
   set2 := [1,3,8];
   if set1 = set2 then
      pass := false;
   if not (set1 <> set2) then
      pass := false;
   if set1 <= set2 then
      pass := false;
   if not (set1 >= set2) then
      pass := false;

   { test with disjoint sets }
   set1 := [1,3,8,10];
   set2 := [1,3,8,9];
   if set1 = set2 then
      pass := false;
   if not (set1 <> set2) then
      pass := false;
   if set1 <= set2 then
      pass := false;
   if set1 >= set2 then
      pass := false;

   {test in operator}
   if 9 in set1 then
      pass := false;
   if not (8 in set1) then
      pass := false;

   if pass then
      writeln(' PASS ... 6.7.2.5c, SET COMPARE')
   else
      writeln('FAIL ... 6.7.2.5c, SET COMPARE')
end;


{TEST 6.7.2.5d}
{Check the use of relational operators on pointers.
 only equality tests are allowed.
 The test fails if this procedure fails to compile, otherwise the test passes}
procedure c6p7p2p5d;
type pi = ^integer;
var
   p1, p2 :pi;
begin
   new(p1); p2 := nil;
   if (p1 <> p2) or (p2 = nil) then
      writeln(' PASS ... 6.7.2.5d, POINTER EQUALITY COMPARE');
   dispose(p1);
end;


{------- 6.7.3 Function-designators -------}

{TEST 6.7.3a}
{test that a function parameter can be used in an expression}
procedure c6p7p3a;
var
   pass: boolean;
function invert(ab: boolean): boolean;
begin
   invert := not ab;
end;
procedure p( function af(ab: boolean): boolean; var ab: boolean);
begin
   ab := af( false );
end;
begin
   pass := false;
   p(invert, pass);
   if pass then
      writeln(' PASS ... 6.7.3a, call function parameter')
   else
      writeln('FAIL ... 6.7.3a, call function parameter');
end; {c6p7p3a}


{------- 6.8 Statements -------}

{------- 6.8.1 General -------}

{TEST 6.8.1a}
{a goto statement is allowed to jump to a label iff the label prefixes a statement that:
-  contains the goto statement, or
-  is part of a sequence of statements that contain the goto statement, or
-  is at the outer level of a block that encloses the goto statement.
Check that the label is allowed in a statement that contains the goto statement}
procedure c6p8p1a;
label 1;
var
    pass: boolean;
begin
    pass := false;
1: {label for the statement that contains the goto }
    while not pass do begin
        pass := succ(pass);
        goto 1;
    end;

    if pass then
        writeln(' PASS ... 6.8.1a, GOTO')
    else
        writeln('FAIL ... 6.8.1a, GOTO');
end; {c6p8p1a}


{TEST 6.8.1b}
{Similar to test 6.8.1a, but now check that the label can prefix a statement that is
 part of a sequence of statements that contain the goto statement.}
procedure c6p8p1b;
label 1;
var
    pass: boolean;
begin
    pass := false;
    while not pass do begin
        pass := succ(pass);
        if pass then goto 1;
    end;

1: {label for statement that is part of the sequence of statements that contain the goto}
    if pass then
        writeln(' PASS ... 6.8.1b, GOTO')
    else
        writeln('FAIL ... 6.8.1b, GOTO');
end; {c6p8p1b}


{TEST 6.8.1c}
{Similar to test 6.8.1b,
 this time the label and goto have an extra level of nesting.}
procedure c6p8p1c;
label 1;
var
    pass: boolean;
begin
    pass := true;
    repeat
1:
        pass := not pass;
        if not pass then goto 1;
    until pass;

    if pass then
        writeln(' PASS ... 6.8.1c, GOTO')
    else
        writeln('FAIL ... 6.8.1c, GOTO');
end; {c6p8p1c}


{TEST 6.8.1d}
{check that the label can prefix a statement that is at the outer
 level of a block that encloses an interprocedural goto statement.
 see also 6.8.2.4a}
procedure c6p8p1d;
label 1;
var
    pass: boolean;
procedure p;
begin
    while not pass do begin
        pass := succ(pass);
        goto 1;
    end;
end;
begin {c6p8p1d}
    pass := false;
    p;
1: {label for statement that is at the outer level of a block that encloses the goto}
    if pass then
        writeln(' PASS ... 6.8.1d, GOTO')
    else
        writeln('FAIL ... 6.8.1d, GOTO');
end; {c6p8p1d}


{TEST 6.8.1e}
{Similar to test 6.8.1a, but now check that the label can prefix a compond statement.}
procedure c6p8p1e;
label 1;
var
    i   :integer;
begin
    i := 0;
    while i<4 do
1:
    begin
        i := i+1;
        if odd(i) then
            goto 1;
    end;
    if i=4 then
        writeln(' PASS ... 6.8.1e, GOTO')
    else
        writeln('FAIL ... 6.8.1e, GOTO');
end; {c6p8p1e}


{------- 6.8.2 Simple-statements -------}

{------- 6.8.2.1 General -------}


{TEST 6.8.2.1a}
{Does the compiler allow all the possible empty clauses? }
procedure c6p8p2p1a;
var
   b:boolean;
   r1:record
	 x:real;
	 a: integer; {1}
      end;
   r2:record
	 case b:boolean of
	 true: (
		  c:real;
		  d:char; {2}
	       );
	 false:   (e:integer); {3}
      end;
begin
   b := true;
   if b then; {4}
   if b then else; {5}
   repeat
      b := not b; {6}
   until b;
   while b do begin
      b := not b; {7}
   end;
   with r1 do; {8}
   r1.a := 1;
   case r1.a of
   0: b := false;
   1: ; {9}
   2: b := true; {1O}
   end;
   writeln(' PASS ... 6.8.2.1a, EMPTY STATEMENT'); {11}
end;


{------- 6.8.2.2 Assignment-statements -------}

{------- 6.8.2.3 Procedure-statements -------}


{------- 6.8.2.4 Goto-statements -------}


{TEST 6.8.2.4a}
{ Check that non-local goto statements are correctly implemented.
See also test 6.8.1c}
procedure c6p8p2p4a;
label 1;
var
   pass:boolean;
procedure setPass;
begin
   pass := true;
   goto 1;
end; {setPass}
begin
   setPass;
   pass := false;
1:
   if pass then
      writeln(' PASS ... 6.8.2.4a, NON-LOCAL GOTO')
   else
      writeln('FAIL ... 6.8.2.4a, NON-LOCAL GOTO');
end;


{------- 6.8.3 Structured-statements -------}

{------- 6.8.3.1 General -------}

{------- 6.8.3.2 Compound-statements -------}


{TEST 6.8.3.2a}
{ Check that a double semicolon is handled - it is really an empty statement }
procedure c6p8p3p2a;
var
   pass  : boolean;
begin
   pass := true;;
   if pass then
      writeln(' PASS ... 6.8.3.2a, double semicolon')
   else
      writeln('FAIL ... 6.8.3.2a, double semicolon')
end;


{TEST 6.8.3.4a}
{ Check that a dangling else statement pairs with the closest if statement
  that is otherwise unpaired }
procedure c6p8p3p4a;
var
   b1, b2:boolean;
   pass  : boolean;
begin
   pass := true;
   for b1 := false to true do
      for b2 := true downto false do
         if b1 then
            if b2 then
               pass := pass and b1 and b2
            else { this else should match "if b2 ..", not "if b1 .." }
               pass := pass and b1 and not b2;

   if pass then
      writeln(' PASS ... 6.8.3.4a, dangling else')
   else
      writeln('FAIL ... 6.8.3.4a, dangling else')
end;


{------- 6.8.3.5 Case-statements -------}


{TEST 6.8.3.5a}
{ Check that a minimal case statement will compile }
procedure c6p8p3p5a;
var
   i : integer;
begin
   i := 1;
   case i of
   1:
   end;
   writeln(' PASS ... 6.8.3.5a, CASE');
end;


{T8ST 6.8.3.5d}
{Check that a compiler handles a sparse case adequately }
procedure c6p8p3p5d;
var
   i,j : integer;
   pass: boolean;
begin
   i := -1000;
   pass := false;
   for j := 1 to 2 do
      case i of
      -1000: i := -i;
      1000: pass := true;
      end;
   if pass then
      writeln(' PASS ... 6.8.3.5d, SPARSE CASE')
   else
      writeln('FAIL ... 6.8.3.5d, SPARSE CASE');
end;


{TEST 6.8.3.7a}
{Check that a repeat loop is executed at least once }
procedure c6p8p3p7a;
var
   passStr: packed array[1..4] of char;
   done :boolean;
begin
   done := true;
   passStr := 'FAIL';
   repeat
      passStr := 'PASS';
      write(' ')
   until done;
   writeln( passStr, ' ... 6.8.3.7a, REPEAT loop executed once')
end;


{TEST 6.8.3.7b}
{Check that a loop containing no statements is executed until the expression is true }
procedure c6p8p3p7b;
const
   stop = 5;
var
   a:integer;
function done : boolean;
begin
   a := a+1;
   done := a>=stop;
end;
begin
   a := 0;
   repeat
   until done;
   if a=stop then
      writeln(' PASS ... 6.8.3.7b, EMPTY REPEAT')
   else
      writeln('FAIL ... 6.8.3.7b, EMPTY REPEAT');
end;


{TEST 6.8.3.7c}
{Check that an apparently infinite loop is allowed by the compiler }
procedure c6p8p3p7c;
label   100;
const
   eternity = false;
var
   i : integer;
begin
   i := 0;
   repeat
      i := i+1;
      if i>50 then
	 goto 100;
   until eternity;
100:
   writeln(' PASS ... 6.8.3.7c, REPEAT');
end;


{TEST 6.8.3.8a}
{Check that a while loop is not entered
if the initial value of the boolean expression is false }
procedure c6p8p3p8a;
var
   falseValue :boolean;
   rstr : packed array[1..5] of char;
begin
   falseValue := false;
   rstr := ' PASS';
   while falseValue do begin
      rstr := 'FAIL ';
      falseValue := false;
   end;
      writeln( rstr, ' ... 6.8.3.8a, WHILE');
end;


{TEST 6.8.3.8b}
{Check that a while loop containing no statements is accepted }
procedure c6p8p3p8b;
label 99;
const
   stop = 5;
var
   a:integer;
function bool:boolean;
begin
   a := a+1;
   bool := a>=stop;
   if a > stop+4 then
       goto 99;
end;
begin
   a := 0;
   while not bool do ;
99: {emergency escape route}
   if a=stop then
      writeln(' PASS ... 6.8.3.8b, EMPTY WHILE')
   else
      writeln('FAIL ... 6.8.3.8b, EMPTY WHILE');
end;


{------- 6.8.3.9 For-statements -------}

{TEST 6.8.3.9a}
{Check that assignnent follows the evaluation of both expressions in a for statement }
procedure c6p8p3p9a;
const
   test = 101;
   start = 11;
var
   i,j : integer;
begin
   i := start;
   j := 0;
   for i := (i+1) to (i+test) do begin
      j := j+i;
      {write(i, ' ');}
   end;
   if j=test*(2*start+test+1) div 2 then
      writeln(' PASS ... 6.8.3.9a, FOR')
   else
      writeln('FAIL ... 6.8.3.9a, FOR');
end;


{TEST 6.8.3.9g}
{Check that extreme values are correctly used in a for loop.
In particular, check that the succ test at the last increment
does not cause wraparound(overflow) - leading to an infinite loop }
procedure c6p8p3p9g;
label 9;
var
   i,j : integer;
begin
   j := 0;
   for i := (maxint-10) to maxint do begin
      j := j+1;
      if j > 50 then goto 9;
   end;
   for i := (-maxint+10) downto -maxint do begin
      j := j+1;
      if j > 50 then goto 9;
   end;

9:
   if j = 22 then
      writeln(' PASS ... 6.8.3.9g, FOR LOOP')
   else
      writeln('FAIL ... 6.8.3.9g, FOR LOOP');
end;


{TEST 6.8.3.9h}
{Check that a control variable of a for statement remains defined
if a goto statement exits a for statement }
procedure c6p8p3p9h;
label 100;
const
   c = 1;
var
   i,j :integer;
begin
   j := c;
   for i := j to j+10 do begin
      if j=c+5 then
	 goto 100;
      j := j+1;
   end;
100:
   if i=j then
      writeln(' PASS ... 6.8.3.9h, FOR')
   else
      writeln('FAIL ... 6.8.3.9h, FOR');
end;


{TEST 6.8.3.9o}
{Check the order of evaluation of the limit expressions in a for statement.}
procedure c6p8p3p9o;
const n = 15;
var
   i,j,k:integer;
function f( var k: integer ) : integer;
begin
   k := k+1;
   f := k;
end;

begin
   k := 0;
   j := 0;
   for i := f(k) to f(k)+n do begin
      j := j+i;
   end;
   if j = (n+3)*(n+2) div 2 then
      writeln(' PASS ... 6.8.3.9o, FOR')
   else
      writeln('FAIL ... 6.8.3.9o FOR');
end;


{TEST 6.8.3.9q}
{The standard says that the control variable of a for loop is not
assigned its initial value until the loop is entered.
Make the start value of a for loop higher than the end value so the loop is not entered.
The initial value is also above the allowed range of the control variable.
The loop should not be entered, and there should be no range error on the control variable.}
procedure c6p8p3p9q;
const
   n0=0; n1=12;
var
   i: n0..n1;
   j : integer;
begin
   j := 0;
   for i := n1+1 to n0 do   { i should not be initialised above upper limit of its range}
      j := j + i;

   if j=0 then
      writeln(' PASS ... 6.8.3.9q, FOR')
   else
      writeln('FAIL ... 6.8.3.9q, FOR');
end; {c6p8p3p9q}


{TEST 6.8.3.9r}
{similar to test 6.8.3.9q, but this time use a for ... downto loop }
procedure c6p8p3p9r;
const
   n0=0; n1=12;
var
   i: n0..n1;
   j : integer;
begin
   j := 0;
   for i := n0-1 downto n1 do   { i should not be initialised below lower limit of its range}
      j := j + i;

   if j=0 then
      writeln(' PASS ... 6.8.3.9r, FOR')
   else
      writeln('FAIL ... 6.8.3.9r, FOR');
end; {c6p8p3p9r}


{------- 6.8.3.10 With-statements -------}

{TEST 6.8.3.10a}
{Check the implementation of the with statement }
procedure c6p8p3p10a;
const
   checkValue = 5555;
var
   r1:record
	 a,b:integer
      end;
   r2:record
	 c,d:integer
      end;
   r3:record
	 e,f :integer
      end;
   pass: boolean;
begin
   with r1 do
      a := checkValue;
   with r1,r2,r3 do begin
      e := a;
      c := a
   end;
   pass := (r2.c=checkValue);
   with r2 do
      pass := pass and (c=checkValue);
   if pass then
      writeln(' PASS ... 6.8.3.10a, WITH')
   else
      writeln('FAIL ... 6.8.3.10a, WITH');
end;


{TEST 6.8.3.10b}
{Check that a field identifier is correctly identified when a with statement is invoked }
procedure c6p8p3p10b;
var
   r:record
	i,j : integer
     end;
   i: integer;
begin
   i := 10;
   with r do
      i := 5;
   if (i=10) and (r.i=5) then
      writeln(' PASS ... 6.8.3.10b, WITH')
   else
      writeln('FAIL ... 6.8.3.10b, WITH');
end;


{TEST 6.8.3.10c}
{ Check that the record-variable-list is evaluated in the correct order }
procedure c6p8p3p10c;
var
   r1: record
	  i,j,k: integer
       end;
   r2:record
	 i,j: integer
      end;
   r3: record
	  i:  integer
       end;
begin
   with r1 do begin
      i := 1;
      j := 1;
      k := 1
   end;
   with r2 do begin
      i := 2;
      j := 2
   end;
   with r3 do
      i := 3;
   with r1,r2,r3 do begin
      i := 5;
      j := 6;
      k := 7
   end;
   if(r1.i=1) and (r1.j=1) and (r2.i=2) and (r1.k=7)
	 and (r2.j=6) and (r3.i=5) then
      writeln(' PASS ... 6.8.3.10c, WITH EVALUATION')
   else
      writeln('FAIL ... 6.8.3.10c, WITH EVALUATION');
end;


{TEST 6.8.3.10d}
{ Check that the selection of a variable in the record-variable-list
is performed before the component statement is executed }
procedure c6p8p3p10d;
var
   a:array[1..2] of record
	   i,j :integer
	end;
   k : integer;
begin
   a[2].i := 5;
   k := 1;
   with a[k] do begin
      j := 1;
      k := 2;
      i := 2
   end;
   if (a[2].i=5) and (a[1].i=2) then
      writeln(' PASS ... 6.8.3.10d, WITH')
   else
      writeln('FAIL ... 6.8.3.10d, WITH');
end;


{TEST 6.8.3.10e}
{ Check that the selection of a variable in the record-variable-list
is performed before the component statement is executed }
procedure c6p8p3p10e;
type
   pointer = ^recordtype;
   recordtype = record
      data: integer;
      link:pointer
   end;
var
   counter: integer;
   p,q,t:pointer;
begin
   counter := 0;
   new(p);
   p^.data := 0;
   new(q);
   q^.data := 1;
   q^.link := nil;
   p^.link := q;
   q := p;
   t := p; {save link to first record}
   with q^ do begin
      q := link;
      if (data=0) and (q^.data=1) then
	 counter := counter+ 1;
   end;
   with p^ do begin
      p := link;  {now p & q both point  to second record}
      if (data=0) and (p^.data=1) then
	 counter := counter+1;
   end;
   dispose(p); dispose(t);
   if counter=2 then
      writeln(' PASS ... 6.8.3.10e, WITH')
   else
      writeln('FAIL ... 6.8.3.10e, WITH');
end;


{TEST 6.8.3.10f}
{Check that the order of evaluation of the record-variable-list
in a with statement is correctly implemented.}
procedure c6p8p1p10p6;
type
   pp = ^ptr;
   ptr = record
	    i : integer;
	    link:pp;
	 end;
var
   p,q,r : pp;
begin
   new(p);
   p^.i := 0;
   new(q);
   q^.i := 0;
   p^.link := q;
   new( r);
   r^.i := 0;
   r^.link := nil;
   q^.link := r;
   with p^.link^, link^ do begin
      i := 5;
   end;
   if ((r^.i=5) and (q^.i=0) and (p^.i=0)) then
      writeln(' PASS ... 6.8.3.10f, WITH')
   else
      writeln('FAIL ... 6.8.3.10f, WITH');
   dispose(p);
   dispose(q);
   dispose(r);
end;


{ ------- 6.9 Input and output ------- }

{ ------- 6.9.1 The procedure read ------- }

{TEST 6.9.1a}
{Check that a single read statement with many variables is
equivalent to many read statements containing one variable each }
procedure c6p9p1a;
var
   f :text;
   a,b,c,d,e: integer;
   a1,b1,c1,d1,e1:integer;
begin
   rewrite(f);
   writeln(f,' 1 2 3 4 5 ');
   reset (f);
   read(f,a,b,c,d,e);
   reset (f);
   read (f,a1);
   read (f,b1);
   read (f,c1);
   read (f,d1);
   read (f,e1);
   if (a=a1) and (b=b1) and (c=c1) and (d=d1) and (e=e1)
	 and (a=1) and (b=2) and (c=3) and (d=4) and (e=5) then
      writeln(' PASS ... 6.9.1a, READ TEXT')
   else
      writeln('FAIL ... 6.9.1a, READ TEXT');
end;


{TEST 6.9.1b}
{Check that a single read statement with many variables is
equivalent to many read statements inside a virtual begin .. end }
procedure c6p9p1b;
var
   f :text;
   a,b,c,d,e: integer;
begin
   rewrite(f);
   writeln(f,' 1 2 3 4 5 ');
   reset (f);
   a:=0; b:=0; c:=0; d:=0; e:=0;
   if eof(f) then
      read(f,a,b,c,d,e); {are they all part of the same virtual begin..end }
   if (a=0) and (b=0) and (c=0) and (d=0) and (e=0) then
      writeln(' PASS ... 6.9.1b, READ TEXT')
   else
      writeln('FAIL ... 6.9.1b, READ TEXT');
end;


{TEST 6.9.1c}
{Check that integers and reals are read correctly from a file }
procedure c6p9p1c;
var
   f :text;
   i,j:integer;
   x,y:real;
begin
{  equality tests on real numbers are OK here, since the numbers have been chosen
   to be exactly representable in ieee and probably other base 2 floating point formats }
   rewrite(f);
   writeln(f,' 123' );
   writeln(f, ' 123.5 5 123E6 ');
   reset(f);
   read(f, i, x, j, y);
   if (i=123) and (x=123.5) and (j=5) and (y=123E6) then
      writeln(' PASS ... 6.9.1c, READ TEXT')
   else begin
      if (i=123) and (j=5) then begin
	 writeln('FAIL ... 6.9.1c, READ REAL CONVERSIONS, x is ', x:10:3, ' y is ', y:10:3 );
      end
      else begin
	 writeln('FAIL ... 6.9.2c, READ, i is ', i, ' j is ', j )
      end;
   end;
end;


{TEST 6.9.1d}
{Check that a read statement with many variables evaluates the file variable exactly once.
This is similar to test 6.6.5.2k, but here we use a text file}
procedure c6p9p1d;
const n = 5;
var
   f : array[1..5] of text;
   i : integer;
begin
   for i := 2 to n do begin
      rewrite(f[i]);
      write( f[i], n, n, n);
      reset( f[i] );
   end;

   i := 1;
   rewrite(f[i]);
   writeln(f[i],' 4 3 2 ');
   reset (f[i]);
   read(f[i], i, i, i );
   if i = 2 then
      writeln(' PASS ... 6.9.1d, READ TEXT FILE VARIABLE')
   else
      writeln('FAIL ... 6.9.1d, READ TEXT FILE VARIABLE, i is ', i:1);
end;


{TEST 6.9.1e}
{Check that a read of a character variable is
equivalent to correctly positioning the buffer variable }
procedure c6p9p1e;
var
   f :text;
   a,b,a1,b1,c:char;
begin
   rewrite(f);
   writeln(f,'ABC');
   reset (f);
   read (f,a);
   read (f,b);
   read (f,c);
   read (f,c);
   reset (f);
   a1 := f^; get(f);
   b1 := f^; get(f);
   if (a=a1) and (b=b1) and (a='A') and (b='B') and (c=' ') then
      writeln(' PASS ... 6.9.1e, READ TEXT')
   else
      writeln('FAIL ... 6.9.1e, READ TEXT');
end;


{TEST 6.9.2a}
{Check that readln is correctly implemented for text files }
procedure c6p9p2a;
var
   f :text;
   a,b,c:char;
   pass: boolean;
begin
   pass := true;
   rewrite(f);
   writeln(f,'ABC');
   writeln(f,'DE');

   reset(f);
   readln(f,a,b,c);
   read (f,a);
   if a <> 'D' then pass := false;

   reset(f);
   read (f,a,b,c);
   readln(f);
   read (f,a);
   if a <> 'D' then pass := false;

   reset(f);
   read (f,a);
   while not eoln(f) do get(f);
   get(f);
   if f^<>'D' then pass := false;

   reset(f);
   read(f,a,b,c);
   read(f,a); {read eoln char}
   if a <> ' ' then begin pass := false; {writeln('test 4 failed');} end;
   if eoln(f) then begin pass := false; {writeln('test 5 failed');} end;
   readln(f);
   if not eof(f) then begin pass := false; {writeln('test 6 failed');} end;

   reset(f);
   read(f,a,b,c);
   if f^ <> ' ' then pass := false; {fetch eoln char}
   readln(f);
   if f^ <> 'D' then begin pass := false; {writeln('test 7 failed');} end;

   reset(f);
   read(f,a,b,c);
   readln(f);
   if f^ <> 'D' then begin pass := false; {writeln('test 8 failed');} end;

   if pass then
      writeln(' PASS ... 6.9.2a, READLN')
   else
      writeln('FAIL ... 6.9.2a, READLN');
end;


{ ------- 6.9.3 The procedure write ------- }

{TEST 6.9.3a}
{ Check that a write procedure with many parameters
  is equivalent to many write procedures with one parameter each }
procedure c6p9p3a;
const
   a = 'A'; b = 'B'; c = 'C';
var
   f:text;
   a1,b1,c1:char;
   pass: boolean;

function bc: char;
begin
   write(f, b);
   bc := c;
end;

begin
   rewrite(f);
   {output will be 'bac' if a & bc are combined into a single parameter ...}
   write(f, a, bc);
   writeln(f);
   reset(f);
   if not eof(f) then
      read(f,a1,b1,c1);
   pass := (a=a1) and (b=b1) and (c=c1);
   rewrite(f);
   write(f,a);
   write(f,b);
   write(f,c);
   writeln(f);
   reset(f);
   if not eof(f) then
      read(f,a1,b1,c1);
   pass := pass and (a1=a) and (b1=b) and (c1=c);
   if pass then
      writeln(' PASS ... 6.9.3a, WRITE PARAMETERS')
   else
      writeln('FAIL ... 6.9.3a, WRITE PARAMETERS');
end;


{TEST 6.9.3b}
{ Check that a write procedure with many parameters
  is equivalent to many write procedures inside begin .. end }
procedure c6p9p3b;
const
   a = 'A'; b = 'B'; c = 'C';
var
   f:text;
begin
   rewrite(f);
   if not eof(f) then
      write(f, a, b, c);   {are all these params inside a begin .. end?}

   reset(f);
   if eof(f) then
      writeln(' PASS ... 6.9.3b, WRITE PARAMETERS')
   else
      writeln('FAIL ... 6.9.3b, WRITE PARAMETERS');
end;


{TEST 6.9.3c}
{Check that a write statement with many variables evaluates the file variable exactly once.
This is similar to test  6.6.5.2l, but this time use a text file}
procedure c6p9p3c;
var
   f : array[1..5] of text;
   i : integer;
   i1, i2, i3, i4: integer;

function side: integer;
begin
   i := i+1;
   side := i;
end;

begin
   for i1 := 1 to 5 do
      rewrite(f[i1]);
   i := 1;
   rewrite(f[i]);
   write(f[i], side:4, side:4, side:4, side:4);
   if i <> 5 then
      writeln( 'test 6.9.3b internal error' );
   reset (f[1]);
   i1 := 0; i2 := 0; i3 := 0; i4 := 0;
   if not eof( f[1] ) then read(f[1], i1 );
   if not eof( f[1] ) then read(f[1], i2 );
   if not eof( f[1] ) then read(f[1], i3 );
   if not eof( f[1] ) then read(f[1], i4 );
   if (i1=2) and (i2=3) and (i3=4) and (i4=5) then
      writeln(' PASS ... 6.9.3c, write file variable')
   else
      writeln('FAIL ... 6.9.3c, write file variable');
end;


{TEST 6.9.3m}
{ This procedure attempts to perform recursive I/O using a
different file for the second I/O action }
procedure c6p9p3m;
var
   f :text;
function a (i: integer) :char;
begin
   writeln(f, i);
   a := 'P';
end;
begin
   rewrite(f);
   writeln( ' ', a(1), 'ASS ... 6.9.3m, RECURSIVE I/O');
   {writeln(' RECURSIVE I/O ALLOWED USING DIFFERENT FILES');}
end;


{TEST 6.9.3o}
{Check that a write that does not specify the file
always writes on the default file at the procedure level,
 not any local variable with the same name }
procedure c6p9p3o;
var
   ch: char;
procedure test;
var
   output :text;
begin
   rewrite(output);
   writeln(output,'FAIL ... 6.9.3o write to output');
   writeln(' PASS ... 6.9.3o, write to output');
   reset(output);
   if not eof(output) then
      read(output,ch);
end;
begin
   ch := '?';
   test;
   if ch <> 'F' then
      writeln(output,'FAIL ... 6.9.3o write to output');
end;


{ ------- 6.9.3.2 Char-type ------- }

{TEST 6.9.3.2b}
{ Check that the defau1t value for the field width of a character type is one }
procedure c6p9p3p2b;
var
   f :text;
   a,b:char;
begin
   rewrite(f);
   writeln(f, 'A', 'B');
   a := '?'; b := '?';
   reset(f);
   if not eof(f) then
      read (f,a,b);
   if (a='A') and (b='B') then
      writeln(' PASS ... 6.9.3.2b, WRITE CHAR FIELD WIDTH')
   else
      write('FAIL ... 6.9.3.2b, WRITE CHAR FIELD WIDTH');
end;


{ ------- 6.9.3.3 Integer-type ------- }

{TEST 6.9.3.3c}
{ Check the implementation of integer output }
procedure c6p9p3p3c;
var
   f :text;
   b:packed array [1 .. 26] of char;
   i: integer;
begin
   rewrite(f);
   writeln(f, 0:3, 1:3, -1:3, 10:3, 99:3, 100:3, -100:3, 1111:3);
   reset(f);
   for i := 1 to 26 do
      if not eof(f) then
         read(f, b[i]);
   if b = '  0  1 -1 10 99100-1001111' then
      writeln(' PASS ... 6.9.3.3c, WRITE INTEGERS')
   else
      writeln('FAIL ... 6.9.3.3c, WRITE INTEGERS, b is >', b, '<');
end;


{ ------- 6.9.3.4 Real-type ------- }

{TEST 6.9.3.4c}
{Check that real numbers in floating point format are correctly written to text files }
procedure c6p9p3p4c;
const
   na = 22;
var
   f :text;
   a:packed array [1 .. na] of char;
   b:packed array [1..24] of char;
   s : packed array[1..7] of char;
   i : integer;
   pass : boolean;
   expDigits : integer;
   c : char;
   done : boolean;
begin
   pass := true;
   rewrite(f);
   writeln(f, 100.0);
   reset(f);
   done := false;
   expDigits := 0;
   while not done and pass do begin
      if (eof(f) or eoln(f)) then begin
         done := true;
         pass := false;
      end
      else begin
         read( f, c );
         if (c = 'e') or (c='E') then begin
            read( f, c );
            if c <> '+' then
               pass := false;
            while not (eof( f ) or eoln(f)) do begin
               expDigits := expDigits+1;
               read( f, c );
            end;
            {writeln( 'real nrs have ', expDigits:1, ' exponent digits, '  );}
            done := true;
         end;
      end;
      if not pass then
         writeln( 'fail, real nr not in floating point format' );
   end;

   { test floating point format, ie -1.2e+56, ls digit should be rounded }
   rewrite(f);
   writeln(f, 108.0:expDigits+5 );  { total width is too small }
   writeln(f, -108.0:expDigits+6 ); { min total width }
   writeln(f, 0.108:expDigits+7 );  { extra decimal place }
   writeln(f, 0.0:expDigits+6 );    { special value }

   { expect a leading space or sign, number rounded, total width >= 6+expDigits }
   reset( f );
   for i := 1 to 6 do
      if not eoln(f) then
         read( f, s[i] )
      else
         s[i] := ' ';
   s[7] := ' ';
   if s[5] = 'E' then
      s[5] := 'e';

   if s = ' 1.0e+ ' then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4c(1), WRITE REAL floating point number is truncated, but should be rounded');
   end
   else if s <> ' 1.1e+ ' then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4c(1), WRITE REAL floating point format, s is ''', s, '''');
   end;
   read( f, i );
   if i <> 2 then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4c(2), WRITE REAL floating point format exp is ', i:1);
   end;
   if not eoln(f) then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4c(3), WRITE REAL floating point format');
   end;
   readln( f );

   for i := 1 to 6 do
      if not eoln(f) then
         read( f, s[i] )
      else
         s[i] := ' ';
   s[7] := ' ';
   if s[5] = 'E' then
      s[5] := 'e';
   if s <> '-1.1e+ ' then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4c(4), WRITE REALS floating point format, s is ', s);
   end;
   read( f, i );
   if i <> 2 then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4c(5), WRITE REALS floating point format, exp is ', i:1);
   end;
   if not eoln(f) then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4c(6), WRITE REALS floating point format');
   end;
   readln( f );

   for i := 1 to 7 do
      if not eoln(f) then
         read( f, s[i] )
      else
         s[i] := ' ';
   if s[6] = 'E' then
      s[6] := 'e';
   if s <> ' 1.08e-' then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4c(7), WRITE REALS floating point format, s is ', s);
   end;
   read( f, i );
   if i <> 1 then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4c(8), WRITE REALS floating point format, exp is ', i:i);
   end;
   if not eoln(f) then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4c(9), WRITE REALS floating point format');
   end;
   readln( f );

   for i := 1 to 6 do
      if not eoln(f) then
         read( f, s[i] )
      else
         s[i] := ' ';
   s[7] := ' ';
   if s[5] = 'E' then
      s[5] := 'e';
   if s <> ' 0.0e+ ' then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4c(10), WRITE REALS floating point format, s is ', s);
   end;
   read( f, i );
   if i <> 0 then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4c(11), WRITE REALS floating point format exp is ', i:1);
   end;
   if not eoln(f) then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4c(12), WRITE REALS floating point format');
   end;

   if pass then
      writeln(' PASS ... 6.9.3.4c, WRITE REALS')
end;


{TEST 6.9.3.4d}
{Check that real numbers in floating point format are correctly written to text files }
procedure c6p9p3p4d;
const
   na = 22;
var
   f :text;
   a:packed array [1 .. na] of char;
   b:packed array [1..24] of char;
   s : packed array[1..7] of char;
   i : integer;
   pass : boolean;
   c : char;
   done : boolean;
begin
   pass := true;

   { test fixed point reals: spaces[-]nnn.ddd }
   rewrite(f);
   writeln( f, 0.0:2:1, 'x', 0.0:3:1, 0.0:4:1, 0.0:5:1 );
   writeln( f, 0.0:3:2, 'y', 0.0:4:2, 0.0:5:2, 0.0:8:2 );
   writeln( f, 0.06:2:1, 'z', -0.06:3:1, 0.06:7:1, -0.06:7:1 );
   writeln( f, 100.04:4:1, 'v', -100.04:7:3 );
   writeln( f, 200.04:5:1, 'w', -200.04:8:3 );
   writeln( f, 100.04:6:1,  -100.04:9:3 );

   reset(f);
   for i := 1 to na do begin
      if not eoln(f) then
         read(f, a[i])
      else
         a[i] := '_';
   end;
   if a <> '0.0x0.0 0.0  0.0______' then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4d(1), WRITE REALS fixed point format' );
   end;
   readln(f);
   for i := 1 to na do begin
      if not eoln(f) then
         read(f, a[i])
      else
         a[i] := '_';
   end;
   if a <> '0.00y0.00 0.00    0.00' then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4d(2), WRITE REALS fixed point format' );
   end;
   readln(f);
   for i := 1 to na do begin
      if not eoln(f) then
         read(f, a[i])
      else
         a[i] := '_';
   end;
   if a <> '0.1z-0.1    0.1   -0.1' then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4d(3), WRITE REALS fixed point format' );
   end;
   readln(f);
   for i := 1 to na do begin
      if not eoln(f) then
         read(f, a[i])
      else
         a[i] := '_';
   end;
   if a <> '100.0v-100.040________' then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4d(4), WRITE REALS fixed point format' );
   end;
   readln(f);
   for i := 1 to na do begin
      if not eoln(f) then
         read(f, a[i])
      else
         a[i] := '_';
   end;
   if a <> '200.0w-200.040________' then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4d(5), WRITE REALS fixed point format' );
   end;
   readln(f);
   for i := 1 to na do begin
      if not eoln(f) then
         read(f, a[i])
      else
         a[i] := '_';
   end;
   if a <> ' 100.0 -100.040_______' then begin
      pass := false;
      writeln( 'FAIL ... 6.9.3.4d(6), WRITE REALS fixed point format' );
   end;


   rewrite(f);
   writeln(f, 0.0:6:1, 1.0:6:1, 1.0:10);
   reset (f);
   for i := 1 to na do begin
      if not eof(f) then
         read(f,a[i]);
   end;
   { account for 3-digit exponents }
   if a[19] = 'e' then
      a[19] := 'E';
   if a[18] = 'e' then
      a[18] := 'E';
   if (a <> '   0.0   1.0 1.000E+00') and (a <> '   0.0   1.0 1.00E+000') then begin
      pass := false;
      writeln('FAIL ... 6.9.3.4d, WRITE REALS: a is ''', a, '''' );
   end;

   rewrite(f);
   writeln( f, 0.0:4:1, 1.0:6:1, -1.0:6:1, 123.456:8:3 );
   reset(f);
   for i := 1 to 24 do
      if not eof(f) then
         read(f,b[i]);
   if b <> ' 0.0   1.0  -1.0 123.456' then begin
      pass := false;
      writeln('FAIL ... 6.9.3.4d, WRITE REALS, b is ''', b, '''' );
   end;

   if pass then
      writeln(' PASS ... 6.9.3.4d, WRITE REALS')
end;


{ ------- 6.9.3.5 Boolean-type ------- }

{TEST 6.9.3.5g}
{Check that boolean variables are correctly written to text files }
procedure c6p9p3p5g;
const
   strlen = 12;
var
   f :text;
   b,c :boolean;
   a:packed array[1 .. strlen] of char;
   i: integer;
begin
   rewrite(f);
   b := true;
   c := not b;
   writeln(f, b:6, c:(strlen-6));
   reset (f);
   if not eof(f) then
      for i := 1 to strlen do begin
         read(f,a[i] );
         if ('a' <= a[i]) and (a[i] <= 'z') then             {convert to upper case}
            a[i] := chr( ord('A') -ord('a') + ord(a[i]) );
      end;
   if a = '  TRUE FALSE' then
      writeln(' PASS ... 6.9.3.5g, WRITE BOOLEAN')
   else
      writeln('FAIL ... 6.9.3.5g, WRITE BOOLEAN, a is ''', a, '''');
end;


{ ------- 6.9.3.6 String-types ------- }

{TEST 6.9.3.6e}
{Check that strings with a width specifier are correctly written to a text file }
procedure c6p9p3p6e;
var
   f    :text;
   i,j,k:integer;
   c    :char;
   pass : boolean;
begin
   rewrite(f);
   pass := true;
   for i := 1 to 10 do
      writeln( f, 'AAAAA':i, 'X':1 );

   reset ( f);
   for i := 1 to 10 do begin
      for j := 6 to i do begin  {check leading spaces}
         read(f,c);
         if c <> ' ' then
            pass := false;
      end;
      if i>5 then k := 5 else k := i;
      for j := 1 to k do begin {up to 5 'A' chars}
         read (f,c);
         if c <> 'A' then
            pass := false;
      end;
      read (f,c);         {expect end mark here}
      if C <> 'X' then
         pass := false;
      if not eoln(f) then
         pass := false;
      readln( f);
   end;

   if pass then
      writeln(' PASS ... 6.9.3.6e, WRITE STRINGS')
   else
      writeln('FAIL ... 6.9.3.6e, WRITE STRINGS');
end;


{TEST 6.9.3.6f}
{Check that a string with no width specifier is correctly written to a text file }
procedure c6p9p3p6f;
var
   f    :text;
   i    :integer;
   c    :char;
   pass : boolean;
begin
   rewrite(f);
   pass := true;
   writeln( f, 'BBBBB', 'Y':1 );

   reset ( f);
   for i := 1 to 5 do begin
      read(f,c);
      if c <> 'B' then
         pass := false;
   end;
   read (f,c);
   if c <> 'Y' then
      pass := false;
   if not eoln(f) then
      pass := false;

   if pass then
      writeln(' PASS ... 6.9.3.6f, WRITE STRINGS')
   else
      writeln('FAIL ... 6.9.3.6f, WRITE STRINGS');
end;


{TEST 6.9.4a}
{Check the implementation of procedure writeln }
procedure c6p9p4a;
const
   n = 10;
var
   f :text;
   a,b:packed array[1 .. n] of char;
   i :integer;
begin
   rewrite(f);
   writeln(f, 1:5, 'ABCDE');
   write(f, 1:5, 'ABCDE');
   writeln(f);
   reset(f);
   for i := 1 to n do
      if not eof(f) then
         read(f, a[i]);
   reset (f);
   for i := 1 to n do
      if not eof(f) then
         read (f, b[i]);
   if a=b then
      writeln(' PASS ... 6.9.4a, WRITELN')
   else
      writeln('FAIL ... 6.9.4a, WRITELN');
end;


{TEST 6.9.5a}
{ TODO: check that eoln is added when necessary }
{Check that the procedure page is implemented.
This conformance test is unable to determine whether the compiler passes or fails
If the compiler appears to use the ascii char set, and page() writes formfeed, then
the test passes, otherwise the user must check that a page has been generated }
procedure c6p9p5a;
type
   hexDigit = 0..15;
var
   f  :text;
   ch : char;
   pass : boolean;
function wrhex( d: hexDigit) : char;
begin
   if d <= 9 then
      wrhex := chr(ord('0') + d)
   else
      wrhex := chr(ord('a') + d - 10)
end;
begin
   pass := false;
   if (chr(65) = 'A') and (chr(48) = '0') then begin  { assume ascii }
      { writeln( 'assuming ascii char set', ord('A'), ord('0') ); }
      rewrite(f);
      page (f) ;
      reset(f);
      if not eof(f) then
	 if not eoln(f) then begin
	    read(f, ch);
	    if ch = chr(12) then
	       pass := true;
	 end;
   end;

   if pass then
      writeln( ' PASS ... 6.9.5a, PAGE')
   else begin
      writeln(' PAGE GENERATION TEST');
      page(output);
      writeln( ' IF THIS LINE IS PRINTED ON THE TOP OF A NEW PAGE');
      writeln( ' THEN PASS ... 6.9.5a, PAGE');
      writeln( ' ELSE FAIL ... 6.9.5a, PAGE');
   end;

end;


begin

   initialise;

   c6p1p2c;
   c6p1p3a;
   c6p1p3b;
   c6p1p5a;
   c6p1pSb;
   c6p1p6a;
   c6p1p6b;
   c6p1p7a;
   c6p1p7b;
   c6p1p7c;
   c6p1p8a;
   c6p1p8b;
   c6p1p8c;
   c6p1p8d;
   c6p1p8e;
   c6p1p8f;
   c6p1p8g;
   c6p2p1a;
   c6p2p1b;
   c6p2p1f;
   c6p2p2b;
   c6p2p2c;
   c6p2p2f;
   c6p2p2h;
   c6p2p2j;
   c6p2p2k;
   c6p2p2l;
   c6p2p2p5a;
   c6p2p2p5e;
   c6p3a;
   c6p4p1a;
   c6p4p2p2a;
   c6p4p2p2b;
   c6p4p2p2c;
   c6p4p2p2d;
   c6p4p2p2e;
   c6p4p2p2f;
   c6p4p2p3a;
   c6p4p2p3b;
   c6p4p2p4a;
   c6p4p3p1c;
   c6p4p3p2a;
   c6p4p3p2b;
   c6p4p3p2c;
   c6p4p3p2d;
   c6p4p3p3a;
   c6p4p3p3b;
   c6p4p3p3c;
   c6p4p3p3d;
   c6p4p3p3j;
   c6p4p3p3m;
   c6p4p3p3n;
   c6p4p3p4a;
   c6p4p3p5a;
   c6p4p3p5b;
   c6p4p3p5c;
   c6p4p3p5d;
   c6p4p4a;
   c6p4p5a;
   c6p4p5f;
   c6p4p5g;
   c6p4p5h;
   c6p4p5i;
   c6p4p5l;
   c6p4p6a;
   c6p4p6b;
   c6p4p6c;
   c6p5p1a;
   c6p5p3p2b;
   c6p5p5a;
   c6p5p5b;
   c6p6p1a;
   c6p6p1b;
   c6p6p2a;
   c6p6p2b;
   c6p6p2c;
   c6p6p2d;
   c6p6p2e;
   c6p6p2g;
   c6p6p3p1a;
   c6p6p3p1b;
   c6p6p3p1c;
   c6p6p3p1e;
   c6p6p3p3a;
   c6p6p3p2a;
   c6p6p3p2e;
   c6p6p3p3b;
   c6p6p3p3c;
   c6p6p3p4a;
   c6p6p3p4b;
   c6p6p3p4c;
   c6p6p3p4d;
   c6p6p3p5a;
   c6p6p3p5b;
   c6p6p4p1a;
   c6p6p5p2c;
   c6p6p5p2d;
   c6p6p5p2e;
   c6p6p5p2h;
   c6p6p5p2i;
   c6p6p5p2k;
   c6p6p5p2l;
   c6p6p5p3a;
   c6p6p5p3b;
   c6p6p5p4a;
   c6p6p5p4j;
   c6p6p6p2a;
   c6p6p6p2b;
   c6p6p6p2c;
   c6p6p6p3a;
   c6p6p6p4a;
   c6p6p6p4b;
   c6p6p6p4c;
   c6p6p6p5a;
   c6p6p6p5b;
   c6p7p1a;
   c6p7p1b;
   c6p7p1c;
   c6p7p1d;
   c6p7p1e;
   c6p7p1f;
   c6p7p1g;
   c6p7p2p1a;
   c6p7p2p2a;
   c6p7p2p2b;
   c6p7p2p2e;
   c6p7p2p3a;
   c6p7p2p4a;
   c6p7p2p4b;
   c6p7p2p4c;
   c6p7p2p5a;
   c6p7p2p5b;
   c6p7p2p5c;
   c6p7p2p5d;
   c6p7p3a;
   c6p8p1a;
   c6p8p1b;
   c6p8p1c;
   c6p8p1d;
   c6p8p1e;
   c6p8p2p1a;
   c6p8p2p4a;
   c6p8p3p2a;
   c6p8p3p4a;
   c6p8p3p5a;
   c6p8p3p5d;
   c6p8p3p7a;
   c6p8p3p7b;
   c6p8p3p7c;
   c6p8p3p8a;
   c6p8p3p8b;
   c6p8p3p9a;
   c6p8p3p9g;
   c6p8p3p9h;
   c6p8p3p9o;
   c6p8p3p9q;
   c6p8p3p9r;
   c6p8p3p10a;
   c6p8p3p10b;
   c6p8p3p10c;
   c6p8p3p10d;
   c6p8p3p10e;
   c6p8p1p10p6;
   c6p9p1a;
   c6p9p1b;
   c6p9p1c;
   c6p9p1d;
   c6p9p1e;
   c6p9p2a;
   c6p9p3a;
   c6p9p3b;
   c6p9p3c;
   c6p9p3m;
   c6p9p3o;
   c6p9p3p2b;
   c6p9p3p3c;
   c6p9p3p4d;
   c6p9p3p4c;
   c6p9p3p5g;
   c6p9p3p6e;
   c6p9p3p6f;
   c6p9p4a;
   c6p9p5a;
   c6p4p3p5e;  { this must be last TODO: include completed message & failure count }

end. { conformant }

{kate: debugMode on; cfgIndentCase false;}
