program test(input,output);


{    Pascal Compiler Test Program
     Version 1.1

     Written by John R. Naleszkiewicz
     Date: October 19, 1984
   Update: January 15, 1985   }

const
     start = 10;
     finish = 50;

type
     rec = record
             f1 : integer;
             f2 : real;
             f3 : boolean;
             f4 : array[1 .. 3] of char;
           end;

var
    fail : boolean;
     i,j : integer;
     x,y : real;
     b,f : boolean;
     c,h : char;
     ain : array[0 .. 10] of integer;
     arl : array[start .. finish] of real;
     abl : array[-5 .. 5] of boolean;
     ach : array[1 .. 25] of char;

     alist,blist : rec;


procedure ptest1;
var
  i : integer;
  x : real;
  begin
    writeln('called');
    i := -10;
    x := -15.0
  end; { ptest1 }

procedure ptest2(i : integer; x : real; var j : integer; var y : real);
  begin
    writeln('called');
    if i<>10 then
      writeln('    Call by value integer passed incorrectly (P)');
    if x<>10.0 then
      writeln('    Call by value real passed incorrectly (P)');
    if j<>25 then
      writeln('    Call by reference integer passed incorrectly (P)');
    if y<>25.0 then
      writeln('    Call by reference real passed incorrectly (P)');
    j := j - 1;
    y := y - 1.0
  end; { ptest2 }

procedure ptest3(i : integer);
  begin
    write(i:1);
    if i>0 then
      ptest3(i-1)
  end; { ptest3 }

function ftest1(k : integer; z : real): integer;
  begin
    writeln('called');
    if k<>0 then
      writeln('    Call by reference integer passed incorrectly (F)');
    if z<>75.0 then
      writeln('    Call by reference real passed incorrectly (F)');
    ftest1 := 100
  end; { ftest1 }

function ftest2(m : integer): integer;
  begin
    if m>0 then
      ftest2 := ftest2(m-1) + 2
    else
      ftest2 := 0;
    write(m:1)
  end; { ftest2 }


