{
# // force cpp
   test:
- underscores and dollars in ids
- hex numbers
- // style comments
- mixed declarations
- maxreal, minreal, epsreal, maxchar
- timestamp
- eponentiation operator
- bit operations
- assign(f,s)
- case statements
- pred/succ
- file extend
- constant expressions
}


{$d-,v-}
program tp5x( output );

#include "sys.inc.pas"

// mixed declarations
var f:text;
const fname = 't1.txt';

const slen=100;
var str : packed array[1..slen] of char;
   i    : 0..maxint;

type
   colour = ( black, brown, red, orange, yellow, green, blue, violet, grey, white);
const
   first_colour =  black; last_colour =  white;

type   colour_bands = array[1..3] of colour;

var
   r1, r2 : colour_bands;
   s      : integer;
   x      : real;
   pass   : boolean;

procedure inline; inline;
   function inline(a : boolean): real; forward;
   function inline; inline;
   begin
      writeln('inlined function');
      inline := 12;
   end; { inline }
begin
   writeln('inlined procedure');
end; { inline }


function wrHex(i :  integer) : char;
var
   lastCh :  char;
procedure convert(i: integer);
begin
   if i < 0 then begin
      convert((i+1) div 16 + maxint div 8);
      convert((i + maxint + 1) mod 16)
   end
   else if i < 10 then begin
      write(lastCh);
      lastCh := chr(i + ord('0'))
   end
   else if i < 16 then begin
      write(lastCh);
      lastCh := chr(i + ord('a') - 10);
   end
   else begin
      convert(i div 16);
      convert(i mod 16);
   end;
end; { convert }
begin
   lastCh := '$';
   convert(i);
   wrHex := lastCh
end; { wrHex }


procedure mixedDec;
{ test forward references for functions }
{ test forward references for pointers }

function f(ai :  integer): boolean; forward;

var
   c      : colour;

type
   prec1 = ^rec1;
   rec1 = record
             s    : packed array[1..8] of char;
             link : ^rec2;
          end;
   rec2 = record
             s2    : packed array[1..8] of char;
             link2 : prec1;
          end;
const
   cc =  13;

function f;
begin
   f := ai = cc;
end; { f }

var
   pr : prec1;

begin

   if first_colour <> black then begin
      pass := false;
      writeln( 'mixed dec test 1 fails, mixed declarations' );
   end;

   if last_colour <> white then begin
      pass := false;
      writeln( 'mixed dec test 2 fails, mixed declarations' );
   end;

   x := 0;
   for c := last_colour downto first_colour do
      x := 10*x + ord(c);

   if x <> 9876543210.0 then begin
      pass := false;
      writeln( 'mixedDec test 3 fails, mixed declarations, x is ', x:1:1 );
   end;

   new(pr);
   with pr^ do begin
      s := 'record 1';
      new(link);
   end;
   with pr^.link^ do begin
      s2 := 'record 2';
      link2 := pr;
   end;

   if pr^.link^.link2^.s <> 'record 1' then begin
      pass := false;
      writeln( 'mixedDec pointer ref test 1 failed' );
   end;

   if pr^.link^.link2^.link^.s2 <> 'record 2' then begin
      pass := false;
      writeln( 'mixedDec pointer ref test 2 failed' );
   end;

   dispose(pr^.link);
   dispose(pr);

   if not f(cc) then begin
      pass := false;
      writeln( 'forward ref test failed' );
   end;

end; { mixedDec }

const m1 =
//comment
-
//comment
   1;

m2 = //comment
//comment
- //comment
   2;


   c1 =
   //
   $10;

var
   id_with_underscores : boolean;
   id_withunderscores  : boolean;
   id$with$dollars     : boolean;
   id$withdollars      : boolean;

// this is a comment
//

{ test hex and bit operations }
{ NOTE: some of these tests assume:
          - 32 bit integers
          - twos complement arithmetic }
procedure testHexnum;
var
   i : integer;
