|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 42240 (0xa500)
Types: TextFile
Names: »tsystest3 «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦f546e193b⟧
└─⟦this⟧ »tsystest3 «
message de enkelte testprocedurer part 1 (tsystest3);
boolean procedure test_proc (testno);
value testno;
integer testno;
begin
long antal;
integer i, j, k;
integer array ia (1 : 20);
long array la (1 : 2);
<* statusinformation *>
long array sidst_rørt (1 : antdiske);
integer array antal_io, segment_nr, blok_lgd,
bs_nr, antal_fejl, aktivitet (1 : antdiske);
integer first_buf, last_buf;
\f
boolean procedure ens_i (txt1, formel, i1, i2, i3, i4);
value i1, i2, i3, i4;
string txt1, formel;
integer i1, i2, i3, i4;
begin <* i1 ? i2 = i3 og i4 er forventet *>
if i3 <> i4 then
begin <* fejl *>
ens_i := false;
fejl (<:Fejl ved:>, - 1);
write (out, <<d>,
txt1, <: (:>, i1, "sp", 1, formel, "sp", 1, i2, <:):>,
"nl", 1, <:beregnet: :>, true, 10, i3,
"nl", 1, <:forventet::>, true, 10, i4,
"nl", 1, <:forskel: :>, true, 10, abs (i3 - i4));
if online then setposition (out, 0, 0);
if pause then system (10, 1, <:<10>pause pga fejl:>); <* pause *>
end fejl
else ens_i := true;
end procedure ens_i;
boolean procedure ens_l (txt1, formel, l1, l2, l3, l4);
value l1, l2, l3, l4;
string txt1, formel;
long l1, l2, l3, l4;
begin <* l1 ? l2 = l3 og l4 er forventet *>
if l3 <> l4 then
begin <* fejl *>
ens_l := false;
fejl (<:Fejl ved:>, - 1);
write (out, <<d>,
txt1, <: (:>, l1, "sp", 1, formel, "sp", 1, l2, <:):>,
"nl", 1, <:beregnet: :>, true, 16, l3,
"nl", 1, <:forventet::>, true, 16, l4,
"nl", 1, <:forskel: :>, true, 16, abs (l3 - l4));
if online then setposition (out, 0, 0);
if pause then system (10, 1, <:<10>pause pga fejl:>); <* pause *>
end fejl
else ens_l := true;
end procedure ens_l;
boolean procedure ens_r (txt1, formel, r1, r2, r3, r4);
value r1, r2, r3, r4;
string txt1, formel;
real r1, r2, r3, r4;
begin <* r1 ? r2 = r3 og r4 er forventet *>
real afv;
afv :=
if r3 = r4 then 0
else
if r3 = 0 or r4 = 0 then abs (r4 - r3)
else abs ((r4 - r3) / r4);
if afv > 1.0'-10 then
begin <* fejl *>
ens_r := false;
fejl (<:Fejl ved:>, - 1);
write (out, <<d.ddddddddd'-ddd>,
txt1, <: (:>, r1, "sp", 1, formel, "sp", 1, r2, <:):>,
<<-d.ddddddddd'-ddd>,
"nl", 1, <:beregnet: :>, r3,
"nl", 1, <:forventet::>, r4,
"nl", 1, <:forskel: :>, r4 - r3,
<<d.dd>, <: (afvigelsesfaktor :>, afv, <:):>);
if online then setposition (out, 0, 0);
if pause then system (10, 1, <:<10>pause pga fejl:>); <* pause *>
end fejl
else ens_r := true;
end procedure ens_r;
\f
procedure test_integer;
begin <* test integer regning *>
if datawrite or datatest then d_init (testno); <* open og positioner *>
for i1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for i2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
i3 := i1 + i2;
if datawrite then d_iwrite (i3)
else ens_i (<:integer-addition:>, <:+:>, i1, i2, i3, d_iread);
end;
for i1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for i2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
i3 := i1 - i2;
if datawrite then d_iwrite (i3)
else ens_i (<:integer-subtraktion:>, <:-:>, i1, i2, i3, d_iread);
end;
for i1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for i2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
i3 := i1 * i2;
if datawrite then d_iwrite (i3)
else ens_i (<:integer-multiplikation:>, <:*:>, i1, i2, i3, d_iread);
end;
for i1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for i2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
i3 := i1 // i2;
if datawrite then d_iwrite (i3)
else ens_i (<:integer-division:>, <://:>, i1, i2, i3, d_iread);
end;
for i1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for i2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
i3 := i1 mod i2;
if datawrite then d_iwrite (i3)
else ens_i (<:integer-modelo:>, <:mod:>, i1, i2, i3, d_iread);
end;
if datawrite or datatest then d_exit; <* close *>
end procedure test_integer;
\f
procedure test_long;
begin <* test long regning *>
if datawrite or datatest then d_init (testno); <* open og positioner *>
for l1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for l2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
l3 := l1 + l2;
if datawrite then d_lwrite (l3)
else ens_l (<:long-addition:>, <:+:>, l1, l2, l3, d_lread);
end;
for l1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for l2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
l3 := l1 - l2;
if datawrite then d_lwrite (l3)
else ens_l (<:long-subtraktion:>, <:-:>, l1, l2, l3, d_lread);
end;
for l1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for l2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
l3 := l1 * l2;
if datawrite then d_lwrite (l3)
else ens_l (<:long-multiplikation:>, <:*:>, l1, l2, l3, d_lread);
end;
for l1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for l2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
l3 := l1 // l2;
if datawrite then d_lwrite (l3)
else ens_l (<:long-division:>, <://:>, l1, l2, l3, d_lread);
end;
for l1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for l2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
l3 := l1 mod l2;
if datawrite then d_lwrite (l3)
else ens_l (<:long-modelo:>, <:mod:>, l1, l2, l3, d_lread);
end;
if datawrite or datatest then d_exit; <* close *>
end procedure test_long;
\f
procedure test_real;
begin <* test real regning *>
if datawrite or datatest then d_init (testno); <* open og positioner *>
for r1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
- 0.9 step 0.1 until - 0.1,
- 0.09 step 0.01 until - 0.01,
0,
0.01 step 0.01 until 0.09,
0.9 step 0.1 until 0.1,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for r2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
- 0.9 step 0.1 until - 0.1,
- 0.09 step 0.01 until - 0.01,
0,
0.01 step 0.01 until 0.09,
0.1 step 0.1 until 0.9,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
r3 := r1 + r2;
if datawrite then d_rwrite (r3)
else ens_r (<:real-addition:>, <:+:>, r1, r2, r3, d_rread);
end;
for r1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
- 0.9 step 0.1 until - 0.1,
- 0.09 step 0.01 until - 0.01,
0,
0.01 step 0.01 until 0.09,
0.1 step 0.1 until 0.9,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for r2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
- 0.9 step 0.1 until - 0.1,
- 0.09 step 0.01 until - 0.01,
0,
0.01 step 0.01 until 0.09,
0.1 step 0.1 until 0.9,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
r3 := r1 - r2;
if datawrite then d_rwrite (r3)
else ens_r (<:real-subtraktion:>, <:-:>, r1, r2, r3, d_rread);
end;
for r1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
- 0.9 step 0.1 until - 0.1,
- 0.09 step 0.01 until - 0.01,
0,
0.01 step 0.01 until 0.09,
0.1 step 0.1 until 0.9,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for r2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
- 0.9 step 0.1 until - 0.1,
- 0.09 step 0.01 until - 0.01,
0,
0.01 step 0.01 until 0.09,
0.1 step 0.1 until 0.9,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
r3 := r1 * r2;
if datawrite then d_rwrite (r3)
else ens_r (<:real-multiplikation:>, <:*:>, r1, r2, r3, d_rread);
end;
for r1 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
- 0.9 step 0.1 until - 0.1,
- 0.09 step 0.01 until - 0.01,
0,
0.01 step 0.01 until 0.09,
0.1 step 0.1 until 0.9,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
for r2 := - 900 step 100 until - 100,
- 90 step 10 until - 10,
- 9 step 1 until - 1,
- 0.9 step 0.1 until - 0.1,
- 0.09 step 0.01 until - 0.01,
0.01 step 0.01 until 0.09,
0.1 step 0.1 until 0.9,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900 do
begin
r3 := r1 / r2;
if datawrite then d_rwrite (r3)
else ens_r (<:real-division:>, <:/:>, r1, r2, r3, d_rread);
end;
if datawrite or datatest then d_exit; <* close *>
end procedure test_real;
\f
procedure test_exp;
begin <* test exponentiations beregning *>
if datawrite or datatest then d_init (testno); <* open og positioner *>
for i1 := 0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900,
1 000 step 1 000 until 9 000,
10 000 step 10 000 until 90 000,
100 000 step 100 000 until 900 000 do
for i2 := - 99 step 1 until 100 do
begin
if i1 <> 0 or i2 > 0 then
begin
r3 := i1 ** i2;
if datawrite then d_rwrite (r3)
else ens_r (<:integer-exponentiation:>, <:**:>, i1, i2, r3, d_rread);
end;
end;
for l1 := 0,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900,
1 000 step 1 000 until 9 000,
10 000 step 10 000 until 90 000,
100 000 step 100 000 until 900 000 do
for l2 := - 99 step 1 until 100 do
begin
if l1 <> 0 or l2 > 0 then
begin
r3 := l1 ** l2;
if datawrite then d_rwrite (r3)
else ens_r (<:long-exponentiation:>, <:**:>, l1, l2, r3, d_rread);
end;
end;
for r1 := 0,
0.01 step 0.01 until 0.09,
0.1 step 0.1 until 0.9,
1 step 1 until 9,
10 step 10 until 90,
100 step 100 until 900,
1 000 step 1 000 until 9 000,
10 000 step 10 000 until 90 000,
100 000 step 100 000 until 900 000 do
for r2 := - 99 step 1 until 100 do
begin
if r1 > 0 then
begin
r3 := r1 ** r2;
if datawrite then d_rwrite (r3)
else ens_r (<:real-exponentiation:>, <:**:>, r1, r2, r3, d_rread);
end;
end;
if datawrite or datatest then d_exit; <* close *>
end procedure test_exp;
\f
procedure wr_z_disk (forventet, læst);
long forventet, læst;
begin
integer i;
write (out, "nl", 1, true, 10, <:forventet:>,
<<zd>, forventet shift (- 40) extract 8,
".", 1, <<zdddddddddd>, forventet shift 8 shift (- 8) // 512,
".", 1, <<zdd>, forventet shift 8 shift (- 8) mod 512);
for i := 47 step - 1 until 0 do
write (out, if forventet shift (- i) extract 1 = 1 then "1" else ".", 1,
"sp", if i <> 40 then 0 else 1);
write (out, "nl", 1, true, 10, <:læst:>,
<<zd>, læst shift (- 40) extract 8,
".", 1, <<zdddddddddd>, læst shift 8 shift (- 8) // 512,
".", 1, <<zdd>, læst shift 8 shift (- 8) mod 512);
for i := 47 step - 1 until 0 do
write (out, if læst shift (- i) extract 1 = 1 then "1" else ".", 1,
"sp", if i <> 40 then 0 else 1);
if pause then system (10, 1, <:<10>pause pga fejl:>); <* pause *>
if online then setposition (out, 0, 0);
end procedure wr_z_disk;
procedure wr_z_tape (forventet, læst);
long forventet, læst;
begin
integer i;
write (out, "nl", 1, true, 10, <:forventet:>,
<<dd>, forventet shift (- 40) extract 8, ".", 1,
<<dd>, forventet shift (- 32) extract 8, ".", 1,
<<dd>, forventet shift (- 24) extract 8, ".", 1,
<<d________>, forventet extract 24);
for i := 47 step - 1 until 0 do
write (out, if forventet shift (- i) extract 1 = 1 then "1" else ".", 1,
"sp", if i mod 8 <> 0 or i < 24 then 0 else 1);
write (out, "nl", 1, true, 10, <:læst:>,
<<dd>, læst shift (- 40) extract 8, ".", 1,
<<dd>, læst shift (- 32) extract 8, ".", 1,
<<dd>, læst shift (- 24) extract 8, ".", 1,
<<d________>, læst extract 24);
for i := 47 step - 1 until 0 do
write (out, if læst shift (- i) extract 1 = 1 then "1" else ".", 1,
"sp", if i mod 8 <> 0 or i < 24 then 0 else 1);
if pause then system (10, 1, <:<10>pause pga fejl:>); <* pause *>
if online then setposition (out, 0, 0);
end procedure wr_z_tape;
\f
procedure test_tofrom (size);
value size;
integer size; <* bufferstørrelse pr buf i hw *>
begin
integer i, ejok;
zone z0 (size // 4, 1, xstderror);
zone z1 (size // 4, 1, xstderror);
zone z2 (size // 4, 1, xstderror);
zone z3 (size // 4, 1, xstderror);
zone z4 (size // 4, 1, xstderror);
zone z5 (size // 4, 1, xstderror);
zone z6 (size // 4, 1, xstderror);
zone z7 (size // 4, 1, xstderror);
zone z8 (size // 4, 1, xstderror);
zone z9 (size // 4, 1, xstderror);
ejok := 0;
size := size // 4; <* i dw *>
for i := 1 step 1 until size do
begin <* init med blok < 44 + lbnr < 4 + blok *>
z0 (i) := real (extend 0 shift 44 + extend i shift 4 + 0);
z1 (i) := real (extend 1 shift 44 + extend i shift 4 + 1);
z2 (i) := real (extend 2 shift 44 + extend i shift 4 + 2);
z3 (i) := real (extend 3 shift 44 + extend i shift 4 + 3);
z4 (i) := real (extend 4 shift 44 + extend i shift 4 + 4);
z5 (i) := real (extend 5 shift 44 + extend i shift 4 + 5);
z6 (i) := real (extend 6 shift 44 + extend i shift 4 + 6);
z7 (i) := real (extend 7 shift 44 + extend i shift 4 + 7);
z8 (i) := real (extend 8 shift 44 + extend i shift 4 + 8);
z9 (i) := real (extend 9 shift 44 + extend i shift 4 + 9);
end;
tofrom (z0, z1, size * 4);
tofrom (z1, z2, size * 4);
tofrom (z2, z3, size * 4);
tofrom (z3, z4, size * 4);
tofrom (z4, z5, size * 4);
tofrom (z5, z6, size * 4);
tofrom (z6, z7, size * 4);
tofrom (z7, z8, size * 4);
tofrom (z8, z9, size * 4);
tofrom (z9, z0, size * 4);
for i:= 1 step 1 until size do
begin <* test *>
if z0 (i) <> real (extend 1 shift 44 + extend i shift 4 + 1)
or z1 (i) <> real (extend 2 shift 44 + extend i shift 4 + 2)
or z2 (i) <> real (extend 3 shift 44 + extend i shift 4 + 3)
or z3 (i) <> real (extend 4 shift 44 + extend i shift 4 + 4)
or z4 (i) <> real (extend 5 shift 44 + extend i shift 4 + 5)
or z5 (i) <> real (extend 6 shift 44 + extend i shift 4 + 6)
or z6 (i) <> real (extend 7 shift 44 + extend i shift 4 + 7)
or z7 (i) <> real (extend 8 shift 44 + extend i shift 4 + 8)
or z8 (i) <> real (extend 9 shift 44 + extend i shift 4 + 9)
or z9 (i) <> real (extend 1 shift 44 + extend i shift 4 + 1) then
begin <* fejl *>
ejok := ejok + 1;
fejl (<:Fejl ved movecore, test no.:>, testno);
write (out,
"nl", 1, true, 16, <:forventet:>, true, 16, <:fundet:>, <:(blok.adr.blok):>,
"nl", 1, <<zd>, 1, ".", 1, <<zddddddd>, i, ".", 1, <<zd>, 1,
"sp", 2, <<zd>, z0 (i) shift (- 44) extract 4,
".", 1, <<zddddddd>, z0 (i) shift (- 4) extract 40,
".", 1, <<zd>, z0 (i) extract 4,
"nl", 1, <<zd>, 2, ".", 1, <<zddddddd>, i, ".", 1, <<zd>, 2,
"sp", 2, <<zd>, z1 (i) shift (- 44) extract 4,
".", 1, <<zddddddd>, z1 (i) shift (- 4) extract 40,
".", 1, <<zd>, z1 (i) extract 4,
"nl", 1, <<zd>, 3, ".", 1, <<zddddddd>, i, ".", 1, <<zd>, 3,
"sp", 2, <<zd>, z2 (i) shift (- 44) extract 4,
".", 1, <<zddddddd>, z2 (i) shift (- 4) extract 40,
".", 1, <<zd>, z2 (i) extract 4,
"nl", 1, <<zd>, 4, ".", 1, <<zddddddd>, i, ".", 1, <<zd>, 4,
"sp", 2, <<zd>, z3 (i) shift (- 44) extract 4,
".", 1, <<zddddddd>, z3 (i) shift (- 4) extract 40,
".", 1, <<zd>, z3 (i) extract 4,
"nl", 1, <<zd>, 5, ".", 1, <<zddddddd>, i, ".", 1, <<zd>, 5,
"sp", 2, <<zd>, z4 (i) shift (- 44) extract 4,
".", 1, <<zddddddd>, z4 (i) shift (- 4) extract 40,
".", 1, <<zd>, z4 (i) extract 4,
"nl", 1, <<zd>, 6, ".", 1, <<zddddddd>, i, ".", 1, <<zd>, 6,
"sp", 2, <<zd>, z5 (i) shift (- 44) extract 4,
".", 1, <<zddddddd>, z5 (i) shift (- 4) extract 40,
".", 1, <<zd>, z5 (i) extract 4,
"nl", 1, <<zd>, 7, ".", 1, <<zddddddd>, i, ".", 1, <<zd>, 7,
"sp", 2, <<zd>, z6 (i) shift (- 44) extract 4,
".", 1, <<zddddddd>, z6 (i) shift (- 4) extract 40,
".", 1, <<zd>, z6 (i) extract 4,
"nl", 1, <<zd>, 8, ".", 1, <<zddddddd>, i, ".", 1, <<zd>, 8,
"sp", 2, <<zd>, z7 (i) shift (- 44) extract 4,
".", 1, <<zddddddd>, z7 (i) shift (- 4) extract 40,
".", 1, <<zd>, z7 (i) extract 4,
"nl", 1, <<zd>, 9, ".", 1, <<zddddddd>, i, ".", 1, <<zd>, 9,
"sp", 2, <<zd>, z8 (i) shift (- 44) extract 4,
".", 1, <<zddddddd>, z8 (i) shift (- 4) extract 40,
".", 1, <<zd>, z8 (i) extract 4,
"nl", 1, <<zd>, 1, ".", 1, <<zddddddd>, i, ".", 1, <<zd>, 1,
"sp", 2, <<zd>, z9 (i) shift (- 44) extract 4,
".", 1, <<zddddddd>, z9 (i) shift (- 4) extract 40,
".", 1, <<zd>, z9 (i) extract 4);
if online then setposition (out, 0, 0);
if pause then system (10, 1, <:<10>pause pga fejl:>); <* pause *>
if ejok >= stop then
begin <* for mange fejl *>
wr_test (<:for mange fejl observeret, testen stoppes:>, - 1);
i := size;
end for mange fejl;
end fejl;
end;
end procedure test_tofrom;
\f
integer procedure test_disk (funk, antbs, aktiviteter);
integer funk, antbs, aktiviteter;
begin
<* funk = 1 => write seq, read cross og test data
funk = 2 => write cross, read seq og test data
funk = 3 => opret filer til diskcopy
funk = 4 => diskcopy
der laves io med maximal bufferlængde
ved copy læses fra filerne wrksysxxxi og skrives i wrksysxxxo
hvor xxx står for pågældende bsdeviceno
retur antal fejl
*>
integer i, j, k, aktive, buf, nr, res, maxbuflgd;
integer array ia (1 : 20);
long array la (1 : 2);
zone zhlp (1, 1, xstderror);
procedure wseq (nr, name, disk, mk, sh, segm, buflgd, testnr);
long array name, disk;
integer nr, mk, sh, segm, buflgd, testnr;
begin
zone z (buflgd * 128 * sh, sh, xstderror);
integer i, j, k;
long l;
long field lf;
write (out, "nl", 1, <:write seq :>, disk,
<<d>, <: segm.:>, segm, <: bloklgd.:>, buflgd);
if online then setposition (out, 0, 0);
xnulstil (z);
open (z, mk, name, 1 shift 9);
setposition (z, 0, 0);
blok_lgd (nr) := buflgd;
segment_nr (nr) := segm;
aktivitet (nr) := 1;
l := extend testnr shift 40;
j := 0;
for i := 1 step buflgd until segm do
begin <* write seq *>
if test then wr_test (<:før outrec6:>, i);
outrec6 (z, buflgd * 512);
for lf := 4 step if datacheck then 4 else 32 * 4 until buflgd * 512 do
z.lf := l + extend j * 512 + lf;
j := j + buflgd;
segment_nr (nr) := segment_nr (nr) - buflgd;
end;
close (z, false);
end procedure wseq;
integer procedure rseq (nr, name, disk, mk, sh, segm, buflgd, testnr);
long array name, disk;
integer nr, mk, sh, segm, buflgd, testnr;
begin
zone z (buflgd * 128 * sh, sh, xstderror);
integer i, j, k, ejok;
long l;
long field lf;
write (out, "nl", 1, <:read seq :>, disk,
<<d>, <: segm.:>, segm, <: bloklgd.:>, buflgd);
if online then setposition (out, 0, 0);
open (z, mk, name, 1 shift 9);
setposition (z, 0, 0);
blok_lgd (nr) := buflgd;
segment_nr (nr) := segm;
aktivitet (nr) := 2;
ejok := 0;
l := extend testnr shift 40;
j := 0;
for i := 1 step buflgd until segm do
begin <* read seq *>
if test then wr_test (<:før inrec6:>, i);
inrec6 (z, buflgd * 512);
for lf := 4 step if datacheck then 4 else 32 * 4 until buflgd * 512 do
if z.lf <> l + extend j * 512 + lf then
begin <* fejl *>
antal_fejl (nr) := antal_fejl (nr) + 1;
ejok := ejok + 1;
fejl (<:Fejl ved seq read:>, - 1);
write (out, <<d>, <:læst på :>, disk,
<: segment :>, j + (lf - 4) // 512,
<: adr :>, (lf - 4) mod 512,
"nl", 1, <: (disk.segm.hw / nr<40+adr):>);
wr_z_disk (l + extend j * 512 + lf, z.lf);
if ejok >= stop then
begin <* for mange fejl *>
wr_test (<:for mange fejl observeret, testen stoppes:>, - 1);
i := segm;
lf := buflgd * 512;
end for mange fejl;
end fejl;
j := j + buflgd;
segment_nr (nr) := segment_nr (nr) - buflgd;
end;
close (z, false);
rseq := ejok;
end procedure rseq;
procedure wcross (nr, name, disk, mk, sh, segm, buflgd, testnr);
long array name, disk;
integer nr, mk, sh, segm, buflgd, testnr;
begin
zone z (buflgd * 128 * sh, sh, xstderror);
integer i, j, k;
boolean lav;
long l;
long field lf;
write (out, "nl", 1, <:write cross :>, disk,
<<d>, <: segm.:>, segm, <: bloklgd.:>, buflgd);
if online then setposition (out, 0, 0);
xnulstil (z);
open (z, mk, name, 1 shift 9);
setposition (z, 0, 0);
blok_lgd (nr) := buflgd;
segment_nr (nr) := segm;
aktivitet (nr) := 3;
lav := true;
l := extend testnr shift 40;
for i := 1 step buflgd until segm do
begin <* write cross *>
j := if lav then (i - 1) // 2 else segm - (i - 1 + buflgd) // 2;
if test then wr_test (<:før setposition til segment:>, j);
setposition (z, 0, j);
if test then wr_test (<:før outrec6:>, i);
outrec6 (z, buflgd * 512);
lav := not lav;
for lf := 4 step if datacheck then 4 else 32 * 4 until buflgd * 512 do
z.lf := l + extend j * 512 + lf;
segment_nr (nr) := segment_nr (nr) - buflgd;
end;
close (z, false);
end procedure wcross;
integer procedure rcross (nr, name, disk, mk, sh, segm, buflgd, testnr);
long array name, disk;
integer nr, mk, sh, segm, buflgd, testnr;
begin
zone z (buflgd * 128 * sh, sh, xstderror);
integer i, j, k, ejok;
boolean lav;
long l;
long field lf;
write (out, "nl", 1, <:read cross :>, disk,
<<d>, <: segm.:>, segm, <: bloklgd.:>, buflgd);
if online then setposition (out, 0, 0);
open (z, mk, name, 1 shift 9);
setposition (z, 0, 0);
blok_lgd (nr) := buflgd;
segment_nr (nr) := segm;
aktivitet (nr) := 4;
ejok := 0;
lav := true;
l := extend testnr shift 40;
for i := 1 step buflgd until segm do
begin <* read cross *>
j := if lav then (i - 1) // 2 else segm - (i - 1 + buflgd) // 2;
if test then wr_test (<:før setposition til segment:>, j);
setposition (z, 0, j);
if test then wr_test (<:før inrec6:>, i);
inrec6 (z, buflgd * 512);
lav := not lav;
for lf := 4 step if datacheck then 4 else 32 * 4 until buflgd * 512 do
if z.lf <> l + extend j * 512 + lf then
begin <* fejl *>
antal_fejl (nr) := antal_fejl (nr) + 1;
ejok := ejok + 1;
fejl (<:Fejl ved cross read:>, - 1);
write (out, <<d>, <:læst på :>, disk,
<: segment :>, j + (lf - 4) // 512,
<: adr :>, (lf - 4) mod 512,
"nl", 1, <: (disk.segm.hw / nr<40+adr):>);
wr_z_disk (l + extend j * 512 + lf, z.lf);
if ejok >= stop then
begin <* for mange fejl *>
wr_test (<:for mange fejl observeret, testen stoppes:>, - 1);
i := segm;
lf := buflgd * 512;
end for mange fejl;
end fejl;
segment_nr (nr) := segment_nr (nr) - buflgd;
end;
close (z, false);
rcross := ejok;
end procedure rcross;
procedure io_proc (nr, funk, buflgd, bsno);
value nr, funk, buflgd, bsno;
integer nr, funk, buflgd, bsno;
begin
<* funk som for hoved proceduren
buflgd er antal segm i zonen
bsno er den ønskede disks bsno
der laves altid filer med et helt antal buffere
*>
integer ejok;
ejok := 0;
<* lav plads 2000 hw stack og til zonebuffer(e) *>
xclaim (2000 + (if funk <> 5 then 1 else 2) * buflgd * 512);
if funk >= 1 and funk <= 4 then
begin
boolean lav;
integer i, j, k, segm;
integer array tail (1 : 10);
long array name, disk (1 : 2);
zone z (1, 1, xstderror);
makename (nr, name, 'i');
open (z, 4, name, 1 shift 9);
close (z, true);
monitor (48, z, 0, tail); <* clear evt gammel fil *>
makename (nr, name, 'o');
open (z, 4, name, 1 shift 9);
close (z, true);
monitor (48, z, 0, tail); <* clear evt gammel fil *>
segm := 0;
xclaimproc (0, bsno, disk, 0, segm, i);
if funk >= 3 then segm := segm // i // 2 * i; <* 2 hele filer *>
if maxsegm > 0 and segm > maxsegm then segm := maxsegm; <* benyt parameter *>
if segm > 0 and segm < buflgd then buflgd := segm
else segm := segm // buflgd * buflgd; <* helt antal buffere *>
tail (1) := segm;
tofrom (tail.laf2, disk, 8);
tail (6) := systime (7, 0, 0.0);
tail (7) := tail (8) := tail (9) := 0;
tail (10) := buflgd;
if disk (1) = long <::> then <* ingen disk *>
else
if segm = 0 then <* ingen reso *>
else
case funk of
begin
begin <* 1 = write seq, read cross og test data *>
makename (nr, name, 'i');
open (z, 4, name, 1 shift 9);
i := monitor (40, z, 0, tail); <* create entry *>
if i <> 0 then segm := 0; <* kan ikke oprette filen *>
wseq (nr, name, disk, 4, 1, segm, buflgd, nr);
ejok := rcross (nr, name, disk, 4, 1, segm, buflgd, nr);
if ejok = 0 then monitor (48, z, 0, tail) <* clear fil hvis ok *>
else write (out, "nl", 1, <:pga. fejl slettes :>, name,
<: på :>, disk, <: ikke:>);
close (z, true);
end 1;
begin <* 2 = write cross, read seq og test data *>
makename (nr, name, 'i');
open (z, 4, name, 1 shift 9);
i := monitor (40, z, 0, tail); <* create entry *>
if i <> 0 then segm := 0; <* kan ikke oprette filen *>
wcross (nr, name, disk, 4, 1, segm, buflgd, nr);
ejok := rseq (nr, name, disk, 4, 1, segm, buflgd, nr);
if ejok = 0 then monitor (48, z, 0, tail) <* clear fil hvis ok *>
else write (out, "nl", 1, <:pga. fejl slettes :>, name,
<: på :>, disk, <: ikke:>);
if ejok = 0 then monitor (48, z, 0, tail) <* clear fil hvis ok *>
else write (out, "nl", 1, <:pga. fejl slettes :>, name,
<: på :>, disk, <: ikke:>);
close (z, true);
end 2;
begin <* 3 = opret og check filer til diskcopy *>
makename (nr, name, 'o');
open (z, 4, name, 1 shift 9);
i := monitor (40, z, 0, tail); <* create entry *>
if i <> 0 then segm := 0; <* kan ikke oprette filen *>
close (z, true);
makename (nr, name, 'i');
open (z, 4, name, 1 shift 9);
i := monitor (40, z, 0, tail); <* create entry *>
if i <> 0 then segm := 0; <* kan ikke oprette filen *>
wseq (nr, name, disk, 4, 1, segm, buflgd, nr); <* skriv *>
ejok := rseq (nr, name, disk, 4, 1, segm, buflgd, nr); <* checklæs *>
if ejok <> 0 then antal_fejl (nr) := - (abs antal_fejl (nr)); <* død *>
close (z, true);
end 3;
begin <* 4 = slet filer fra diskcopy *>
makename (nr, name, 'o');
open (z, 4, name, 1 shift 9);
close (z, true);
if antal_fejl (nr) = 0
then monitor (48, z, 0, tail) <* clear fil hvis ok *>
else write (out, "nl", 1, <:pga. fejl slettes :>, name, <: ikke:>);
makename (nr, name, 'i');
open (z, 4, name, 1 shift 9);
close (z, true);
monitor (48, z, 0, tail); <* slet fil *>
end 4;
end case;
end funk 1..4
else
if funk = 5 then
begin <* disk-disk-copy *>
integer i, j, k, se, bu, segm_o, segm_i, nr_i;
integer array tail_i, tail_o (1 : 10);
long array name_i, name_o, disk_i, disk_o (1 : 2), la (1 : 5);
zone z_i, z_o (1, 1, xstderror);
makename (nr, name_o, 'o');
open (z_o, 4, name_o, 1 shift 9);
segm_o := if monitor (42, z_o, 0, tail_o) <> 0 then 0 else tail_o (1);
tofrom (disk_o, tail_o.laf2, 8);
if segm_o > 0 then <* det skal den være... *>
for i := 1 step 1 until aktiviteter do
begin <* kopier fra alle til mig *>
nr_i := (nr - 1 + i) mod aktiviteter + 1; <* start ved disken efter mig *>
makename (nr_i, name_i, 'i');
open (z_i, 4, name_i, 1 shift 9);
segm_i := if monitor (42, z_i, 0, tail_i) <> 0 then 0 else tail_i (1);
tofrom (disk_i, tail_i.laf2, 8);
if segm_i > 0 <* filen existerer *>
and (xnameok (tail_i.laf2, disc1) <* første navnekrav ok *>
or (xnameok (tail_i.laf2, disc2) and disc2 (1) <> long <::>)) <* andet navn ok *>
then
begin <* kopier *>
trap (trap_copy);
bu := buflgd;
se := if segm_i >= segm_o then segm_o else segm_i;
if se > 0 and se < bu then bu := se
else se := se // bu * bu; <* helt antal buffere *>
write (out, <<d>, "nl", 1,
<:diskcopy :>, disk_i, <: -> :>, disk_o,
<: segm.:>, se, <: bloklgd.:>, bu);
if online then setposition (out, 0, 0);
segment_nr (nr) := se;
aktivitet (nr) := 5;
xcopyzone (z_i, z_o, extend se * 512, bu * 512, 1);
ejok := rseq (nr, name_o, disk_o, 4, 1, se, bu, nr_i);
if false then
trap_copy:
begin <* hertil trappes kun *>
write (out, <<d>, "nl", 1,
<:Fejlet ved :>,
<:diskcopy :>, disk_i, <: -> :>, disk_o,
<: segm.:>, se, <: bloklgd.:>, bu);
trap (nr); <* trap videre *>
end trapped;
end kopier;
close (z_i, false);
end pr bs;
close (z_o, true);
end funk 5;
end procedure io_proc;
procedure write_status (z);
zone z;
begin <* udskriv status for aktiviteter *>
integer nr, i, j, k;
long array la (1 : 2);
real kl;
integer array ia (1 : 20);
zone zhlp (1, 1, xstderror);
systime (5, 0, kl);
writeint (z, "nl", 1, <:Aktivitetsstatus kl. :>,
<<zddd.dd>, round (kl),
<: bufferinterval :>, <<d>, first_buf, ".", 2, last_buf,
"nl", 1,
<:aktivitet :>,
<:disknavn :>,
<: rørt:>,
<: antio:>,
<: bloklgd:>,
<: restseg:>,
<: fejl:>,
<: waitbuf:>,
<: status:>);
for nr := 1 step 1 until aktiviteter do
begin
xclaimproc (0, bs_nr (nr), la, 0, 0, 0);
systime (4, sidst_rørt (nr) / 10000, kl);
system (12, nr, ia);
writeint (z, "nl", 1,
true, 10, case aktivitet (nr) + 1 of (
<:tom:>, <:w.seq:>, <:r.seq:>, <:w.cross:>, <:r.cross:>, <:copy:>),
true, 12, la,
<<zddd.dd>, round (kl),
<<bdddddd>, antal_io (nr),
<<bddddddd>, blok_lgd (nr),
<<bddddddd>, segment_nr (nr),
<<-bdddd>, antal_fejl (nr),
<<bddddddd>, ia (1),
"sp", 1, (case ia (8) + 1 of
(<:empty:>, <:expl pas:>, <:impl pas:>, <:activate:>)));
end;
write (z, "nl", 1, <:eventkø::>);
j := 0;
repeat
i := monitor (66, zhlp, j, ia);
if i = 0 then write (z, <: mess:>) else
if i > 0 then write (z, <<dddddddd>, j);
until i < 0;
write (z, "nl", 1);
getzone6 (z, ia);
if ia (1) <> 4 then setposition (z, 0, 0);
end procedure write_status;
\f
activity (aktiviteter); <* en activity pr faktisk disk *>
system (5, 86, ia); <* first/last buf *>
first_buf := ia (1);
last_buf := ia (2);
i := if funk < 3 then aktiviteter else aktiviteter * 2; <* hver copy bruger 2 buffere *>
system (5, system (6, 0, la) + 26, ia); <* get buffer claim *>
if ia (1) shift (- 12) < i
then system (9, i - ia (1) shift (- 12), <:<10>bufsless:>);
maxbuflgd := xmaxbuflgd (aktiviteter, aktiviteter * 4000, false) // 512;
if funk = 5 then maxbuflgd := maxbuflgd // 2; <* copy bruger 2 gange *>
if maxbuflgd < 1 then maxbuflgd := 1;
if buflgd > 0 and maxbuflgd > buflgd
then maxbuflgd := buflgd <* benyt parameter *>
else
if buflgd <= 0 and maxbuflgd > 100 then maxbuflgd := 100; <* max 100 seg *>
buf := 0;
for res := monitor (66, zhlp, buf, ia) while res <> - 1 do
if res = 0 then
begin <* fjern gamle messages *>
monitor (20, zhlp, buf, ia); <* get message *>
ia (9) := 2; <* rejected *>
monitor (22, zhlp, buf, ia); <* send answer *>
getzone6 (zhlp, ia);
write (out, <<d>, "nl", 1, <:returner message fra :>, ia.laf2);
if online then setposition (out, 0, 0);
buf := 0; <* forfra *>
end fjern message;
aktive := nr := 0;
for i := 0 step 1 until antbs - 1 do
if (xclaimproc (0, i, la, 0, 0, j) and la (1) <> long <::>) <* disk ok *>
and (xnameok (la, disc1) <* første navnekrav ok *>
or (xnameok (la, disc2) and disc2 (1) <> long <::>)) <* andet navn ok *>
then
begin <* disken existerer og er ikke udmasket *>
nr := nr + 1;
if antal_fejl (nr) >= 0 then
begin <* ikke nedgået *>
systemtid (0, sidst_rørt (nr));
bs_nr (nr) := i;
aktive := aktive + 1;
res := newactivity (nr, 0, io_proc, nr, funk, maxbuflgd, i) extract 24;
if res > 0 then <* pasivated activity *> else
if res = 0 then aktive := aktive - 1 <* afsluttet activity *>
else
begin <* fejl *>
xwritealarm;
if trapstop then system (9, nr, <:<10>stop...:>);
fejl (<:activity terminated in errormode:>, res);
antal_fejl (nr) := - (abs (antal_fejl (nr)) + 1); <* marker døden *>
aktive := aktive - 1;
if alarmcause extract 24 = - 9 <* break *>
then goto trap_heltyt;
end fejl;
end ej nedgået;
end disk ok;
while aktive > 0 do
begin <* reaktiver *>
buf := 0;
for res := w_activity (buf) while res < 0 do
begin <* uventet buffer *>
if test then write (out, <<d>, "nl", 1, <:w-activity=:>, res, <: buf.:>, buf);
end uventet;
if res = 0 then
begin <* skriv status *>
zone z (128, 1, xstderror);
monitor (20, z, buf, ia); <* get message *>
ia (9) := 2; <* rejected *>
monitor (22, z, buf, ia); <* send answer *>
getzone6 (z, ia);
open (z, ia (1), ia.laf2, 0);
write_status (z);
close (z, false);
end fjern message
else
begin <* answer *>
nr := res;
systemtid (0, sidst_rørt (nr));
antal_io (nr) := antal_io (nr) + 1;
if test then write (out, <<d>, "nl", 1, <:activate (:>, nr, <:) buf.:>, buf, "sp", 1);
res := activate (nr) extract 24;
if res > 0 then <* pasivated activity *> else
if res = 0 then aktive := aktive - 1 <* afsluttet activity *>
else
begin <* fejl *>
xwritealarm;
if trapstop then system (9, nr, <:<10>stop...:>);
fejl (<:activity terminated in errormode:>, res);
antal_fejl (nr) := - (abs (antal_fejl (nr)) + 1); <* marker døden *>
aktive := aktive - 1;
if alarmcause extract 24 = - 9 <* break *>
then goto trap_heltyt;
end fejl;
end answer;
end while aktive > 0;
j := 0;
for i := 1 step 1 until aktiviteter do
j := j + antal_fejl (i);
test_disk := j;
end procedure test_disk;
message filen fortsættes;
▶EOF◀