lang/pc/test/t4.p

   1 #
   2 {
   3   (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
   4
   5            This product is part of the Amsterdam Compiler Kit.
   6
   7   Permission to use, sell, duplicate or disclose this software must be
   8   obtained in writing. Requests for such permissions may be sent to
   9
  10        Dr. Andrew S. Tanenbaum
  11        Wiskundig Seminarium
  12        Vrije Universiteit
  13        Postbox 7161
  14        1007 MC Amsterdam
  15        The Netherlands
  16
  17 }
  18
  19 program t4(input,output);
  20 { Tests for the EM-1 compiler }
  21 const rcsversion='$Id: t4.p,v 2.4 1994/06/24 12:37:00 ceriel Exp $';
  22 type vec = array[1..1000] of integer;
  23      spectrum = set of (red,blue,yellow);
  24 #ifndef NOFLOAT
  25      tp2 = record c1:char;i,j:integer; p:boolean; x:real end;
  26 #else
  27      tp2 = record c1:char;i,j:integer; p:boolean end;
  28 #endif
  29      cmat = array[0..3,0..7] of ^spectrum;
  30      single = array [0..0] of integer;
  31      np = ^node;
  32      node = record val: integer;  next: np end;
  33
  34 var t,ect,pct:integer;
  35     r1: tp2;
  36     pt1,pt2: ^vec;
  37     pt3:^integer;
  38     mk: ^integer;
  39     i,j: integer;
  40
  41
  42
  43 procedure e(n:integer);
  44 begin
  45   ect := ect + 1;
  46   writeln(' Error', n:3,' in test ', t)
  47 end;
  48
  49 function inc(k:integer):integer; begin inc := k+1 end;
  50 function twice(k:integer):integer; begin twice := 2*k end;
  51 function decr(k:integer):integer; begin decr := k-1 end;
  52
  53
  54
  55 procedure tst40;
  56 { Mark and Release }
  57 var i:integer;
  58   procedure grab;
  59   var i:integer;
  60   begin
  61     for i:=1 to 10 do new(pt1);
  62     for i:=1 to 1000 do new(pt3);
  63   end;
  64
  65 begin t:= 40;  pct:=pct+1;
  66   for i:=1 to 10 do
  67      begin
  68         mark(mk);
  69         new(pt2);
  70         grab;
  71         release(mk)
  72      end;
  73 end;
  74
  75
  76 procedure tst41;
  77 { Empty sets }
  78 begin  t:=41;  pct := pct + 1;
  79   if red in [] then e(1);
  80   if ([] <> []) then e(2);
  81   if not ([] = []) then e(3);
  82   if not([] <=[]) then e(4);
  83   if not ( [] >= []) then e(5);
  84 end;
  85
  86
  87 {************************************************************************}
  88 procedure tst42;
  89 { Record variants.  These tests are machine dependent }
  90 var s:record b:boolean; case t:boolean of false:(c:char);true:(d:cmat) end;
  91     w: packed record
  92           case z:boolean of
  93             false: (x:array[0..20] of integer);
  94             true: (x1,x2,x3,a,b,c,d,e,f,g,h,i,j,k,l:char)
  95        end;
  96
  97     y: record
  98           case z:boolean of
  99             false: (x:array[0..20] of integer);
 100             true: (a,b,c,d,e,f,g,h,i,j,k,l:char)
 101        end;
 102     i:integer;
 103 begin t:=42; pct:=pct+1;
 104   s.t:=false;  s.c:='x';  if s.c <> 'x' then e(1);
 105   for i:=0 to 20 do begin w.x[i]:=-1; y.x[i]:=-1 end;
 106   w.a:=chr(0);  w.f:=chr(0);
 107   y.a:=chr(0);  y.f:=chr(0);
 108   if (ord(w.a) <> 0) or (ord(w.b) <> 255) then e(3);
 109   if (ord(w.c) <> 255) or (ord(w.d)<>255) then e(4);
 110   if (ord(w.e) <> 255) or (ord(w.f) <> 0) then e(5);
 111   if ord(y.a) <> 0 then e(6);
 112   if ord(y.f) <> 0 then e(7);
 113 end;
 114
 115
 116
 117
 118 {************************************************************************}
 119 procedure tst43;
 120 { Procedure and function parameters }
 121   function incr(k:integer):integer; begin incr := k+1 end;
 122   function double(k:integer):integer; begin double := 2*k end;
 123   function eval(function f(a:integer):integer; a:integer):integer;
 124   begin eval:=f(a) end;
 125   function apply(function f(a:integer):integer; a:integer):integer;
 126       begin apply:=eval(f,a) end;
 127
 128   procedure x1(function f(a:integer):integer;  a:integer; var r:integer);
 129       procedure x2(function g(c:integer):integer;  b:integer;  var s:integer);
 130       begin s:=apply(g,b); end;
 131   begin x2(f, a+a, r) end;
 132
 133 procedure p0(procedure p(x:integer); i,j:integer);
 134 begin
 135   if j=0 then p(i) else p0(p,i+j,j-1)
 136 end;
 137
 138 procedure p1(a,b,c,d:integer);
 139 var k:integer;
 140   procedure p2(x:integer);
 141   begin k:= x*x end;
 142 begin k:=0;
 143   p0(p2,a,b);
 144   if k <> c then e(d);
 145 end;
 146
 147
 148
 149 begin t:=43; pct := pct+1;
 150   i:=10;  j:=20;
 151   if incr(0) <> 1 then e(1);
 152   if decr(i) <> 9 then e(2);
 153   if double(i+j) <> 60 then e(3);
 154   if incr(double(j)) <> 41 then e(4);
 155   if decr(double(incr(double(i)))) <> 41 then e(5);
 156   if incr(incr(incr(incr(incr(5))))) <> 10 then e(6);
 157   if eval(incr,i) <> 11 then e(7);
 158   if eval(decr,3) <> 2 then e(8);
 159   if incr(eval(double,15)) <> 31 then e(9);
 160   if apply(incr,3) <> 4 then e(10);
 161
 162   x1(double,i,j);  if j <> 40 then e(11);
 163   x1(incr,i+3,j);  if j <> 27 then e(12);
 164   p1(3,5,324,13);
 165   p1(10,4,400,14);
 166   p1(1,8,1369,15);
 167   j:=1;
 168   if inc(incr(twice(double(inc(incr(twice(double(j)))))))) <> 26 then e(13);
 169 end;
 170
 171
 172 {************************************************************************}
 173  procedure tst44;
 174 { Value parameters }
 175    type ww2 = array[-10..+10] of tp2;
 176         arra = array[-10..+10] of integer;
 177         reca = record k:single; s:spectrum end;
 178         pa = np;
 179 #ifndef NOFLOAT
 180 var l1:integer;  xr:real;  xb:boolean;  xc:char;  xar:cmat;  xnode:pa;
 181 #else
 182 var l1:integer;  xb:boolean;  xc:char;  xar:cmat;  xnode:pa;
 183 #endif
 184     vec1: arra;   vec2: ww2;
 185     s2:spectrum;  rec1: reca;
 186     zero:0..0;
 187
 188 #ifndef NOFLOAT
 189 procedure tst4401(pl1:integer; pxr:real;   pxb:boolean;  pxc:char;
 190 #else
 191 procedure tst4401(pl1:integer;  pxb:boolean;  pxc:char;
 192 #endif
 193                    pxar:cmat;   pxnode:pa;  pxtp2:tp2;
 194                    pvec1:arra;  pvec2:ww2; prec1:reca;
 195                    ps1,ps2:spectrum;  psin:single; i,j:integer);
 196 begin t:=4401; pct:=pct+1;
 197   if pl1<>29 then e(1);
 198 #ifndef NOFLOAT
 199   if pxr<>-0.31 then e(2);
 200 #endif
 201   if pxb <> false then e(3);
 202   if pxc <> 'k' then e(4);
 203   if (pxar[1,1]^<>[red,blue]) or (pxar[2,2]^ <> [yellow]) then e(5);
 204   if (pxnode^.val <> 105) or (pxnode^.next^.val <> 106) then e(6);
 205 #ifndef NOFLOAT
 206   if (pxtp2.c1 <> 'w') or (pxtp2.x <> 20.3) then e(7);
 207 #else
 208   if (pxtp2.c1 <> 'w')  then e(7);
 209 #endif
 210   if pvec1[10] <> -996 then e(8);
 211 #ifndef NOFLOAT
 212   if pvec2[zero].x <> -300 then e(9);
 213 #endif
 214   if (prec1.k[zero] <> -421) or (prec1.s <> []) then e(10);
 215   if (ps1<>[]) or (ps2<>[red]) then e(11);
 216   if psin[zero] <> -421 then e(12);
 217   if i <> -421 then e(13);
 218   if j <> 106 then e(14);
 219
 220   pl1:=0;  pxc:=' ';  pxb:=true;
 221   pxar[1,1]^:=[];  pxar[2,2]^:=[];
 222   pxnode^.val:=0;  pxnode^.next^.val:=1;
 223   pxtp2.c1:=' ';
 224   pvec1[10]:=0;
 225 #ifndef NOFLOAT
 226   pvec2[zero].x:=0;
 227 #endif
 228   prec1.k[zero]:=0;
 229   psin[0]:=0;  i:=0;  j:=0;
 230 end;
 231
 232 begin t:=44; pct:=pct+1;
 233   zero:=0;
 234 #ifndef NOFLOAT
 235   l1:=29;  xr:=-0.31;  xb:=false;  xc:='k';
 236 #else
 237   l1:=29;  xb:=false;  xc:='k';
 238 #endif
 239   new(xar[1,1]);  xar[1,1]^ := [red,blue];
 240   new(xar[2,2]);  xar[2,2]^ := [yellow];
 241   new(xar[1,2]);  xar[1,2]^ := [yellow];
 242   new(xnode);  xnode^.val :=105;
 243   new(xnode^.next); xnode^.next^.val :=106;
 244 #ifndef NOFLOAT
 245   r1.c1:='w';  r1.x:=20.3;
 246   vec1[10] := -996;  vec2[zero].x := -300;
 247 #else
 248   r1.c1:='w';
 249   vec1[10] := -996;
 250 #endif
 251   rec1.k[zero]:=-421;  rec1.s :=[];
 252   s2:=[red];
 253
 254 #ifndef NOFLOAT
 255   tst4401(l1, xr, xb, xc, xar, xnode, r1, vec1, vec2, rec1,
 256 #else
 257   tst4401(l1, xb, xc, xar, xnode, r1, vec1, vec2, rec1,
 258 #endif
 259            [], s2, rec1.k, rec1.k[zero], xnode^.next^.val);;
 260   t:=44;
 261
 262   if l1<>29 then e(1);
 263 #ifndef NOFLOAT
 264   if xr<> -0.31 then e(2);
 265 #endif
 266   if xb <> false then e(3);
 267   if xc <> 'k' then e(4);
 268   if (xar[1,1]^ <> [])  or (xar[2,2]^ <> []) then e(5);
 269   if xar[1,2]^ <> [yellow] then e(6);
 270   if (xnode^.val <> 0) or (xnode^.next^.val <> 1) then e(7);
 271 #ifndef NOFLOAT
 272   if (r1.c1 <> 'w') or (r1.x <> 20.3) then e(8);
 273 #else
 274   if (r1.c1 <> 'w') then e(8);
 275 #endif
 276   if vec1[10] <> -996 then e(9);
 277 #ifndef NOFLOAT
 278   if vec2[zero].x <> -300 then e(10);
 279 #endif
 280   if (rec1.k[zero] <> -421) or (rec1.s <> []) then e(11);
 281   if s2 <> [red] then e(12);
 282 end;
 283
 284
 285 {************************************************************************}
 286  procedure tst45;
 287 { Var parameters }
 288    type ww2 = array[-10..+10] of tp2;
 289         arra = array[-10..+10] of integer;
 290         reca = record k:single; s:spectrum end;
 291         pa = np;
 292 #ifndef NOFLOAT
 293 var l1:integer;  xr:real;  xb:boolean;  xc:char;  xar:cmat;  xnode:pa;
 294 #else
 295 var l1:integer;   xb:boolean;  xc:char;  xar:cmat;  xnode:pa;
 296 #endif
 297     vec1: arra;   vec2: ww2;
 298     s1,s2:spectrum;  rec1: reca;
 299     zero:0..0;
 300
 301 #ifndef NOFLOAT
 302 procedure tst4501(var pl1:integer; var pxr:real; var pxb:boolean; var pxc:char;
 303 #else
 304 procedure tst4501(var pl1:integer;  var pxb:boolean; var pxc:char;
 305 #endif
 306                    var pxar:cmat;   var pxnode:pa;  var pxtp2:tp2;
 307                    var pvec1:arra;  var pvec2:ww2; var prec1:reca;
 308                    var ps1,ps2:spectrum;  var psin:single; var i,j:integer);
 309 begin t:=4501; pct:=pct+1;
 310   if pl1<>29 then e(1);
 311 #ifndef NOFLOAT
 312   if pxr<>-0.31 then e(2);
 313 #endif
 314   if pxb <> false then e(3);
 315   if pxc <> 'k' then e(4);
 316   if (pxar[1,1]^<>[red,blue]) or (pxar[2,2]^ <> [yellow]) then e(5);
 317   if (pxnode^.val <> 105) or (pxnode^.next^.val <> 106) then e(6);
 318 #ifndef NOFLOAT
 319   if (pxtp2.c1 <> 'w') or (pxtp2.x <> 20.3) then e(7);
 320 #else
 321   if (pxtp2.c1 <> 'w') then e(7);
 322 #endif
 323   if pvec1[10] <> -996 then e(8);
 324 #ifndef NOFLOAT
 325   if pvec2[zero].x <> -300 then e(9);
 326 #endif
 327   if (prec1.k[zero] <> -421) or (prec1.s <> []) then e(10);
 328   if (ps1<>[]) or (ps2<>[red]) then e(11);
 329   if psin[zero] <> -421 then e(12);
 330   if i <> -421 then e(13);
 331   if j <> 106 then e(14);
 332
 333 #ifndef NOFLOAT
 334   pl1:=0;  pxr:=0;  pxc:=' ';  pxb:=true;
 335 #else
 336   pl1:=0;   pxc:=' ';  pxb:=true;
 337 #endif
 338   pxar[1,1]^:=[];  pxar[2,2]^:=[];
 339   pxnode^.val:=0;  pxnode^.next^.val:=1;
 340   pxtp2.c1:=' ';
 341 #ifndef NOFLOAT
 342   pxtp2.x := 0;
 343 #endif
 344   pvec1[10]:=0;
 345 #ifndef NOFLOAT
 346   pvec2[zero].x:=0;
 347 #endif
 348   prec1.k[zero]:=0;
 349   psin[0]:=0;  i:=223;  j:=445;
 350 end;
 351
 352 begin t:=45; pct:=pct+1;
 353   zero:=0;
 354 #ifndef NOFLOAT
 355   l1:=29;  xr:=-0.31;  xb:=false;  xc:='k';
 356 #else
 357   l1:=29;  xb:=false;  xc:='k';
 358 #endif
 359   new(xar[1,1]);  xar[1,1]^ := [red,blue];
 360   new(xar[2,2]);  xar[2,2]^ := [yellow];
 361   new(xar[1,2]);  xar[1,2]^ := [yellow];
 362   new(xnode);  xnode^.val :=105;
 363   new(xnode^.next); xnode^.next^.val :=106;
 364 #ifndef NOFLOAT
 365   r1.c1:='w';  r1.x:=20.3;
 366   vec1[10] := -996;  vec2[zero].x := -300;
 367 #else
 368   r1.c1:='w';
 369   vec1[10] := -996;
 370 #endif
 371   rec1.k[zero]:=-421;  rec1.s :=[];
 372   s1:=[];  s2:=[red];
 373
 374 #ifndef NOFLOAT
 375   tst4501(l1, xr, xb, xc, xar, xnode, r1, vec1, vec2, rec1,
 376 #else
 377   tst4501(l1, xb, xc, xar, xnode, r1, vec1, vec2, rec1,
 378 #endif
 379            s1, s2, rec1.k, rec1.k[zero], xnode^.next^.val);;
 380   t:=45;
 381
 382   if l1<>0 then e(1);
 383 #ifndef NOFLOAT
 384   if xr<> 0 then e(2);
 385 #endif
 386   if xb <> true then e(3);
 387   if xc <> ' ' then e(4);
 388   if (xar[1,1]^ <> [])  or (xar[2,2]^ <> []) then e(5);
 389   if xar[1,2]^ <> [yellow] then e(6);
 390   if (xnode^.val <> 0) or (xnode^.next^.val <> 445) then e(7);
 391 #ifndef NOFLOAT
 392   if (r1.c1 <> ' ') or (r1.x <> 0) then e(8);
 393 #else
 394   if (r1.c1 <> ' ') then e(8);
 395 #endif
 396   if vec1[10] <> 0 then e(9);
 397 #ifndef NOFLOAT
 398   if vec2[zero].x <> 0 then e(10);
 399 #endif
 400   if (rec1.k[zero] <> 223) or (rec1.s <> []) then e(11);
 401   if (s1 <> []) or (s2 <> [red]) then e(12);
 402 end;
 403
 404
 405
 406
 407 begin ect:=0; pct:=0;
 408   tst40; tst41; tst42; tst43; tst44; tst45;
 409   write('Program t4:',pct:3,' tests completed.');
 410   writeln('Number of errors = ',ect:1);
 411 end.