begin
   i := $abcdef;
   if i <> ((((10*16 +11)*16 + 12)*16 + 13)*16 +14)*16 + 15 then begin
      pass := false;
      writeln( 'hex num value test fails' );
   end;

   if $ABCDEF <> $abcdef then begin
      pass := false;
      writeln( 'hex num case test fails' );
   end;

   if $101 <> 257 then begin
      pass := false;
      writeln( 'hexnum test 1 fails' );
   end;

   if $000000000000001 <> 1 then begin
      pass := false;
      writeln( 'hexnum test 2 fails' );
   end;

   if $000000000000000 <> 0 then begin
      pass := false;
      writeln( 'hexnum test 3 fails' );
   end;

   if $7fffffff <> maxint then begin
      pass := false;
      writeln( 'hexnum test 4 fails' );
   end;

   if $ffffffff <> -1 then begin
      pass := false;
      writeln( 'hexnum test 5 fails' );
   end;

   if $fffffff0 <> -16 then begin
      pass := false;
      writeln( 'hexnum test 6 fails' );
   end;

   if $ffffffef <> -17 then begin
      pass := false;
      writeln( 'hexnum test 7 fails' );
   end;

   if $80000000+ord(odd(maxint)) <> -maxint then begin
      pass := false;
      writeln( 'hexnum test 8 fails' );
   end;

   if $80000001 <> -maxint then begin
      pass := false;
      writeln( 'hexnum test 9 fails' );
   end;


   if $80000002 <> -maxint+1 then begin
      pass := false;
      writeln( 'hexnum test 10 fails' );
   end;

   if $8000000f <> -maxint+14 then begin
      pass := false;
      writeln( 'hexnum test 11 fails' );
   end;

   if bitand( $f0f0, $ff00) = $f000 then
      i := bitand( i, $ff0f)  // i = $cd0f
   else begin
      pass := false;
      writeln( 'and test fails' );
   end;

   if bitor( $f0f0, $ff00) = $fff0 then
      i := bitor( i, $ff00)  // i = $ff0f
   else begin
      pass := false;
      writeln( 'or test fails' );
   end;

   if bitxor( $f0f0, $ff00) = $0ff0 then
      i := bitxor( i, $ff00)  // i = $000f
   else begin
      pass := false;
      writeln( 'xor test fails' );
   end;

   if bitnot( 0 ) = -1 then
      i := bitnot( i )  // i = $fffffff0
   else begin
      pass := false;
      writeln( 'complement test 1 fails' );
   end;

   if bitnot( -1 ) <> 0 then begin
      pass := false;
      writeln( 'complement test 2 fails' );
   end;

   if bitnot( $f0f0 ) <> $ffff0f0f then begin
      pass := false;
      writeln( 'complement test 3 fails' );
   end;

   if bitnot( maxint-1 ) <> -maxint then begin
      pass := false;
      writeln( 'complement test 4 fails' );
   end;

   if rshift( $f0, -4 ) = $f00 then
      i := rshift(i, -4) // i := $ffffff00
   else begin
      pass := false;
      writeln( 'shift right test 1 fails, ', rshift( $f0, -4 ):1);
   end;

   if rshift( $f0, 4 ) <> $f then begin
      pass := false;
      writeln( 'shift right test 2 fails' );
   end;

   if rshift( $f0, 0 ) <> $f0 then begin
      pass := false;
      writeln( 'shift right test 3 fails' );
   end;

   if rshift( -1, 4 ) <> -1 then begin
      pass := false;
      writeln( 'shift right test 4 fails' );
   end;

   if rshiftu( $f0, -4 ) = $f00 then
      i := rshiftu(i, -4) // i = $fffff000
   else begin
      pass := false;
      writeln( 'shift right unsigned test 1 fails, ', rshiftu( $f0, -4 ) );
   end;

   if rshiftu( $f0, 4 ) = $f then
      i := rshiftu(i, -4) // i = $ffff0000
   else begin
      pass := false;
      writeln( 'shift right unsigned test 2 fails' );
   end;

   if i <> $ffff0000 then begin
      pass := false;
      writeln( 'bit operations fail, i is ''', wrhex(i), '''' );
   end;


   if rshiftu( $f0, 0 ) <> $f0 then begin
      pass := false;
      writeln( 'shift right unsigned test 3 fails' );
   end;

   if rshiftu( $ffffffff, 4 ) <> $0fffffff then begin
      pass := false;
      writeln( 'shift right unsigned test 4 fails' );
   end;

   if rshiftu(-1,1) <> maxint then begin
      pass := false;
      writeln( 'shift right unsigned test 5 fails' );
   end;

   if rshiftu(-1,-4) <> -16 then begin
      pass := false;
      writeln( 'shift right unsigned test 6 fails' );
   end;

end; { testHexnum }


{ test plausability of maxreal, etc }
procedure realtest;
const eps = epsreal;
const negeps = -eps;
var x1, x2 :  real;
begin
   if (1+epsreal <> 1) and (2+epsreal = 2) then
      writeln( 'epsreal is ', epsreal )
   else begin
      pass := false;
      writeln( 'fail: epsreal test' );
   end;

   x2 := minreal/2;
   if x2 = 0 then
      writeln( 'minreal is ', minreal, ' (no normalising)' )
   else begin
      x1 := -minreal*negeps; x2 := x2*eps;
      if (x1 > 0) and  (x2 <= 0) then
         writeln( 'minreal is ', minreal, ' (before normalising)' )
      else begin
         pass := false;
         writeln( 'fail: minreal test' );
         writeln( 'minReal is ', minReal );
         writeln( 'minReal/2 is ', minReal/2 );
         writeln( '-minreal*negeps is ', -minreal*negeps );
         writeln( 'minreal*eps/2 is ', minreal*eps/2 );
      end;
   end;

   if maxreal*minreal >= 0.25 + negeps then
      writeln( 'maxreal is ', maxreal )
   else begin
      pass := false;
      writeln( 'fail: maxreal test' );
   end;

   if ord(maxchar) = ORD_CHAR_MAX then
      writeln( 'maxchar is ', ord(maxchar):1 )
   else begin
      pass := false;
      writeln( 'fail: maxchar test' );
   end;

   if eps + negeps >= sqr(negeps) then begin
      pass := false;
      writeln( 'fail: epsreal constant test 1' );
   end;

   if 1 + eps/negeps >= sqr(negeps) then begin
      pass := false;
      writeln( 'fail: epsreal constant test 2' );
   end;

   if negeps/eps + 1 >= sqr(negeps) then begin
      pass := false;
      writeln( 'fail: epsreal constant test 3' );
   end;

end; { realtest }


procedure testTStamp;
var
   t    : timestamp;
   f    : text;
   test : record
            case boolean of
              true  : ( t : timestamp);
              false : ( y, a, b : integer);
          end;
begin

   with test do begin
      t.year := 1999;
      writeln('y is ', y);
      a := 0; b := 0;
      if t.dstvalid then begin
         writeln('unexpected dstValid');
      end;
      t.isdst := true;
      writeln('a,b (isdst) is ', a, ' ', wrHex(a), ' ', b);
      a := 0; b := 0;
      t.dstValid := true;
      if b <> 0 then
         writeln('timestamp not contained within a single integer'); {without the year}
      writeln('a,b (dstValid) is ', a, ' ', wrHex(a), ' ', b);
      a := 0; b := 0;
      t.dateValid := true;
      if not (a < 0) then
         writeln('date valid is not aligned on the sign bit');
      writeln('a,b (dateValid) is ', a, ' ', wrHex(a), ' ', b);
      a := 0; b := 0;
      t.timeValid := true;
      writeln('a,b (timeValid) is ', a, ' ', wrHex(a), ' ', b);
      a := 0; b := 0;
      t.month := 9;
      writeln('a,b (month) is ', a, ' ', wrHex(a), ' ', b);
      a := 0; b := 0;
      t.day := 31;
      writeln('a,b (day) is ', a, ' ', wrHex(a), ' ', b);
      a := 0; b := 0;
      t.hour := 17;
      writeln('a,b (hour) is ', a, ' ', wrHex(a), ' ', b);
      a := 0; b := 0;
      t.minute := 59;
      writeln('a,b (minute) is ', a, ' ', wrHex(a), ' ', b);
      a := 0; b := 0;
      t.second := 60;
      writeln('a,b (second) is ', a, ' ', wrHex(a), ' ', b);
      a := 0; b := 0;
      t.day_of_week := 5;
      writeln('a,b (day) is ', a, ' ', wrHex(a), ' ', b);

      if a = 0 then begin
         writeln('unexpected bit pattern in tstamp, a is ', a:1);
      end;
   end; {with test}


   with t do begin
      rewrite(f);
      day := 31; month := 9;
      write(f, day:3, month:3);
      day := 1; month := 1;
      reset(f);
      read(f, day, month);
      if day <> 31 then
         writeln('unexpected read result in tstamp, day is ', day:1);
      if month <> 9 then
         writeln('unexpected read result in tstamp, month is ', day:1);
   end; {with t}

   t.year := 2000;
   t.dateValid := true;
   t.timevalid := false;
   if t.dateValid then begin   {dateValid & timeValid should share one bit }
      pass := false;
      writeln('date valid error: ', t.dateValid);
   end;
   t.month := 2;
   t.day := 7;
   t.hour := 12;
   t.minute := 22;
   t.second := 42;
   t.day_of_week := 4;
   t.isdst := true;

   if t.isdst then gettimestamp(t) else gettimestamp(t);

   with t do
      if not dateValid then
         writeln( 'date & time unavailable' )
      else begin
         write( 'today''s date is ');
         case day_of_week of
           1 : write('Sun');
           2 : write('Mon');
           3 : write('Tue');
           4 : write('Wed');
           5 : write('Thu');
           6 : write('Fri');
           7 : write('Sat');
         end; { case }
         write( ' ', day:1, ' ' );
         case month of
           1 : write('Jan');
           2 : write('Feb');
           3 : write('Mar');
           4 : write('Apr');
           5 : write('May');
           6 : write('Jun');
           7 : write('Jul');
           8 : write('Aug');
           9 : write('Sep');
           10 : write('Oct');
           11 : write('Nov');
           12 : write('Dec');
         end; {case}
         write( year:5 );

         writeln( ', the time is ', hour:2, ':', minute:2, ':', second:2 );
         if dstvalid then begin
            if isdst then
               writeln( 'daylight saving time' )
            else
               writeln( 'not daylight saving time' );
         end
         else
            writeln( 'daylight saving info unavailable' );
      end;

end; { testTStamp }


procedure testExp;
var
   x,y,z : real;
   i,n   : integer;
   pass1 : boolean;
begin
   pass1 := true;
   x := 1.69**0.5;
   if abs(x-1.3) >= epsreal then begin
      pass1 := false;
      writeln( '** test 1 fails, x is ', x:1:2 );
   end;

   x := 1.69**(-0.5);
   if abs(x*1.3-1) >= epsreal then begin
      pass1 := false;
      writeln( '** test 2 fails, x is ', x:1:2 );
   end;

   x := 0.5**(-2);
   if abs(x-4) >= epsreal then begin
      pass1 := false;
      writeln( '** test 3 fails, x is ', x:1:2 );
   end;

   y := 1;
   x := 0**y;
   if abs(x) > 0 then begin
      pass1 := false;
      writeln( 'y := (0 ** y) test 1 fails, x is ', x:1:2 );
   end;

   x := 0**0.0;
   if abs(x-1) > 0 then begin
      pass1 := false;
      writeln( 'y := (0 ** y) test 3 fails, x is ', x-1:1:2 );
   end;

   x := 0**trunc(y);
   if abs(x) > 0 then begin
      pass1 := false;
      writeln( 'y := (0 ** y) test 4 fails, x is ', x:1:2 );
   end;

   x := 0**0.0;
   if abs(x-1) > 0 then begin
      pass1 := false;
      writeln( 'y := (0 ** y) test 6 fails, x is ', x:1:2 );
   end;

   y := 20;
   x := 1**(-y);
   if abs(x-1) > 0 then begin
      pass1 := false;
      writeln( '(1 ** y) test 1 fails, x is ', x:1:2 );
   end;

   x := 1**0.0;
   if abs(x-1) > 0 then begin
      pass1 := false;
      writeln( '(1 ** y) test 2 fails, x is ', x:1:2 );
   end;

   x := 1**y;
   if abs(x-1) > 0 then begin
      pass1 := false;
      writeln( '(1 ** y) test 3 fails, x is ', x:1:2 );
   end;

   x := 1**trunc(-y);
   if abs(x-1) > 0 then begin
      pass1 := false;
      writeln( '(1 ** y) test 1 fails, x is ', x:1:2 );
   end;

   x := 1**0;
   if abs(x-1) > 0 then begin
      pass1 := false;
      writeln( '(1 ** y) test 2 fails, x is ', x:1:2 );
   end;

   x := 1**trunc(y);
   if abs(x-1) > 0 then begin
      pass1 := false;
      writeln( '(1 ** y) test 3 fails, x is ', x:1:2 );
   end;

   x := (-1)**(-1);
   if x <> -1 then begin
      pass1 := false;
      writeln( '** test 8 fails, x is ', x:1:2 );
   end;

   x := 1.5**2;
   if abs(x-2.25) >= epsreal then begin
      pass1 := false;
      writeln( '** test 9 fails, x is ', x:1:2 );
   end;

   x := 3**(-2);
   if abs(x-1/9) >= epsreal then begin
      pass1 := false;
      writeln( '** test 10 fails, x is ', x:1:2 );
   end;

   x := (-3)**(-3);
   if abs(x+1/27) >= epsreal then begin
      pass1 := false;
      writeln( '** test 11 fails, x is ', x:1:2 );
   end;

   x := (-3)**round(2**3);
   if x <> 6561 then begin
      pass1 := false;
      writeln( '** test 12 fails, x is ', x:1:2 );
   end;

   x := (3**2)**3;
   if x <> 729 then begin
      pass1 := false;
      writeln( '** test 13 fails, x is ', x:1:2 );
   end;

   x := 3**(2**3);
   if x <> 6561 then begin
      pass1 := false;
      writeln( '** test 14 fails, x is ', x:1:2 );
   end;

   x := 0**0.5;
   if x <> 0 then begin
      pass1 := false;
      writeln( '** test 15 fails, x is ', x:1:2 );
   end;

   x := -1.69**0.5;  { according to the rules of pascal, this is -(1.69**0.5) }
   if abs(x+1.3) >= 0.001 then begin
      pass1 := false;
      writeln( '** test 16 fails, x is ', x:1:2 );
   end;
   x := $aaaa;
   y := (1+epsreal)**round(x); {integer exponent}
   x := (1+epsreal)**x;        {real exponent}
   if x <> y then begin
      pass1 := false;
      writeln( '** integer vs real test fails, x is ', x-1,
               ', y is ', y-1, ', difference is ', y-x );
   end;

{
   x := 1;
   y := maxint;
   while y >= x+1 do begin
      writeln( 'x is ', round(x):1, ', y is ', round(y):1 );
      z := (x+y)/2;
      if (1+epsreal)**round(z) <> (1+epsreal)**z then
         y := z
      else
         x := z;
   end;
}

   x := epsReal;
   x := (1+x)**(1/x);
   if abs(x - exp(1)) > x*epsReal then begin
      writeln( 'inaccurate: (1+eps)**(1/eps) is ', x:1:6,
               ', expected e (', exp(1):1:6, ')' );
      writeln( 'error is ', x-exp(1):1, ', ', round(abs(x-exp(1))/(2*epsReal)):1,
               ' units of last place' );
      if sqr(x - exp(1)) > epsReal then begin
         writeln('this error is too large');
         pass1 := false;
      end
      else begin
         writeln('this error is acceptable');
      end;
   end;

   {expect x**integer to lose accuracy for large integers }
   i := 0; n:=0;
   repeat
      i := 2*i+1;
      n := n+1;
      x := (1+1/i)**i;
      if (exp(1)-x >= x/i) or (exp(1) < x)  then
         writeln( '   i is 2**', n:1, '-1, error for e - (1+1/i)**i is ', exp(1)-x,
                 ' correct result is in range 0 .. ', x/i );
   until i > (maxint-1) div 2;

   if pass1 then
      writeln( 'exponent operator tests passed' )
   else
      pass := false;


end; { testExp }


{TODO: test assign for binary files}
procedure testAssignFile;

var pass1 : boolean;
    f1    : text;

{ test file termination for assign }
{TODO: work recursion into this}
procedure p1;
label 1;
const fname = 'filep1.tst';
var f0 : text;
procedure p2;
procedure p3;
begin
  goto 1;
end; {p3}

var
   f:text; {belongs to p2, but unknown to p3}

begin {p2}
  assign(f, fname);
  rewrite(f);
  write(f, 'A');
  p3;
end; {p2}
begin {p1}
  //writeln('file limit is 1024 files'); {test file limit}
  p2;
1:   {p3 returns here, test if file has been terminated and closed}

  assign(f0, fname);
  reset(f0);
  if f0^ <> 'A' then begin
    writeln('fail: problem with ', fname);
    pass1 := false;
  end;
  get(f0);
  if eof(f0) then begin
    pass1 := false;
    writeln( 'fail: ', fname, ' end of file unexpected' );
  end
  else if not eoln(f0) then begin
    pass1 := false;
    writeln( 'fail: ', fname, ' file not terminated' );
  end;

  if pass1 then
     writeln('assign test passed')
  else
     pass := false;

end; {p1}

const n =  20;
var
   instr : packed array[1..n] of char;

   procedure getstr( var f :text );
   var i: 1..n;
   begin
      reset(f);
      i := 1;
      for i := 1 to n do
         if not eof(f) then
            read(f,instr[i])
         else
            instr[i] := ' ';
      writeln( 'message is ''', instr, '''' );
   end; { getstr }

begin

   pass1 := true;

   assign( f, 't0.txt' );
   rewrite(f);
   writeln(f, 'message to t0.txt' );

   {now read the same file with a different file variable ... }
   str := 't0.txt';
   assign( f1, str );
   reset(f1);
   if eof(f1) then
      writeln('f1 seems empty')
   else
      writeln('f1 is not empty');
   reset(f); {this flushes the buffer, so the data can now be read}
   getstr(f1);
   if instr <> 'message to t0.txt   ' then begin
      pass1 := false;
      writeln( 'fail assign test 1' );
   end;

   assign( f, fname );
   rewrite(f);
   writeln(f, 'message to t1.txt' );
   str := 't2.txt';
   assign( f, str );
   rewrite(f);
   writeln(f, 'message to t2.txt' );

   assign( f, fname );
   getstr(f);
   if instr <> 'message to t1.txt   ' then begin
      pass1 := false;
      writeln( 'fail assign test 2' );
   end;

   assign( f, 't2.txt                   ' );
   getstr(f);
   if instr <> 'message to t2.txt   ' then begin
      pass1 := false;
      writeln( 'fail assign test 3' );
   end;

   assign( f, '  ' );  // f is now a temp file
   rewrite(f);
   writeln( f, '123456789' );
   getstr(f);
   if instr <> '123456789           ' then begin
      pass1 := false;
      writeln( 'fail assign test 4' );
   end;


   p1;

end; { testAssignFile }


procedure testCase;
var e,s  : integer;
   pass1 :  boolean;
begin
   e := 10;
   case e of
     1,2,3,4    : begin
        pass1:=false;
        writeln( 'fail: case otherwise test 1' );
       end;
     otherwise
        e := 89;
        pass1 := true;
   end; {case}
   if e <> 89 then begin
        pass1:=false;
        writeln( 'fail: case otherwise test 2' );
   end;

   e := 1;
   case e of
     1,2,3,4    : begin {empty}
       end;
     otherwise
        pass1:=false;
        writeln( 'fail: case otherwise test 3' );
   end; {case}

   e := 11;
   case e of
     1,2,3,4    : begin {empty}
       end;
     otherwise
        pass1:=true;
        e := 89;
   end; {case}
   if e <> 89 then begin
        pass1:=false;
        writeln( 'fail: case otherwise test 4' );
   end;

   s := 0;
   for e := 0 to 100 do begin
      case e of
        1,2,3,4 : begin
        end;
        otherwise
        s :=  s+e;
      end; {case}
   end;
   if s <> 96*105 div 2 then begin
      pass1:=false;
      writeln( 'fail: case otherwise test 5' );
   end;

   for e := 0 to 61 do begin
      s := -1;
      case e of
        1..4    : {empty};
        otherwise
        case e of
          11..11:   s := 89;
          31..33: {empty};
          otherwise
          {empty}
        end; {case}
      end; {case}
      if (s=89) <> (e=11) then begin
         pass1:=false;
         writeln( 'fail: case test 5' );
      end;
   end;

   s := 0;
   for e := 1 to 49 do begin
      case e of
         1.. 9    :   s := s+8*e;  {360}
        11..19    :   s := s+4*e;  {540}
        21..29    :   s := s+2*e;  {450}
        31..39    :   s := s+e;    {315}
        otherwise
          {empty}
      end; {case}
   end;{for}
   if s <> 1665 then begin
      pass1:=false;
      writeln( 'fail: case otherwise test 6 (s is ', s:1, ')' );
   end;

   for e := 0 to 52 do begin
      s := -1;
      case e of
        21..23:   s := 89;
        otherwise
        {empty}
      end; {case}
      if (s = 89) <> (e in [21..23]) then begin
         pass1:=false;
         writeln( 'fail: case range test 2 (e is ', e:1, ',s is ', s:1, ')' );
      end;
   end;

   if pass1 then
      writeln( 'case statement tests passed' )
   else
      pass := false;

end; { testCase }


procedure testpredsucc;
type
   shape = (triangle, rectangle, circle);

var
   pass1  : boolean;
   colour : (white, red, orange, yellow, green, blue);
begin
   pass1 := true;
   if pass1 then colour := succ(red,1) else colour := pred(yellow,1);

   if succ(yellow, -1) <> colour then begin
      pass1 := false;
      writeln( 'fail: pred/succ test' );
   end;
   if succ(triangle, 0) <> triangle then begin
      pass1 := false;
      writeln( 'fail: pred/succ test' );
   end;

   if pass1 then colour := pred(blue,1) else colour := succ(yellow,1);
   if succ(yellow) <> colour then begin
      pass1 := false;
      writeln( 'fail: pred/succ test' );
   end;
   if succ(yellow, 2) <> blue then begin
      pass1 := false;
      writeln( 'fail: pred/succ test' );
   end;
   if pred(red, -1) <> orange then begin
      pass1 := false;
      writeln( 'fail: pred/succ test' );
   end;
   if pred(triangle, 0) <> triangle then begin
      pass1 := false;
      writeln( 'fail: pred/succ test' );
   end;
   if pred(green) <> yellow then begin
      pass1 := false;
      writeln( 'fail: pred/succ test' );
   end;
   if pred(blue, 2) <> yellow then begin
      pass1 := false;
      writeln( 'fail: pred/succ test' );
   end;

   if succ(6,3) <> 9 then begin
      writeln( 'fail: succ 1' );
      pass1 := false;
   end;
   if pred(6,3) <> 3 then begin
      writeln( 'fail: pred 1' );
      pass1 := false;
   end;
   if succ(6,-3) <> 3 then begin
      writeln( 'fail: succ 2' );
      pass1 := false;
   end;
   if pred(6,-3) <> 9 then begin
      writeln( 'fail: pred 2' );
      pass1 := false;
   end;
   if succ(white, 3) <> yellow then begin
      writeln( 'fail: succ 3' );
      pass1 := false;
   end;
   if pred(yellow, 3) <> white then begin
      writeln( 'fail: pred 3' );
      pass1 := false;
   end;
   if succ(yellow, -3) <> white then begin
      writeln( 'fail: succ 4' );
      pass1 := false;
   end;
   if pred(white, -3) <> yellow then begin
      writeln( 'fail: pred 4' );
      pass1 := false;
   end;
   if succ(yellow, 0) <> yellow then begin
      writeln( 'fail: succ 4' );
      pass1 := false;
   end;
   if pred(white, 0) <> white then begin
      writeln( 'fail: pred 4' );
      pass1 := false;
   end;

   if pass1 then
      writeln( 'pred/succ tests passed' )
   else
      pass := false;

end; { testpredsucc }


procedure testExtend;
const n = 6;

var
   f     : text;
   s     : packed array[1..n] of char;
   g     : file of integer;
   t     : integer;
   pass1 : boolean;

procedure readstr;
var i: 1..n;
begin
   i := 1;
   for i := 1 to n do
      if not eoln(f) then
         read(f,s[i])
      else
         s[i] := ' ';
   readln(f);
end; { readstr }

procedure testBinFile;
var t0 : integer;
begin
   t0 := -4;
   rewrite(g);
   while t0 <= 10 do begin
      write(g, t0);
      t0 := t0+1;
   end;

   reset(g);
   t0 := -4;
   while not eof(g) do begin
      read(g, t);
      if t <> t0 then begin
         writeln( 'fail: t is ''', t:1, ''', expected ''', t0:1, '''' );
         pass1 := false;
      end;
      t0 := succ(t0);
   end;
   if pred(t0) <> 10 then begin
      writeln( 'fail: file length (1), last line is ''', t:1, '''' );
      pass1 := false;
   end;

   if pass1 then extend(g) else extend(g);
   extend(g);
   if not eof(g) then begin
      writeln( 'fail: eof() after extend on binary file should be true' );
      pass1 := false;
   end;
   while t0 <= 20 do begin
      write(g, t0 );
      t0 := succ(t0);
   end;

   reset(g);
   t0 := -4;
   while not eof(g) do begin
      read(g, t);
      if t <> t0 then begin
         writeln( 'fail: t is ''', t:1, ''', expected ''', t0:1, '''' );
         pass1 := false;
      end;
      t0 := succ(t0);
   end;
   if pred(t0) <> 20 then begin
      writeln( 'fail: file length (2), last line is ''', t:1, '''' );
      pass1 := false;
   end;

end; { testBinFile }

procedure testTextFile;
var
   s0 : packed array[1..n] of char;
begin
   s0 := 'line  ';
   s0[n] := '0';
   rewrite(f);
   while s0[n] <= '5' do begin
      writeln(f, s0 );
      s0[n] := succ(s0[n]);
   end;

   reset(f);
   s0[n] := '0';
   while not eof(f) do begin
      readstr;
      if s <> s0 then begin
         writeln( 'fail: line is ''', s, ''', expected ''', s0, '''' );
         pass1 := false;
      end;
      s0[n] := succ(s0[n]);
   end;
   if pred(s0[n]) <> '5' then begin
      writeln( 'fail: file length (1), last line is ''', s, '''' );
      pass1 := false;
   end;

   if pass1 then extend(f) else extend(f);
   extend(f);
   if not eof(f) then begin
      writeln( 'fail: eof() after extend on text file should be true' );
      pass1 := false;
   end;
   while s0[n] <= '9' do begin
      writeln(f, s0 );
      s0[n] := succ(s0[n]);
   end;

   reset(f);
   s0[n] := '0';
   while not eof(f) do begin
      readstr;
      if s <> s0 then begin
         writeln( 'fail: line is ''', s, ''', expected ''', s0, '''' );
         pass1 := false;
      end;
      s0[n] := succ(s0[n]);
   end;
   if pred(s0[n]) <> '9' then begin
      writeln( 'fail: file length (2), last line is ''', s, '''' );
      pass1 := false;
   end;

end; { testTextFile }


begin

   pass1 := true;

   testBinFile;
   if pass1 then assign(g, 'myFile.bin') else assign(f, 'myFile.txt');
   assign(g, 'myFile.bin');
   testBinFile;

   testTextFile;
   if pass1 then assign(f, 'myFile.txt') else assign(f, 'myFile.txt');
   assign(f, 'myFile.txt');
   testTextFile;

   if pass1 then
      writeln( 'file extend tests passed' )
   else
      pass := false;

end; { testExtend }


procedure testConst;

const
   q = 12;

{ set * (+, -, *, in ) }


{ strings }
   cs1 = 'test string';

   cc1 = 'a';
   cc2 = chr(9);
   chp = chr(ord('p'));
   cha = pred(succ(cc1));
   chs = chr(ord(succ(chp,3)));
   che = chr(ord('e'));
   chd = pred(che);

{ conditions not implemented
    (int, real?, set?, boolean, string, scalar) x (=, <>, <, <=, >, >=) )
}

{  set constants not implemented
   cset1 = [0,1,3];
}

type days = (sun, mon, tues, wed, thurs, fri, sat, otherday);

{ functions }

   function testFunc : boolean;
const

   cai1 = abs(11); { = 11 }
   cai2 = abs(-111); { = 111 }
   ca3  = abs( abs(-5) - abs(-6) ); { = 1 }

   codd1 =  odd(13);
   codd2 =  odd(12);
   codd3 =  odd(7 + ord(odd(61)));
   codd4 =  odd(7 + ord(odd(62)));

   csqr1 = sqr(3);
   csqr2 = sqr(sqr(2));

   {ctrunc0 = trunc(8);}
(******
   ctrunc10 = trunc( 10.99);
   ctrunc11 = trunc( -10.9);
   ctrunc20 = trunc( maxint + 0.5);
   ctrunc21 = trunc( -maxint - 1.5 );
   ctrunc3 = trunc( trunc(9.3) - 0.2);
*******)

   {cround0 = round(-6);}
(******
   cround1 = round( 10.99);
   cround2 = round( -10.9);
   cround3 = round( trunc(9.3) - 0.2);
*******)


   cord1 = ord(true); { = 1 }
   cord2 = ord(tues); { = 2 }
   cord3 = ord(true);
   cord0 = ord(pred(tues, ord(tues))); { recurse ord }

   csucc1 = succ(tues);  { = wed }
   csucc2 = succ(succ(tues));  { = thurs }

   cpred1 = pred(wed);   { = tues }
   cpred2 = pred(pred(wed));   { = mon }

   cps1 = succ(pred(tues)); { = tues }
   cps2 = pred(succ(tues)); { = tues }

   cpn1 = succ( mon, 4);   { = fri }
   cpn2 = pred( fri, 4);   { = mon }
   cpn3 = succ( fri, -4);   { = mon }
   cpn4 = pred( mon, -4);   { = fri }
   cpn5 = pred( mon, -4);   { = fri }

   cpn50 = succ(pred( fri, 4), 4);   { = fri }
   cpn51 = succ(succ(pred( fri, 5), 3), 2);   { = fri }
   cpn52 = succ(pred(pred( fri, 2), 3), 5);   { = fri }

   cpn60 = pred(-18); { =-19 }
   cpn61 = pred('b'); { ='a' }
   cpn62 = pred(true); { =false }
   cpn100 = succ( tues, 5-ord(tues));   { = thurs }

   cabm = abs(maxint);
   codm = odd(maxint);
   corm = ord(maxint);
   cprm = pred(maxint);
   csum = succ(-maxint);

   corc = ord(maxchar);
   cprc = pred(maxchar);

var
   pass :  boolean;

begin
   write( 'testing functions in constant expressions ... ' );
   pass := true;

   if cai1 <> 11 then begin
      pass := false;
      writeln; writeln( 'cai1: is ', cai1, ' sb 11 abs fails for +ve numbers');
   end;

   if cai2 <> 111 then begin
      pass := false;
      writeln; writeln( 'cai2: is ', cai2, ' sb 111 abs fails for -ve numbers');
   end;

   if ca3 <> 1 then begin
      pass := false;
      writeln; writeln( 'ca3: is ', ca3, 'sb 1 abs fails on recursion');
   end;

   if codd2 then begin
      pass := false;
      writeln; writeln( 'codd2: odd fails for even numbers');
   end;

   if not codd1 then begin
      pass := false;
      writeln; writeln( 'odd fails for odd numbers');
   end;

   if codd3 then begin
      pass := false;
      writeln; writeln( 'codd3: odd fails on recursion');
   end;

   if not codd4 then begin
      pass := false;
      writeln; writeln( 'codd4: odd fails on recursion');
   end;

   if csqr1 <> 9 then begin
      pass := false;
      writeln; writeln( 'csqr2: sqr fails');
   end;

   if csqr2 <> 16 then begin
      pass := false;
      writeln; writeln( 'csqr3: sqr fails');
   end;


(*******
   if ctrunc0 <> 8 then begin
      pass := false;
      writeln; writeln( 'ctrunc0: trunc fails');
   end;

   ctrunc10 = trunc( 10.99); { = 10
   ctrunc11 = trunc( -10.9); { = -10
   ctrunc20 = trunc( maxint + 0.5); { = maxint
   ctrunc21 = trunc( -maxint - 1.5 ); { = -maxint -1
   ctrunc3 = trunc( trunc(9.3) - 0.2); { = 8

   if cround0 <> -6 then begin
      pass := false;
      writeln; writeln( 'cround0: round fails');
   end;

   cround1 = round( 10.99);
   if codd2 then begin
      pass := false;
      writeln; writeln( 'odd fails for even numbers');
   end;

   cround2 = round( -10.9);
   if codd2 then begin
      pass := false;
      writeln; writeln( 'odd fails for even numbers');
   end;

   cround3 = round( trunc(9.3) - 0.2);
   if codd2 then begin
      pass := false;
      writeln; writeln( 'odd fails for even numbers');
   end;
*******)

   if cord1 <> 1 then begin
      pass := false;
      writeln; writeln( 'cord1: ord fails');
   end;

   if cord2 <> 2 then begin
      pass := false;
      writeln; writeln( 'cord2: ord fails');
   end;

   if cord3 <> 1 then begin
      pass := false;
      writeln; writeln( 'cord3: ord fails');
   end;

   if cord0 <> 0 then begin
      pass := false;
      writeln; writeln( 'cord0: ord fails');
   end;

   if csucc1 <> wed then begin
      pass := false;
      writeln; writeln( 'csucc1: succ fails');
   end;

   if csucc2 <> thurs then begin
      pass := false;
      writeln; writeln( 'csucc2: succ fails');
   end;

   if cpred1 <> tues then begin
      pass := false;
      writeln; writeln( 'cpred1: pred fails');
   end;

   if cpred2 <> mon then begin
      pass := false;
      writeln; writeln( 'cpred2: pred fails on recursion');
   end;

   if cps1 <> tues then begin
      pass := false;
      writeln; writeln( 'cps1: pred/succ fails');
   end;

   if cps2 <> tues then begin
      pass := false;
      writeln; writeln( 'cps2: pred/succ fails');
   end;

   if cpn1 <> fri then begin
      pass := false;
      writeln; writeln( 'cpn1: pred/succ fails');
   end;

   if cpn2 <> mon then begin
      pass := false;
      writeln; writeln( 'cpn2: pred/succ fails');
   end;

   if cpn3 <> mon then begin
      pass := false;
      writeln; writeln( 'cpn3: pred/succ fails');
   end;

   if cpn4 <> fri then begin
      pass := false;
      writeln; writeln( 'cpn4: pred/succ fails');
   end;

   if cpn5 <> fri then begin
      pass := false;
      writeln; writeln( 'cpn5: pred/succ fails');
   end;

   if cpn50 <> fri then begin
      pass := false;
      writeln; writeln( 'cpn50: pred/succ fails');
   end;

   if cpn51 <> fri then begin
      pass := false;
      writeln; writeln( 'cpn51: pred/succ fails');
   end;

   if cpn52 <> fri then begin
      pass := false;
      writeln; writeln( 'cpn52: pred/succ fails');
   end;


   if cpn60 <> -19 then begin
      pass := false;
      writeln; writeln( 'cpn60: pred/succ fails');
   end;

   if cpn61 <> 'a' then begin
      pass := false;
      writeln; writeln( 'cpn100: pred/succ fails');
   end;

   if cpn62 then begin
      pass := false;
      writeln; writeln( 'cpn62: pred/succ fails');
   end;

   if cpn100 <> fri then begin
      pass := false;
      writeln; writeln( 'cpn100: pred/succ fails');
   end;


   if cabm <> abs(maxint) then begin
      pass := false;
      writeln( 'fail: cabm' );
   end;

   if codm <> odd(maxint) then begin
      pass := false;
      writeln( 'fail: codm' );
   end;

   if corm <> ord(maxint) then begin
      pass := false;
      writeln( 'fail: corm' );
   end;

   if cprm <> pred(maxint) then begin
      pass := false;
      writeln( 'fail: cprm' );
   end;

   if csum <> succ(-maxint) then begin
      pass := false;
      writeln( 'fail: csum' );
   end;

   if corc <> ord(maxchar) then begin
      pass := false;
      writeln( 'fail: corc' );
   end;

   if cprc <> pred(maxchar) then begin
      pass := false;
      writeln( 'fail: cprc' );
   end;


   {TODO: check range errors, etc }

   if pass then
      writeln( 'passed' );

   testFunc := pass;

end; {testFunc}


function testArith : boolean;

const
   rc1 = 1.5;
   ic1    = 12;
   ic2    = -ic1;

{ all combinations of (int, real) x (+, -, *, /, div, mod) }
   ctiip = 12 + 3;
   ctiis = ic1 - 3;
   ctiix = 12 * 3;
   ctiix0 = 0 * ctiix;
   ctiid = 12 div 5;
   ctiim1 = 12 mod 5;
   ctiim2 = -12 mod 5;
   ctiim3 = 12 mod (-5);
   ctiim4 = (-12) mod 5;

{ precedence and parens }
   ctii2 = 4 + 5 * 2;
   ctii3 = (4 + 5) * 2;

{ signed terms }
   ctii40 = -8;
   ctii41 = -8 * 7;
   ctii42 = -(8 + (-7));
   ctii43 = +8;
   ctii44 = +8 * 7;
   ctii45 = +(8 - (+7));
   ctii46 = -ctii43 * 7;
   ctii47 = -ctii40 * 7;
   ctii48 = +ctii43 * 7;
   ctii49 = +ctii40 * 7;

{ reentry }
   ctii50 = 2 + (30 + 100);
   ctii51 = 2 * (3 * 5);

   cr0 = -(6.25);
   cr1 = +(16.25);
   cr2 = -26.25;
   cr3 = +36.25;

   cm0 = maxint - 100;
   cm1 = -maxint + 100;
   cm2 = maxint div 3;
   cm3 = maxint mod 16;
   cm4 = maxint * 1;
   cm5 = 0 * maxint;

var
   pass :  boolean;

begin
   write( 'testing arithmetic constant expressions ... ' );
   pass := true;

   if ctiip <> 15 then begin
      pass := false;
      writeln; writeln( 'integer add expression fails');
   end;

   if ctiis <> 9 then begin
      pass := false;
      writeln; writeln( 'integer subtract expression fails');
   end;

   if ctiix <> 36 then begin
      pass := false;
      writeln; writeln( 'ctiix: integer miltiply expression fails');
   end;

   if ctiix0 <> 0 then begin
      pass := false;
      writeln; writeln( 'ctiix0: integer miltiply expression fails');
   end;

   if ctiid <> 2 then begin
      pass := false;
      writeln; writeln( 'integer div expression fails');
   end;

   if ctiim1 <> 2 then begin
      pass := false;
      writeln; writeln( 'ctiim1: integer mod expression fails');
   end;

   if ctiim2 <> -2 then begin
      pass := false;
      writeln; writeln( 'ctiim2: integer mod expression fails');
   end;

   if ctiim3 <> -3 then begin
      pass := false;
      writeln; writeln( 'ctiim3: integer mod expression fails');
   end;

   if ctiim4 <> 3 then begin
      pass := false;
      writeln; writeln( 'ctiim4: integer mod expression fails');
   end;

{ precedence and parens }
   if ctii2 <> 14 then begin
      pass := false;
      writeln; writeln( 'integer precedence in expression fails');
   end;

   if ctii3 <> 18 then begin
      pass := false;
      writeln; writeln( 'parens in integer expression fails');
   end;

   { signed term }
   if ctii40 + 8 <> 0 then begin
      pass := false;
      writeln; writeln( 'ctii40: signed factor fails');
   end;

   if 56 + ctii41 <> 0 then begin
      pass := false;
      writeln; writeln( 'ctii41: signed term fails');
   end;

   if ctii42 + 1 <> 0 then begin
      pass := false;
      writeln; writeln( 'ctii42: signed simple expression fails');
   end;

   if ctii43 - 8 <> 0 then begin
      pass := false;
      writeln; writeln( 'ctii43: signed factor fails');
   end;

   if 56 - ctii44 <> 0 then begin
      pass := false;
      writeln; writeln( 'ctii44: signed term fails');
   end;

   if ctii45 - 1 <> 0 then begin
      pass := false;
      writeln; writeln( 'ctii45: signed simple expression fails');
   end;

   if 56 + ctii46 <> 0 then begin
      pass := false;
      writeln; writeln( 'ctii46: signed term fails');
   end;

   if 56 - ctii47 <> 0 then begin
      pass := false;
      writeln; writeln( 'ctii47: signed term fails');
   end;

   if 56 - ctii48 <> 0 then begin
      pass := false;
      writeln; writeln( 'ctii48: signed term fails');
   end;

   if 56 + ctii49 <> 0 then begin
      pass := false;
      writeln; writeln( 'ctii49: signed term fails');
   end;

   if ctii50 <> 132 then begin
      pass := false;
      writeln; writeln( 'reentry addition expression fails');
   end;

   if ctii51 <> 30 then begin
      pass := false;
      writeln; writeln( 'reentry multiplication expression fails');
   end;

   if cr0 <> -6.25 then begin
      pass := false;
      writeln; writeln( 'cr0: signed real term fails');
   end;

   if cr1 <> 16.25 then begin
      pass := false;
      writeln; writeln( 'cr1: signed real term fails');
   end;

   if cr2 <> -26.25 then begin
      pass := false;
      writeln; writeln( 'cr2: signed real term fails');
   end;

   if cr3 <> 36.25 then begin
      pass := false;
      writeln; writeln( 'cr3: signed real term fails');
   end;

   if cm0 <> maxint - 100 then begin
      pass := false;
      writeln( 'fail: cm0' );
   end;

   if cm1 <> -maxint + 100 then begin
      pass := false;
      writeln( 'fail: cm1' );
   end;

   if cm2 <> maxint div 3 then begin
      pass := false;
      writeln( 'fail: cm2' );
   end;

   if cm3 <> maxint mod 16 then begin
      pass := false;
      writeln( 'fail: cm3' );
   end;

   if cm4 <> maxint then begin
      pass := false;
      writeln( 'fail: cm4' );
   end;

   if cm5 <> 0 then begin
      pass := false;
      writeln( 'fail: cm5' );
   end;


   if pass then
      writeln( 'passed' );

   testArith := pass;

end; { testArith }


function testBool : boolean;

const
{ all combinations of (true, false) x (and, or) }
   cb0 = false;
   cb1 = true;
   cba0 = false;
   cba1 = true;
   ctb00 = cb0 or cba0;
   ctb01 = cb0 or cba1;
   ctb10 = cb1 or cba0;
   ctb11 = cb1 or cba1;
   ctba00 = cb0 and cba0;
   ctba01 = cb0 and cba1;
   ctba10 = cb1 and cba0;
   ctba11 = cb1 and cba1;

   ctb2 = cb1 or cba1 and cba0;
   ctb3 = (cb1 or cba1) and cba0;

{ not boolean expression}
   ctbb40 = not ctb3;
   ctbb41 = not ctb11 and ctb2;   { = false }
   ctbb42 = not ctba00 or ctba11; { = true }
   ctbb43 = not(not ctba00 or ctba11); { = false }

var
   pass :  boolean;

begin
   write( 'testing boolean constant expressions ... ' );
   pass := true;

   if ctb00 then begin
      pass := false;
      writeln; writeln( '"false or false" boolean expression fails');
   end;

   if not ctb01 then begin
      pass := false;
      writeln; writeln( '"false or true" boolean expression fails');
   end;

   if not ctb10 then begin
      pass := false;
      writeln; writeln( '"true or false" boolean expression fails');
   end;

   if not ctb11 then begin
      pass := false;
      writeln; writeln( '"true or true" boolean expression fails');
   end;

   if ctba00 then begin
      pass := false;
      writeln; writeln( '"false and false" boolean expression fails');
   end;

   if ctba01 then begin
      pass := false;
      writeln; writeln( '"false and true" boolean expression fails');
   end;

   if ctba10 then begin
      pass := false;
      writeln; writeln( '"true and false" boolean expression fails');
   end;

   if not ctba11 then begin
      pass := false;
      writeln; writeln( '"true and true" boolean expression fails');
   end;

   if not ctb2 then begin
      pass := false;
      writeln; writeln( 'precedence in boolean expression fails');
   end;

   if ctb3 then begin
      pass := false;
      writeln; writeln( 'parens in boolean expression fails');
   end;

   if not ctbb40 then begin
      pass := false;
      writeln; writeln( 'not boolean expression fails');
   end;

   if ctbb41 then begin
      pass := false;
      writeln; writeln( 'not boolean expression fails');
   end;

   if not ctbb42 then begin
      pass := false;
      writeln; writeln( 'not boolean expression fails');
   end;

   if ctbb43 then begin
      pass := false;
      writeln; writeln( 'not boolean expression fails');
   end;

   if pass then
      writeln( ' ', chp, cha, chs, chs, che, chd );

(*
   write( 'testing constant strings ...' );
   pass := true;

   if cs1[5] <> ' ' then begin
      pass := false;
      writeln; writeln( 'string const failed');
   end;

   if pass then
      writeln( 'passed' );
*)

   testBool := pass;

end; { testBool }

function testDec : boolean;

const
   start = 0;
   size  = 10;
   go    = green;
   stop  = red;
   wait  = succ(stop);

type
   list1   = (start) .. (start+size);
   list2   = start .. start+size;
   rainbow1 = succ(brown)..pred(grey);
   rainbow2 = (succ(brown))..(pred(grey));

var
   myArray : array[ start..start+size-1] of real;
   i       : start..start+size-1;
   pass    : boolean;
   l1      : list1;
   l2      : list2;
   s1      : set of list1;
   s2      : set of list2;
   col1    : rainbow1;
   col2    : rainbow2;
   myRec1  : record
                x : (one{,two})
             end;
   myRec2  : record
                x : (stop)..(go);
                y : (size div 2)..size;
                z : size div 2 .. size
             end;

begin
   pass := true;
   write( 'testing use of constant expressions ... ' );
   for i := start to start+size-1 do
      myArray[i] := sqr(i)/4;
   myArray[start] := 1001;
   myArray[start+1] := 1002;
   myArray[start+size-2] := 1003;
   myArray[start+size-1] := 1004;

   for i := start to start+size-1 do
      case i of
        start : if myArray[i] <> 1001 then begin
                   pass := false;
                   writeln( 'fail: const expr in case (', i:1, ')' );
                end;
        start+1 : if myArray[i] <> 1002 then begin
                   pass := false;
                   writeln( 'fail: const expr in case (', i:1, ')' );
                end;
        start+size-2 : if myArray[i] <> 1003 then begin
                   pass := false;
                   writeln( 'fail: const expr in case (', i:1, ')' );
                end;
        start+2..start+size-3 : if 4*myArray[i] <> sqr(i) then begin
                   pass := false;
                   writeln( 'fail: const expr in case (', i:1, ')' );
                end;
        start+size-1 : if myArray[i] <> 1004 then begin
                   pass := false;
                   writeln( 'fail: const expr in case (', i:1, ')' );
                end;
      end;

   s1 := [];
   for l1 := start to start + size do
      if l1 mod 3 = 2 then s1 := s1 + [l1];

   s2 := [];
   for l2 := start to start + size do
      if l2 mod 3 = 2 then s2 := s2 + [l2];

   if s1 <> [2,5,8] then begin
      pass := false;
      writeln( 'fail: constant expression type definition (1)' );
   end;

   if s2 <> [2,5,8] then begin
      pass := false;
      writeln( 'fail: constant expression type definition (2)' );
   end;

   col1 := succ(brown);
   if col1 <> pred(orange) then begin
      pass := false;
      writeln( 'fail: constant expression type definition (3)' );
   end;

   col1 := pred(grey);
   if col1 <> succ(blue) then begin
      pass := false;
      writeln( 'fail: constant expression type definition (4)' );
   end;

   col2 := pred(orange);
   if col2 <> succ(brown) then begin
      pass := false;
      writeln( 'fail: constant expression type definition (5)' );
   end;

   col2 := succ(blue);
   if col2 <> pred(grey) then begin
      pass := false;
      writeln( 'fail: constant expression type definition (6)' );
   end;

   with myRec1 do begin
      x := one;
      if x <> one then begin
         pass := false;
         writeln( 'fail: constant expression type definition (7)' );
      end;
   end;

   with myRec2 do begin
      x := stop;
      if x <> red then begin
         pass := false;
         writeln( 'fail: constant expression type definition (8)' );
      end;
      x := go;
      if x <> green then begin
         pass := false;
         writeln( 'fail: constant expression type definition (9)' );
      end;
   end;

   with myRec2 do begin
      y := size;
      z := y div 2;
      while z < size do begin
         if y+z <> 3*size div 2 then begin
            pass := false;
            writeln( 'fail: constant expression type definition (10)' );
         end;
         y := pred(y);
         z := succ(z);
      end;
   end;

   if pass then
      writeln( 'passed' );

   testDec := pass;

end; { testDec }

begin

   if not testArith then pass := false;
   if not testBool then pass := false;
   if not testFunc then pass := false;
   if not testDec then pass := false;

end; { testConst }


procedure testExternal;
var
   x     : real;
var
      daylight : integer; external;

var
   a,b,c : integer; external;
function pow(x : real; y:real) : real; external;

begin

   writeln( 'pow(3,2) is ', pow(3,2):1:2 );
   writeln( 'daylight is ', Daylight:1 );

end; { testExternal }


procedure testRString;
var
   f     : text ;
   s     : packed array[1..5] of char;
   pass1 : boolean;
begin
   pass1 := true;

(**
   experimental feature, disabled

   rewrite(f);
   writeln( f, '123456' );
   writeln( f, 'abcdef' );
   writeln( f, 'ABCD' );
   reset(f);
   writeln('reading s');
   read(f,s);
   writeln('s is ''', s, '''');
   if s <> '12345' then begin
      pass1 := false;
      writeln( 'fail: read string, s is ''', s, '''' );
   end;
   read(f,s);
   writeln('s is ''', s, '''');
   read(f,s);
   writeln('s is ''', s, '''');
   read(f,s);
   writeln('s is ''', s, '''');

   if pass1 then
      writeln( 'read string tests passed' )
   else
      writeln( 'read string tests passed' );
**)

end; { testRString }


procedure testShortString;
const
   slen     = 10;
   passed   = 'passed';
type
   str =  packed array[1..slen] of char;

   procedure check(s : str; test: packed array[one..len :integer] of char );
   var
      i,j,k  : integer;
      ok     : boolean;
   begin
      ok := true;
      i := 1;
      for j := 1 to slen do
         if s[j] >= ' ' then begin
            if test[i] <> s[j] then
               ok := false;
            i := i+1;
         end
         else begin
            if test[i] <> '\' then
               ok := false;
            i := i+1;
            k := ord(s[j]);
            if k > 10 then begin
               if test[i] <> chr(ord('0') + k div 10) then
                  ok := false;
               k := k mod 10;
               i := i+1;
            end;
            if test[i] <> chr(ord('0') + k) then
               ok := false;
            i := i+1;
         end; {for}
      if i-1 <> len then
         ok := false;
      if not ok  then begin
         pass := false;
         writeln('short string test failed: found ', s);
      end;
   end; { check }

   procedure p(s : str );
   var i,j,k : integer;
       s1    : str;

   begin
      check(s, 'passed\0\0\0\0');
      writeln( 'param short string is ''', s, '''');

      s1 := 'ditto';  {shorter than slen}
      check(s1, 'ditto\0\0\0\0\0');
      writeln( 'assign short string is ''', s1, '''' );

   end; { p }

var s : str;

begin
   s := 'string';
   if s < 'str' then begin
      pass := false;
      writeln('short string compare failed (1)');
   end;

   if not (s >= 'str') then begin
      pass := false;
      writeln('short string compare failed (2)');
   end;

   if 'str' > s then begin
      pass := false;
      writeln('short string compare failed (3)');
   end;

   if not ('str' <= s) then begin
      pass := false;
      writeln('short string compare failed (4)');
   end;

   if 'str' > s then begin
      pass := false;
      writeln('short string compare failed (5)');
   end;

   if not ('str' <= s) then begin
      pass := false;
      writeln('short string compare failed (6)');
   end;

   s := 'string1234';
   if s <= 'string' then begin
      pass := false;
      writeln('short string compare failed (7)');
   end;

   if not (s > 'string') then begin
      pass := false;
      writeln('short string compare failed (8)');
   end;

   if 'string' > s then begin
      pass := false;
      writeln('short string compare failed (9)');
   end;

   if not ('string' <= s) then begin
      pass := false;
      writeln('short string compare failed (10)');
   end;

   if 'string' = 'str' then begin
      pass := false;
      writeln('short string compare failed (11)');
   end;

   if not ('string' <> 'str') then begin
      pass := false;
      writeln('short string compare failed (12)');
   end;

   p( passed ); {shorter than slen}
end; { testShortString }



begin {tp5x}
   pass := true;
   id_with_underscores := true;
   id_withunderscores := false;
   writeln( 'p5x test program' );

   if id_withunderscores then begin
      pass := false;
      writeln( 'underscores in id fails' );
   end;

   if not id_with_underscores then begin
      pass := false;
      writeln( 'underscores in id fails' );
   end;

   id$withdollars := true;
   id$with$dollars := false;

   if not id$withdollars then begin
      pass := false;
      writeln( '$ in id fails' );
   end;

   if id$with$dollars then begin
      pass := false;
      writeln( '$ in id fails (2)' );
   end;

   if m1 <> -1 then begin
      pass := false;
      writeln( 'comment test 1 fails' );
   end;

   if m2 <> -2 then begin
      pass := false;
      writeln( 'comment test 2 fails' );
   end;

   if c1 <> 16 then begin
      pass := false;
      writeln( 'comment test 3 fails' );
   end;

   x := 15.0;
   if x / 3.0 <> 5.0 then begin
      pass := false;
      writeln( 'comment test 4 fails' );
   end;

   if 'test string' <> "test string" then begin
      pass := false;
      writeln( 'double quote test fails' );
   end;


   testhexnum;
   testExp;
   mixedDec;
   realtest;
   testTStamp;
   testAssignFile;
   testCase;
   testpredsucc;
   testExtend;
   testConst;
   testExternal;
   testRString;
   testShortString;

   writeln( 'argc is ', argc );
   for i := 0 to argc-1 do begin
      if i = 0 then argv(0, str) else argv(i, str);
      writeln( 'argv[', i:1, '] is ''', str, '''' );
   end;

   if pass then
      writeln( 'p5x tests passed' )
   else
      writeln( 'p5x tests failed' );

   {test that halt statement compiles without error ...}
   if not pass then halt else pass := true;
   if not pass then halt(0) else pass := true;
end.

// no terminating end of line on next line
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%% end of tp5x.pas %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