begin  { main program }
  writeln;
  writeln('Pascal Compiler Test Program -- Version 1.1');
  writeln;

  fail := false;
  writeln('If statement and logical tests (P=pass, F=fail)');
  write('  Simple logical test (PP):');
  if true then
    write('P')
  else
    write('F');
  if false then
    writeln('F')
  else
    writeln('P');
  write('  Logical NOT test (PP):');
  if not true then
    write('F')
  else
    write('P');
  if not false then
    writeln('P')
  else
    writeln('F');
  write('  Logical AND test (PPP):');
  if true and true then
    write('P')
  else
    write('F');
  if true and false then
    write('F')
  else
    write('P');
  if false and false then
    writeln('F')
  else
    writeln('P');
  write('  Logical OR test (PPP):');
  if true or true then
    write('P')
  else
    write('F');
  if true or false then
    write('P')
  else
    write('F');
  if false or false then
    writeln('F')
  else
    writeln('P');
  write('  Logical comparison tests = <> < > <= >= (PPPPPPPP):');
  if 10 = 10 then
    write('P')
  else
    write('F');
  if 10 <> 1 then
    write('P')
  else
    write('F');
  if 1 < 10 then
    write('P')
  else
    write('F');
  if 10 > 1 then
    write('P')
  else
    write('F');
  if 10 <= 10 then
    write('P')
  else
    write('F');
  if 1 <= 10 then
    write('P')
  else
    write('F');
  if 10 >= 10 then
    write('P')
  else
    write('F');
  if 10 >= 1 then
    writeln('P')
  else
    writeln('F');

  writeln;
  write('Enter "C" <return> to continue');
  read(c);
  writeln;
  writeln;

  writeln('Variable assignment tests');
  writeln('  Simple variable assignment tests');
  i := 10;
  writeln('  Integer stored:    10, contents: ',i:3);
  j := i;
  if j<>10 then
    begin
      write('    Integer assignment test failed, ');
      writeln(j,' instead of 10');
      fail := true
    end;

  j := -i;
  writeln('  Integer stored:   -10, contents: ',j:3);
  if j<>-10 then
    begin
      write('    Integer negation test failed, ');
      writeln(j,' instead of -10');
      fail := true
    end;

  x := 10.0;
  writeln('  Real stored:  1.0000E+01, contents:',x);
  y := x;
  if y<>10.0 then
    begin
      write('    Floating point assignment failed, ');
      writeln(y,' instead of 1.0000E+01');
      fail := true
    end;

  y := -x;
  writeln('  Real stored: -1.0000E+01, contents:',y);
  if y<>-10.0 then
    begin
      write('    Floating point negation failed, ');
      writeln(y,' instead of -1.0000E+01');
      fail := true
    end;

  b := true;
  f := b;
  if not f then
    begin
      write('    Boolean assignment (true) failed, ');
      writeln('false instead of true');
      fail := true
    end;

  b := false;
  f := b;
  if f then
    begin
      write('    Boolean assignment (false) failed, ');
      writeln('true instead of false');
      fail := true
    end;

  c := 'x';
  h := c;
  if h<>'x' then
    begin
      write('    Character assignment failed, ');
      writeln('result of "',h,'" instead of "x"');
      fail := true
    end;


  writeln('  Array assignment tests');
  ain[0] := 25;
  ain[5] := ain[0];
  if ain[5]<>25 then
    begin
      write('    Integer array assignment failed, ');
      writeln(ain[5],' instead of 25');
      fail := true
    end;

  arl[25] := 1000.0;
  arl[45] := arl[25];
  if arl[45]<>1000.0 then
    begin
      write('    Floating point array assignment failed, ');
      writeln(arl[45],' instead of 1.0000E+03');
      fail := true
    end;

  abl[-3] := true;
  abl[3]  := abl[-3];
  if not abl[3] then
    begin
      write('    Boolean array assignment (true) failed, ');
      writeln('false instead of true');
      fail := true
    end;

  abl[0] := false;
  abl[5] := abl[0];
  if abl[5] then
    begin
      write('    Boolean array assignment (false) failed, ');
      writeln('true instead of false');
      fail := true
    end;

  ach[10] := 'a';
  ach[23] := ach[10];
  if ach[23]<>'a' then
    begin
      write('    Character array assignment failed, ');
      writeln('result of "',ach[23],'" instead of "a"');
      fail := true
    end;


  writeln('  Record field assignment tests');
  alist.f1 := 99;
  alist.f2 := 12.5;
  alist.f3 := true;
  alist.f4[1] := 'a';
  alist.f4[2] := 'b';
  alist.f4[3] := alist.f4[1];
  blist := alist;
  if blist.f1<>99 then
    begin
      write('    Integer field assignment failed, ');
      writeln(blist.f1,' instead of 99');
      fail := true
    end;

  if blist.f2<>12.5 then
    begin
      write('    Real field assignment failed, ');
      writeln(blist.f2,' instead of 1.2500E+01');
      fail := true
    end;

  if not blist.f3 then
    begin
      write('    Boolean field assignment failed, ');
      writeln('false instead of true');
      fail := true
    end;

  if blist.f4[3]<>'a' then
    begin
      write('    Character array field assignment failed, ');
      writeln('result of "',blist.f4[3],'" instead of "a"');
      fail := true
    end;


  writeln('Builtin function tests');
  i := 3;
  if not odd(i) then
    begin
      write('  Function odd(x) failed, ');
      writeln(i,' was found to be even');
      fail := true
    end;

  i := 4;
  if odd(i) then
    begin
      write('  Function odd(x) failed, ');
      writeln(i,' was found to be odd');
      fail := true
    end;

  x := 1.77;
  i := round(x);
  j := trunc(x);
  if i<>2 then
    begin
      write('  Function round(x) failed, ');
      writeln(i,' instead of 2');
      fail := true
    end;
  if j<>1 then
    begin
      write('  Function trunc(x) failed, ');
      writeln(i,' instead of 1');
      fail := true
    end;

  i := -25;
  j := abs(i);
  if j <> 25 then
    begin
      write('  Function abs(integer) failed, ');
      writeln(j,' instead of 25');
      fail := true
    end;

  i := 99;
  j := abs(i);
  if j <> 99 then
    begin
      write('  Function abs(integer) failed, ');
      writeln(j,' instead of 99');
      fail := true
    end;

  x := -12.5;
  y := abs(x);
  if y <> 12.5 then
    begin
      write('  Function abs(real) failed, ');
      writeln(y,' instead of 1.2500E+01');
      fail := true
    end;

  x := 112.5;
  y := abs(x);
  if y <> 112.5 then
    begin
      write('  Function abs(real) failed, ');
      writeln(y,' instead of 1.1250E+02');
      fail := true
    end;

  i := 7;
  j := sqr(i);
  if j <> 49 then
    begin
      write('  Function sqr(integer) failed, ');
      writeln(j,' instead of 49');
      fail := true
    end;

  x := 5.0;
  y := sqr(x);
  if y <> 25.0 then
    begin
      write('  Function sqr(real) failed, ');
      writeln(y,' instead of 2.5000E+01');
      fail := true
    end;

  x := 729.0;
  y := sqrt(x);
  if y <> 27.0 then
    begin
      write('  Function sqrt(x) failed, ');
      writeln(y,' instead of 2.7000E+01');
      fail := true
    end;

  x := exp(1.0);
  y := ln(x);
  if y<>1.0 then
    begin
      write('  Function exp(x) or ln(x) failed, ');
      writeln(y,' instead of 1.0000E+00');
      fail := true
    end;


  writeln('Arithmetic tests');
  writeln('  Integer arithmetic tests');
  i := 5 + 5;
  j := i + 10;
  j := j + i;
  if j<>30 then
    begin
      write('    Addition failed, ');
      writeln(j,' instead of 30');
      fail := true
    end;

  i := 20 - 8;
  j := i - 10;
  j := i - j;
  if j<>10 then
    begin
      write('    Subtraction failed, ');
      writeln(j,' instead of 10');
      fail := true
    end;

  i := 2 * 3;
  j := i * 4;
  j := j * i;
  if j<>144 then
    begin
      write('    Multiplication failed, ');
      writeln(j,' instead of 144');
      fail := true
    end;

  i := 100 div 5;
  j := i div 10;
  j := i div j;
  if j<>10 then
    begin
      write('    Division failed, ');
      writeln(j,' instead of 10');
      fail := true
    end;

  i := 102 mod 15;
  j := i mod 7;
  j := i mod j;
  if j<>2 then
    begin
      write('    MOD failed, ');
      writeln(j,' instead of 2');
      fail := true
    end;

  i := 10;
  j := i + 7;
  j := (j - i) * (i - 2 * j);
  if j<>-168 then
    begin
      write('    Hierarchy failed, ');
      writeln(j,' instead of -168');
      fail := true
    end;

  writeln('  Floating point arithmetic tests');
  x := 1.0 / 3.0;
  x := x * 3.0;
  y := 1.0 - x;
  if y=0.0 then
    i := 99
  else
    i := round(-ln(y) / ln(10.0));
  writeln('    Internal accuracy (digits): ',i:2);
  x := 2.0 + 3.0;
  y := x + 10.2;
  y := y + x;
  if y<>20.2 then
    begin
      write('    Addition failed, ');
      writeln(y,' instead of 2.0200E+01');
      fail := true
    end;

  x := 20.0 - 8.7;
  y := x - 10.3;
  y := x - y;
  if y<>10.3 then
    begin
      write('    Subtraction failed, ');
      writeln(y,' instead of 1.0300E+01');
      fail := true
    end;

  x := 2.0 * 3.0;
  y := x * 4.0;
  y := y * x;
  if y<>144.0 then
    begin
      write('    Multiplication failed, ');
      writeln(y,' instead of 1.4400E+02');
      fail := true
    end;

  x := 100.0 / 5.0;
  y := x / 10.0;
  y := x / y;
  if y<>10.0 then
    begin
      write('    Division failed, ');
      writeln(y,' instead of 1.0000E+01');
      fail := true
    end;

  x := 10.0;
  y := x + 7.0;
  y := (y - x) * (x - 2.0 * y);
  if y<>-168.0 then
    begin
      write('    Hierarchy failed, ');
      writeln(y,' instead of -1.6800E+02');
      fail := true
    end;


  writeln;
  write('Enter "C" <return> to continue');
  read(c);
  writeln;
  writeln;

  writeln('Procedure and function testing');
  writeln('  Procedure call tests');
  i := 0;
  x := 10.0;
  write('    Procedure 1 ');
  ptest1;
  if i<>0 then
    begin
      writeln('    Integer local variables damaging globals');
      fail := true
    end;
  if x<>10.0 then
    begin
      writeln('    Real local variables damaging globals');
      fail := true
    end;

  j := 25;
  y := 25.0;
  write('    Procedure 2 ');
  ptest2(10,10.0,j,y);
  if j<>24 then
    begin
      writeln('    Call by reference integer not returned correctly');
      fail := true
    end;
  if y<>24.0 then
    begin
      writeln('    Call by reference real not returned correctly');
      fail := true
    end;

  writeln('    Recursive procedure test (5..0)');
  write('      ');
  i := 5;
  ptest3(i);
  writeln;
  if i<>5 then
    begin
      writeln('    Call by value in recursive test failed');
      fail := true
    end;

  writeln('  Function call tests');
  i := 0;
  x := 75.0;
  write('    Function 1 ');
  i := ftest1(i,x);
  if i<>100 then
    begin
      writeln('    Function not returning correct value');
      fail := true
    end;

  writeln('    Recursive function  test (0..5)');
  write('      ');
  i := 5;
  j := ftest2(i);
  writeln;
  if i<>5 then
    begin
      writeln('      Call by value in recursive function test failed');
      fail := true
    end;
  if j<>10 then
    begin
      writeln('      Function not returning correct value during recursion');
      fail := true
    end;


  writeln;
  writeln('Testing complete');
  if fail then
    writeln('Errors Found')
  else
    writeln('No Errors Found')

end.

  writeln