|
DataMuseum.dkPresents historical artifacts from the history of: RC3500 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC3500 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 21504 (0x5400)
Types: TextFileVerbose
Names: »dynjobs«
└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
└─⟦6b41451d2⟧
└─⟦this⟧ »dynjobs«
; dynjobs
%
(****************
* *
* ep test 1 *
****************)
process test1(var sv : system_vector );
procedure p(a,b,c,d : integer);
type su = a+b .. c*d;
ta = array (su) of integer;
tb = array (1..a) of ta;
rc = record
p : integer;
q : su;
r : ta;
s : integer;
t : su;
u : tb;
v : integer
end;
tc = array (1..10) of rc;
var
v1 : su;
v2 : ta;
v3 : tb;
v4 : rc;
v5 : tc;
v6 : integer;
i,j,k,l : integer;
begin
printtext('start p ');
i:=v1;
printnumber( i, 4 ) ; printnl;
v1:=i;
printnumber( v1, 4); printnl;
i:=v2(i);
printnumber( i, 4); printnl;
j:=v3(k,l);
printnumber( j, 4); printnl;
i:=v4.q;
printnumber( i, 4); printnl;
i:=v4.r(l);
printnumber( i, 4); printnl;
i:=v4.s;
printnumber( i, 4); printnl;
i:=v4.t;
printnumber( i, 4); printnl;
i:=v4.u(k,l);
printnumber( i, 4); printnl;
i:=v4.v;
printnumber( i, 4); printnl;
i:=v5(i).s;
printnumber( i, 4); printnl;
(*$4 1 0*)
printtext( 'end of p ');
end;
begin
p(1,2,3,4);
end.
%
\f
(**********************
* ep test 2 *
* test array decl *
**********************)
process test2( var sv:system_vector);
process testa(var s:semaphore; vn : integer);
type
r1 = record a : semaphore; b : integer end;
r2 = record a : semaphore; b : 0..31 end;
r3 = record a : semaphore; b : array (1..vn) of 0..10 end;
r4 = record a : semaphore; b : array (1..vn+1) of 0..255 end;
r5 = array (1..vn) of integer;
ds = 1..vn;
var
a : array (1..3) of integer;
b : array (1..3) of r1;
c : packed array (1..3) of r2;
d : packed array (1..5) of 0..31;
e : packed array (1..5) of 0..32;
f : packed array (1..6) of 0..10;
g : packed array (1..7) of 0..10;
gg: array (1..3) of ds;
h : array (ds) of r1;
i : packed array (ds) of r2;
j : packed array (ds) of integer;
k : packed array (ds) of 0..32;
l : packed array (ds) of 0..31;
m : packed array (ds) of 0..10;
n : array (1..3) of r3;
o : array (1..3) of r4;
p : array (1..3) of r5;
r : array (ds) of r3;
s : array (ds) of r4;
t1, t : array (ds) of r5;
ii, jj : integer; vs : ds;
sa, ssa, sb, ssb, sc, ssc, sd, ssd, se, sse, sf, ssf,
sg, ssgg, sgg, ssg, sh, ssh, si, ssi, sj,ssj, sk, ssk,
sl, ssl, sm, ssm, sn, ssn, so, sso, sp, ssp,
sr, ssr, ss, sss, st, sst, sum, ssum, st1, sst1 : integer;
procedure error;
begin trace( #hff ) end;
begin
a(1):=277; sa:=277; ssa:=277;
b(1).b:=280; sb:=280; ssb:=sb;
c(1).b:=23; sc:=23; ssc:=sc;
d(1):=27; sd:=27; ssd:=27;
e(1):=28; se:=28; sse:=se;
f(1):=0; sf:=0; ssf:=sf;
g(1):=1; sg:=1; ssg:=sg;
gg(1):=2; sgg:=2; ssgg:=sgg;
h(1).b:=100; sh:=100; ssh:=sh;
i(1).b:=20; si:=20; ssi:=si;
j(1):=250 ; sj:=250; ssj:=sj;
k(1):=11; sk:=11; ssk:=sk;
l(1):=12; sl:=12; ssl:=sl;
m(1):=3; sm:=3; ssm:=3;
for ii:=2 to 3 do begin
a(ii):=a(ii-1)+1; sa:=sa+a(ii); ssa:=ssa+sa;
b(ii).b:=b(ii-1).b+1; sb:=sb+b(ii).b; ssb:=ssb+sb;
c(ii).b:=c(ii-1).b+1; sc:=sc+c(ii).b; ssc:=ssc+sc;
if vn >= 4 then begin
gg(ii):=gg(ii-1)+1; sgg:=sgg+gg(ii); ssgg:=ssgg+sgg;
end; (* vn >= 4 *)
end;
sum:=0; ssum:=0;
for ii:=1 to 3 do begin
sum:=sum+a(ii); ssum:=ssum+sum;
end;
if (sum<>sa) or (ssa<>ssum) then error;
sum:=0; ssum:=0;
for ii:=1 to 3 do begin
sum:=sum+b(ii).b; ssum:=ssum+sum;
end;
if (sum<>sb) or (ssum<>ssb) then error;
sum:=0; ssum:=0;
for ii:=1 to 3 do begin
sum:=sum+c(ii).b; ssum:=ssum+sum;
end;
if (sum<>sc) or (ssum<>ssc) then error;
if vn >= 4 then begin
sum:=0; ssum:=0;
for ii:=1 to 3 do begin
sum:=sum+gg(ii); ssum:=ssum+sum;
end;
if (sgg<>sum) or (ssum<>ssgg) then error;
end; (* vn >= 4 *)
for ii:=2 to 5 do begin
d(ii):=d(ii-1)+1; sd:=sd+d(ii); ssd:=ssd+sd;
e(ii):=e(ii-1)+1; se:=se+e(ii); sse:=sse+se;
f(ii):=f(ii-1)+1; sf:=sf+f(ii); ssf:=ssf+sf;
g(ii):=g(ii-1)+1; sg:=sg+g(ii); ssg:=ssg+sg;
end;
f(6):=f(5)+1; sf:=sf+f(6); ssf:=ssf+sf;
g(6):=g(5)+1; sg:=sg+g(6); ssg:=ssg+sg;
g(7):=g(6)+1; sg:=sg+g(7); ssg:=ssg+sg;
sum:=0; ssum:=0;
for ii:=1 to 5 do begin
sum:=sum+d(ii); ssum:=ssum+sum;
end;
if (sum<>sd) or (ssum<>ssd) then error;
sum:=0; ssum:=0;
for ii:=1 to 5 do begin
sum:=sum+e(ii); ssum:=ssum+sum;
end;
if (sum<>se) or (ssum<>sse) then error;
sum:=0; ssum:=0;
for ii:=1 to 6 do begin
sum:=sum+f(ii); ssum:=ssum+sum;
end;
if (sum<>sf) or (ssum<>ssf) then error;
sum:=0; ssum:=0;
for ii:=1 to 7 do begin
sum:=sum+g(ii); ssum:=ssum + sum ;
end;
if (sum<>sg) or (ssum<>ssg) then error;
for vs:=2 to vn do begin
h(vs).b:=h(vs-1).b+1; sh:=sh+h(vs).b; ssh:=ssh+sh;
i(vs).b:=i(vs-1).b+1; si:=si+i(vs).b; ssi:=ssi+si;
j(vs):=j(vs-1)+1; sj:=sj+j(vs); ssj:=ssj+sj;
k(vs):=k(vs-1)+1; sk:=sk+k(vs); ssk:=ssk+sk;
l(vs):=l(vs-1)+1; sl:=sl+l(vs); ssl:=ssl+sl;
m(vs):=(m(vs-1)+1) mod 11; sm:=sm+m(vs); ssm:=ssm+sm;
end;
sum:=0; ssum:=0;
for vs:=1 to vn do begin
sum:=sum+h(vs).b; ssum:=ssum+sum;
end;
if (sum<>sh) or (ssum<>ssh) then error;
sum:=0; ssum:=0;
for vs:=1 to vn do begin
sum:=sum+i(vs).b; ssum:=ssum+sum;
end;
if (sum<>si) or (ssum<>ssi) then error;
sum:=0; ssum:=0;
for vs:=1 to vn do begin
sum:=sum+j(vs); ssum:=ssum+sum;
end;
if (sum<>sj) or (ssum<>ssj) then error;
sum:=0; ssum:=0;
for vs:=1 to vn do begin
sum:=sum+k(vs); ssum:=ssum+sum;
end;
if (sum<>sk) or (ssum<>ssk) then error;
sum:=0; ssum:=0;
for vs:=1 to vn do begin
sum:=sum+l(vs); ssum:=ssum+sum;
end;
if (sum<>sl) or (ssum<>ssl) then error;
sum:=0; ssum:=0;
for vs:=1 to vn do begin
sum:=sum+m(vs); ssum:=ssum+sum;
end;
if (sum<>sm) or (ssum<>ssm) then error;
jj:=1;
sn:=0; ssn:=0;
so:=0; sso:=0;
sp:=0; ssp:=0;
for ii:=1 to 3 do
for vs:=1 to vn do begin
n(ii).b(vs):=jj; sn:=sn+n(ii).b(vs); ssn:=ssn+sn;
o(ii).b(vs):=jj; so:=so+o(ii).b(vs); sso:=sso+so;
p(ii,vs):=jj; sp:=sp+p(ii,vs); ssp:=ssp+sp;
jj := (jj+1) mod 11;
end;
for ii:=1 to 3 do
with o(ii) do begin
b(vn+1):=jj; so:=b(vn+1)+so; sso:=sso+so;
end;
sum:=0; ssum:=0;
for ii := 1 to 3 do
for vs := 1 to vn do begin
sum:=sum+n(ii).b(vs); ssum:=ssum+sum;
end;
if (sum<>sn) or (ssum<>ssn) then error;
sum:=0; ssum:=0;
for ii := 1 to 3 do
for vs := 1 to vn do begin
sum:=sum+o(ii).b(vs); ssum:=ssum+sum;
end;
for ii := 1 to 3 do begin
sum := sum + o(ii).b(vn+1); ssum := ssum + sum;
end;
if (sum<>so) or (ssum<>sso) then error;
sum:=0; ssum:=0;
for ii := 1 to 3 do
for vs := 1 to vn do begin
sum:=sum+p(ii,vs); ssum:=ssum+sum;
end;
if (sum<>sp) or (ssum<>ssp) then error;
jj:=1;
sr:=0; ssr:=0;
st:=0; sst:=0;
st1:=0; sst1:=0;
for ii:=1 to vn do
for vs:=1 to vn do begin
r(ii).b(vs):=jj mod 11; sr:=sr+r(ii).b(vs); ssr:=ssr+sr;
t(ii,vs):=jj; st:=st+t(ii,vs); sst:=sst+st;
t1(ii,vs):=jj; st1:=st1+t1(ii,vs); sst1:=sst1+st1;
jj:=jj+1;
end;
ss:=0; sss:=0;
for ii:=1 to vn do
with s(ii) do
for jj:=1 to vn+1 do begin
b(jj):=jj+(ii-1)*(vn+1); ss:=ss+b(jj); sss:=sss+ss;
end;
if t1<>t then error;
t1:=t;
sum:=0; ssum:=0;
for ii := 1 to vn do
for vs := 1 to vn do begin
sum:=sum+r(ii).b(vs); ssum:=ssum+sum;
end;
if (sum<>sr) or(ssum<>ssr) then error;
sum:=0; ssum:=0;
for ii := 1 to vn do
for jj := 1 to vn+1 do begin
sum:=sum+s(ii).b(jj); ssum:=ssum+sum;
end;
if (sum<>ss) or (ssum<>sss) then error;
sum:=0; ssum:=0;
for ii := 1 to vn do
for vs := 1 to vn do begin
sum:=sum+t(ii,vs); ssum:=ssum+sum;
end;
if (sum<>st) or (ssum<>sst) then error;
sum:=0; ssum:=0;
for ii:=1 to vn do
for vs:=1 to vn do begin
sum:=sum+t1(ii,vs); ssum:=ssum+sum;
end;
if (sum<>st1) or (ssum<>sst1) then error;
end;
var s : semaphore;
step, result : integer;
sh : shadow;
begin
printnl; printtext('test array'); printnl;
for step := 2 to 7 do begin
printtext('test no :'); printnumber(step, 4);
if nil( sh ) then else remove( sh );
result := create( 'test a', testa(s, step), sh, 1000);
start ( sh, 0 );
end;
printtext('test end.');
end.
%
\f
(***********************
* ep test 3 *
* test record decl *
***********************)
process test3 ( var sv : system_vector );
process testb(var s:semaphore; vn : integer);
type
ta = packed record
a : 0..63;
b : 0..4095;
c : 0..255;
d : ^semaphore;
e : 0..31;
f : ^semaphore;
g : -10..10;
h : 0..10
end;
dd_type = array ( 1..vn ) of integer;
var
a1, a : ta;
r1, r : reference;
poo : pool 2;
e : packed record
i, j, k : integer;
l : 1 .. vn;
dd : dd_type;
ddd : array ( 1..vn ) of integer;
rest : ta;
rest1 : ta;
end;
step : integer;
b : packed record
i,j,k : integer;
l : 1..vn;
dd : dd_type;
a : 0..63;
b : 0..4095;
c : 0..255;
d : semaphore;
e : 0..31;
f : semaphore;
g : -10..10;
h : 0..10;
end;
c, c1 : packed record
a,b,c : 0..255
end;
d, d1 : record
a,b : 0..10;
c : record
a,b,c : 0..10;
d : record
a,b,c,d : 0..10;
e : array (1..vn) of 0..10;
end;
end;
end;
procedure printval( name : alfa; val : integer );
var r, r1 : reference;
begin
printtext( name ); printnumber( val, 5 ); printnl;
end;
procedure error(a,b : integer);
var r : reference;
begin
printtext(' error no =');
printnumber( a , 5 ) ; printnumber( b, 5 ); printnl;
end;
procedure test_return_of_refs;
var
l_r : reference;
arr : array ( 1.. vn ) of reference;
type
interm_arr = array ( b.c .. b.c + b.h ) of record
a : integer;
b : reference;
end;
procedure level_2;
var arr_var : interm_arr;
begin end;
begin
if vn = 1 then l_r :=: r1; (*vn = 1 => exception *)
level_2;
end;
begin
alloc( r1, poo, s );
alloc( r, poo, s );
with a do
begin
a := 63; h := 10;
b := 4095; g := 10;
c := 255; e := 31;
end; (* with a *)
a1 := a;
with d do
begin
a := 0; b := 10;
with c do
begin
a := 1; b := 2; c := 3;
d.d := 10; d.c := 0; d.b := 10; d.a := 0;
for step := 1 to vn do d.e(step) := step mod 11;
end; (* with c *)
end; (* with d *)
d1 := d;
with c do
begin
a := 255; b := 254; c := 253;
end;
c1 := c;
with b do
begin
i := maxint; j := 12345; k := -5432;
l:= vn;
for step := vn downto 1 do dd(step) := step;
a := 0; h := 10;
b := 4095; g := -10;
c := 255; e := 0;
end;
with e do
begin
i := maxint; j := 12345; k := -5432;
l := vn;
dd := b.dd;
rest := a;
end;
if d <> d1 then error( 2, vn);
if c <> c1 then error( 3, vn);
if a <> a1 then error( 4, vn );
with c do
if ( a<> 255) or ( b <> 254) or (c <> 253) then
error( 5, vn );
with d do
begin
printtext(' d = '); printnl;
printval(' a =#', a); printval( ' b =#', b );
printval(' c.a =#', c.a );
printval(' c.b =#', c.b );
printval(' c.c =#', c.c );
with c.d do
begin
printval(' c.d.d =#', d);
printval(' c.d.c =#', c);
printval(' c.d.b =#', b);
printval(' c.d.a =#', a);
printtext(' c.d.e =#');
for step := vn downto 1 do printnumber( e(step), 5 );
end; (* with c.d *)
end; (* with d *)
with b do
begin
printnl; printnl; printtext(' b = '); printnl;
printval(' i =#', i );
printval(' j =#', j );
printval(' k =#', k);
printval(' l ="#', l );
printtext(' dd = #' );
for step := 1 to vn do printnumber( dd(step), 5 );
printnl;
step := a;
printval(' a =#', step );
step := b;
printval(' b =#', step );
step := c;
printval(' c =#', step );
step := e;
printval(' e =#', step );
step := g;
printval(' g =#', step );
step := h;
printval(' h =#', step );
end; (* with *)
test_return_of_refs;
if nil(r) then error( 1, vn );
printnl; printtext(' end child ' ); printnl;
end; (* process *)
var s : semaphore; step, result : integer;
sh : shadow;
begin
for step := 1 to 15 do
begin
trace( step );
if nil(sh) then else remove(sh);
result := create ( 'test b', testb(s,step), sh, 1000);
trace( result );
start ( sh, 0);
end;
end.
%
\f
(*******************
* ep test 4 *
* test fejl *
*******************)
process testd(var s : semaphore; vn : integer);
type
sd = 1..vn;
su = 1..10;
ad = array (sd) of integer;
a = array (su) of integer;
ax = ! ad;
ay = ! a;
sx = sd;
sy = su;
adx = array (sx) of integer;
ady = array (sy) of integer;
ca = array (sd) of char;
se = set of sd;
po = pool vn;
po1=pool 5 of ad;
procedure pa(x : ad; var y : ca);
begin end;
procedure pb(x : ad; var y : ca); external;
function fa(a : integer): sd;
begin
fa:=vn;
end;
function fb(a : integer): ad;
begin
fb(1):=vn;
end;
const
c1 = a(1,2,3,4***0,8,9,10);
c2 = ad(1,2,3,4***0);
c3 = a(1,2,vn,7***0);
c4 = vn;
var
va : a;
vx : ay;
da : ad;
dx : ax;
vv : ca;
sa : sd;
sb : sx;
sc : su;
i : integer;
begin
i:=fa(vn);
i:=fb(1)(vn);
i:=va(vn);
i:=vx(vn);
i:=da(i);
i:=dx(i);
vv:='det er en text';
sa:=i;
sc:=i;
i:=succ(sa);
i:=abs(sa);
i:=pred(sa);
i:=ord(sa);
(*$4 1 0*)
end.
%
\f
(**********************
* ep test 5 *
* test dyn array *
**********************)
process test5(var sv: system_vector);
type
type_ay = packed array (1..5) of 0..31;
type_ax = array (1..4) of type_ay;
type_by = array (1..4) of integer;
type_bx = array (1..5) of type_by;
type_cy = packed array (1..4) of 0..31;
type_cx = array (1..4) of type_cy;
var
a : type_ax := type_ax (
type_ay( 1, 8, 9, 16, 17),
type_ay( 2, 7, 10, 15, 18),
type_ay( 3, 6, 11, 14, 19),
type_ay( 4, 5, 12, 13, 20) );
b : type_bx := type_bx (
type_by( 0, 1, 0, -1),
type_by( 1, 0, -1, 1),
type_by( 0, 1, 0, 0),
type_by( 1, 0, 0, 0),
type_by( 0, 0, 1, 0) );
c : type_cx;
const
facit = type_cx(
type_cy( 24, 10, 9, 7),
type_cy( 22, 12, 11, 5),
type_cy( 20, 14, 13, 3),
type_cy( 18, 16, 15, 1) );
var ok : boolean := true;
p, q, s, i : integer;
s_ok : boolean;
procedure error(n, p, q : integer);
begin
ok:=false;
printtext('error #'); printnumber(n, 4);
printnumber(p, 4); printnumber(q, 4);
printnl;
end;
procedure dyn(n : integer);
type
t_ay = packed array (1..n+1) of 0..31;
t_ax = array(1..4) of t_ay;
t_by = array (1..n) of integer;
t_bx = array (1..n+1) of t_by;
t_cy = packed array (1..n) of 0..31;
t_cx = array (1..n) of t_cy;
wrk = array (1..20) of integer;
var p, q, i : integer;
d_a : t_ax;
d_b : t_bx;
d_c : t_cx;
function mult(var result : t_cx) : wrk;
var p, q, i, s : integer;
begin
for p:=1 to 4 do
for q:=1 to 4 do begin
s:=0;
for i:=1 to 5 do s:=s + d_a(p,i) * d_b(i, q);
result(p,q):=s;
end;
for i:=1 to 20 do mult(i):=i;
end;
begin (* dyn *)
for p:=1 to 4 do
for q:=1 to 5 do begin
d_a(p,q):=a(p,q);
d_b(q,p):=b(q,p);
end;
for p:=4 downto 1 do
for q:=5 downto 1 do begin
if d_a(p,q) <> a(p,q) then error(3,p,q);
if d_b(q,p) <> b(q,p) then error(4,q,p);
end;
for i:=1 to 2 do begin
if 99 + i + mult(d_c)(20) <> i+119 then error(3,i,i);
for p:=4 downto 1 do
for q:=4 downto 1 do
if facit(p,q) <> d_c(p,q) then error(i,p,q);
end;
end; (* dyn *)
begin
printtext('test 5 ');
printnl;
dyn(4);
for p:=1 to 4 do
for q:=1 to 4 do begin
s:=0;
for i:=1 to 5 do s:=s + a(p,i) * b(i, q);
c(p,q):=s;
end;
s_ok:=ok; ok:=true;
for p:=4 downto 1 do
for q:=4 downto 1 do
if facit(p,q) <> c(p,q) then error(5,p,q);
if s_ok and ok then
printtext('test ok')
else
printtext('test not ok');
end.
%
\f
(********************
* ep test 6 *
* test dyn lock *
********************)
process test6(var sv : system_vector );
var s1, s2, a_sem : semaphore;
ref1, ref2, ref : reference;
i, j, p : integer;
po : pool 3 of array (1..100) of integer;
sh : shadow;
procedure error(a,b : integer);
begin
printtext('error'); printnumber(a, 5);
printnumber(b,5);
printnl;
end;
(*************************************************)
(* *)
(* get *)
process get(var s1, s2 : semaphore);
var rec, sen : reference;
a_sem : semaphore;
a, n, s, t : integer;
po : pool 2 of array (1..200) of integer;
procedure move(p, q, r : integer; var ref1, ref2 : reference);
type
ta = array (1..p) of integer;
tb = array (1..q) of integer;
tc = array (1..r) of integer;
buf1 = record
a : integer;
b : ta;
c : tc;
end;
buf2 = record
a : integer;
b : tb;
c : tc;
end;
buf3 = record
a : integer;
c : tc;
end;
begin
if (p<>0) and (q<>0) then
(*
lock ref1 as x : record
a : integer;
b : array ( 1..p ) of integer;
c : tc;
end
*) lock ref1 as x : buf1
do
(*
lock ref2 as y : record
a : integer;
b : array ( 1..q ) of integer;
c : tc;
end
*) lock ref2 as y : buf2
do y.c := x.c
else
if p=0 then
lock ref1 as x : buf3 do
(*
lock ref2 as y : record
a : integer;
b : array ( 1..q ) of integer;
c : tc;
end
*) lock ref2 as y : buf2
do y.c := x.c
else
if q=0 then
(*
lock ref1 as x : record
a : integer;
b : array ( 1..p ) of integer;
c : tc;
end
*) lock ref1 as x : buf1
do
lock ref2 as y : buf3 do y.c:=x.c
end;
begin
while true do begin
wait(rec, s1);
n:=rec^.u1;
lock rec as buf : record
a : integer;
b : array (1..n) of integer;
c : integer;
d : integer;
end
do begin
a:=buf.a; s:=buf.c; t:=buf.d
end;
alloc(sen, po, a_sem);
move(s,0,t,rec,sen);
move(0,t,s,rec,sen);
if s+t < n then move(s+t, s+t, n - s+t, rec, sen);
lock sen as buf : array (1..n+3) of integer do
begin
buf(1):=a; buf(n+2):=s; buf(n+3):=t
end;
signal(sen, s2);
release(rec);
end;
end; (*get*)
(* *)
(* end get *)
(****************************************)
procedure send_buf(length, n1, n2, fill : integer);
type
buf_type = record
a : integer;
b : array (1..length) of integer;
c : integer;
d : integer;
end;
var ref, ref1 : reference;
i : integer;
begin
alloc(ref1, po, a_sem);
ref1^.u1:=77;
alloc(ref, po, a_sem);
ref^.u1:=length;
lock ref as buf : buf_type do
with buf do begin
a:=99;
for i:=1 to n1 do b(i):=fill + n2 + i;
for i:=n1+1 to n1+n2 do b(i):=fill + i - n1;
for i:=n1+n2+1 to length do b(i):=fill + i;
c:=n1; d:=n2;
printnl; printtext('send #');
printnumber(a,4); printnumber(c,6); printnumber(d,6);
for i:=1 to length do begin
if (i-1) mod 10 = 0 then printnl;
printnumber(b(i), 5);
end;
end;
printnl;
signal(ref, s1);
wait(ref, s2);
lock ref as buf : buf_type do
with buf do begin
if a<>99 then error(1001, a);
if c<>n1 then error(1002, c);
if d<>n2 then error(1003, d);
for i:=1 to length do
if b(i)<>fill+i then error(i, b(i));
end;
release(ref);
if ref1^.u1 <> 77 then error(1004, ref1^.u1);
release(ref1);
end; (*send buf*)
begin
printnl; printtext('test ');
printnl;
alloc(ref1, po, a_sem);
ref1^.u2:=55;
i:=create('getproc', get(s1,s2), sh, 1000);
start(sh, 100);
p:=31; i:=1; j:=30;
send_buf(p, i, j, 100);
send_buf(p, j, i, 200);
send_buf(p, 7, 9, 50);
send_buf(10, 5, 2, 20);
if ref1^.u2 <> 55 then error(1005, ref1^.u2);
printtext('test end');
(*$4 1 0*)
end.
%
\f
(***********************
* ep test 7 *
* test init pool *
***********************)
process test7(var sv : system_vector);
process testa(p,q : integer);
type
r1 = record a,b:integer; c:char end;
r2 = array (1..10) of integer;
t1 = pool 1 of alfa;
t2 = array (0..2) of pool 3 of r1;
t3 = array (1..p,1..q) of pool 4 of byte;
ty = record
a : pool 5;
b : array (3..q) of pool 6 of integer;
end;
t4 = array (-1..q) of ty;
t5 = record
a : pool 7 of r2;
b : t2;
c : ty;
end;
var p1 : t1;
p2 : t2;
p3 : t3;
p4 : t4;
p5 : t5;
no : integer :=0;
i,j : integer;
r : reference;
sem, st : semaphore;
procedure ck(n,s:integer; var pul : pool 1);
var i : integer; ok : boolean := true;
p : integer := 1;
begin
printnl; printtext('pool #');
no:=no+1; printnumber(no,3);
printtext(' #'); printnumber(n,3); printnumber(s,5);
alloc(r,pul,sem);
printnumber(r^.size,10); printnumber(s,10);
s:=(s+1) div 2;
if r^.size <> s then ok:=false;
signal(r,st);
while openpool(pul) do begin
alloc(r, pul, sem); p:=p+1;
signal(r,st);
end;
printnumber(p, 10); printnumber(n, 10);
if p<>n then ok:=false;
for i:=1 to p do begin
wait(r,st);
release(r);
end;
if ok then printtext(' ok ') else printtext(' not ok ');
end;
begin
ck(2,12,p1);
ck(1,10,p1);
ck(1,12,p1);
for i:=0 to 2 do ck(3,5,p2(i));
for i:=1 to p do
for j:=1 to q do ck(4,1,p3(i,j));
for i:=-1 to q do begin
ck(5,0,p4(i).a);
for j:=3 to 5 do ck(6,2,p4(i).b(j));
end;
ck(7,20,p5.a);
for i:=0 to 2 do ck(3,5,p5.b(i));
ck(5,0,p5.c.a);
for i:=3 to q do ck(6,2,p5.c.b(i));
end;
var i : integer; sh : shadow;
begin
printnl; printtext('test pool '); printnl;
i:=create('testa', testa(3,5), sh, 3000);
start(sh, 0);
printnl; printtext('test end.');
end.
%
«eof»