|
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: 19200 (0x4b00)
Types: TextFile
Names: »tsystest4 «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦f546e193b⟧
└─⟦this⟧ »tsystest4 «
message de enkelte testprocedurer part 2 (tsystest4);
integer procedure test_tape (name);
long array name;
begin
integer ejok, sh, mk, bl, bu, i, j;
zone z (1, 1, xstderror);
procedure wseq (nr, name, mk, sh, filer, blokke, buflgd, testnr);
long array name;
integer nr, mk, sh, filer, blokke, buflgd, testnr;
begin
zone z (buflgd * 128 * sh, sh, xstderror);
integer f, b, i, j, k;
long l;
long field lf;
write (out, "nl", 1, <:write seq :>, name,
"sp", 1, if mk shift (- 14) extract 1 = 0 then <:high:> else <:low:>,
<: density:>,
filer, if filer <> 1 then <: filer:> else <: fil:>,
<: af:>, blokke, <: *:>, buflgd, <: segm,:>, sh, <:'bufret:>);
if online then setposition (out, 0, 0);
blok_lgd (nr) := buflgd;
segment_nr (nr) := filer * blokke * buflgd;
for f := 0 step 1 until filer - 1 do
begin <* pr fil *>
if test then wr_test (<:fil:>, f);
xnulstil (z);
open (z, mk, name, 1 shift 9);
setposition (z, f, 0);
for b := 0 step 1 until blokke - 1 do
begin <* pr blok *>
l := extend testnr shift 40 + extend f shift 32 + extend b shift 24;
if test then wr_test (<:blok:>, b);
outrec6 (z, buflgd * 512);
for lf := 4 step if datacheck then 4 else 32 * 4 until buflgd * 512 do
z.lf := l + lf;
segment_nr (nr) := segment_nr (nr) - buflgd;
end pr blok;
close (z, false);
end pr fil;
end procedure wseq;
integer procedure rseq (nr, name, mk, sh, filer, blokke, buflgd, testnr);
long array name;
integer nr, mk, sh, filer, blokke, buflgd, testnr;
begin
zone z (buflgd * 128 * sh, sh, xstderror);
integer f, b, i, j, k, ejok;
long l;
long field lf;
write (out, "nl", 1, <:read seq :>, name,
"sp", 1, if mk shift (- 14) extract 1 = 0 then <:high:> else <:low:>,
<: density:>,
filer, if filer <> 1 then <: filer:> else <: fil:>,
<: af:>, blokke, <: *:>, buflgd, <: segm,:>, sh, <:'bufret:>);
if online then setposition (out, 0, 0);
ejok := 0;
xnulstil (z);
open (z, mk, name, 1 shift 9);
blok_lgd (nr) := buflgd;
segment_nr (nr) := filer * blokke * buflgd;
for f := 0 step 1 until filer - 1 do
begin <* pr fil *>
if test then wr_test (<:fil:>, f);
setposition (z, f, 0);
for b := 0 step 1 until blokke - 1 do
begin <* pr blok *>
l := extend testnr shift 40 + extend f shift 32 + extend b shift 24;
if test then wr_test (<:blok:>, b);
inrec6 (z, buflgd * 512);
for lf := 4 step if datacheck then 4 else 32 * 4 until buflgd * 512 do
if z.lf <> l + lf
then
begin <* fejl *>
antal_fejl (nr) := antal_fejl (nr) + 1;
ejok := ejok + 1;
fejl (<:Fejl ved seq read:>, - 1);
write (out, <<d>, <:fil.:>, f, <:, blok.:>, b, <:, adr.:>, lf,
"nl", 1, <:(nr.fil.blok.adr / nr < 40 + fil < 32 + blok < 24 + adr):>);
wr_z_tape (l + lf, z.lf);
if ejok >= stop then
begin <* for mange fejl *>
wr_test (<:for mange fejl observeret, testen stoppes:>, - 1);
f := filer;
b := blokke;
lf := buflgd * 512;
end for mange fejl;
end fejl;
segment_nr (nr) := segment_nr (nr) - buflgd;
end pr blok;
end pr fil;
close (z, false);
rseq := ejok;
end procedure rseq;
integer procedure rback (nr, name, mk, sh, filer, blokke, buflgd, testnr);
long array name;
integer nr, mk, sh, filer, blokke, buflgd, testnr;
begin
zone z (buflgd * 128 * sh, sh, xstderror);
integer f, b, i, j, k, ejok;
long l;
long field lf;
write (out, "nl", 1, <:read backwards :>, name,
"sp", 1, if mk shift (- 14) extract 1 = 0 then <:high:> else <:low:>,
<: density:>,
filer, if filer <> 1 then <: filer:> else <: fil:>,
<: af:>, blokke, <: *:>, buflgd, <: segm,:>, sh, <:'bufret:>);
if online then setposition (out, 0, 0);
ejok := 0;
xnulstil (z);
open (z, mk, name, 1 shift 9);
blok_lgd (nr) := buflgd;
segment_nr (nr) := filer * blokke * buflgd;
for f := filer - 1 step - 1 until 0 do
begin <* pr fil *>
if test then wr_test (<:fil:>, f);
for b := blokke - 1 step - 1 until 0 do
begin <* pr blok *>
setposition (z, f, b);
l := extend testnr shift 40 + extend f shift 32 + extend b shift 24;
if test then wr_test (<:blok:>, b);
inrec6 (z, buflgd * 512);
for lf := 4 step if datacheck then 4 else 32 * 4 until buflgd * 512 do
if z.lf <> l + lf
then
begin <* fejl *>
antal_fejl (nr) := antal_fejl (nr) + 1;
ejok := ejok + 1;
fejl (<:Fejl ved seq read backwards:>, - 1);
write (out, <<d>, <:fil.:>, f, <:, blok.:>, b, <:, adr.:>, lf,
"nl", 1, <:(nr.fil.blok.adr / nr < 40 + fil < 32 + blok < 24 + adr):>);
wr_z_tape (l + lf, z.lf);
if ejok >= stop then
begin <* for mange fejl *>
wr_test (<:for mange fejl observeret, testen stoppes:>, - 1);
f := 0;
b := 0;
lf := buflgd * 512;
end for mange fejl;
end fejl;
segment_nr (nr) := segment_nr (nr) - buflgd;
end pr blok;
end pr fil;
close (z, false);
rback := ejok;
end procedure rback;
for mk := 0 shift 12 + 18, 4 shift 12 + 18 do
begin
write (out, "nl", 1, <:tapetest med :>,
"sp", 1, if mk shift (- 14) extract 1 = 0 then <:high:> else <:low:>,
<: density:>);
if online then setposition (out, 0, 0);
open (z, mk, name, 1 shift 9);
setposition (z, 0, 0); <* fortæl keystone om high/low density *>
setposition (z, 0, 0); <* fortæl keystone om high/low density *>
close (z, false);
wseq (1, name, mk, 3, 3, 10, 84, 1);
ejok := rback (1, name, mk, 3, 3, 10, 84, 1)
+ rseq (1, name, mk, 3, 3, 10, 84, 1);
sh := if shares > 0 then shares else 3;
bu := 0;
repeat
bu := if buflgd > 0 and buflgd <= 84 then buflgd else
if bu <= 0 then 1 else 84;
bl := if maxsegm > 0 then (maxsegm + bu - 1) // bu else 100;
if bl < 1 then bl := 1;
wseq (1, name, mk, sh, 1, bl, bu, 1);
ejok := ejok + rseq (1, name, mk, sh, 1, bl, bu, 1)
until buflgd > 0 or bu >= 84;
end;
close (z, true);
test_tape := antal_fejl (1);
end procedure test_tape;
\f
integer procedure test_ioc;
begin
<* skriv og læs i diskfil,
bufferplaceringen i lagret ændres i spring på 2 over 16 halvordsadr
segmentantallet pr io ændres fra 1 til 88 ( lidt over 64kbyte)
der checkes om der skrives ved siden af det forventede
*>
integer i, j, k, adr, adr_base, adr_rel, buf_start, buf_slut, segm, ant_fejl;
integer array tail (1 : 10), ia (1 : 20);
long array name, disk (1 : 2);
integer field inf;
zone z (128 * 90, 1, xstderror);
procedure io (z, fra, til, input);
zone z;
integer fra, til;
boolean input;
begin
<* lav io vha z med buffer startende i fra og sluttende i til
hvor fra og til kan opfattes som integer array fields
hvis input er true laves input ellers output
*>
integer array zd (1 : 20), sh (1 : 12);
integer i, j;
if test then
begin
wr_test (if input then <:input:> else <:output:>, (til - fra) // 512);
write (out, <: segm, fra.:>, <<d>, fra, <: til.:>, til);
end test;
getzone6 (z, zd);
getshare6 (z, sh, 1);
zd (17) := 1; <* used share *>
sh (1) := 0; <* free share *>
sh (2) := 1; <* first shared *>
sh (3) := sh (2) + zd (20) * 4 - 1; <* last shared *>
if input
then sh (4) := 3 shift 12 + 0 <* input *>
else sh (4) := 5 shift 12 + 0; <* output *>
sh (5) := zd (19) + sh (2) + fra; <* first abs adr *>
sh (6) := sh (5) + (til - fra); <* last abs adr *>
sh (7) := 0; <* segm count *>
sh (8) := sh (9) := sh (10) := sh (11) := 0; <* ubenyttet *>
sh (12) := sh (5); <* top transferred *>
setzone6 (z, zd);
setshare6 (z, sh, 1);
if monitor (16, z, 1, ia) = 0
then system (9, 6, <:<10>break:>);
i := monitor (18, z, 1, ia);
if i <> 1 then xstderror (z, 1 shift i, 0) else
if ia (1) <> 0 then xstderror (z, ia (1), ia (2));
end procedure io;
getzone6 (z, ia);
adr_rel := (ia (19) + 2) // 2 * 2; <* første ordadr i buffer *>
system (5, ownadr + 98, ia); <* get current base *>
adr_base := ia (1); <* processens relative forskydning *>
if test then
begin
wr_test (<:io test, adresser::>, - 1);
write (out, <<d>,
<: proc-base=:>, adr_base,
<: z-rel-adr=:>, adr_rel,
<: buf-rel-adr=:>, adr);
if online then setposition (out, 0, 0);
end test;
ant_fejl := 0;
makename (1, name, 'i');
open (z, 4, name, 1 shift 9);
close (z, true);
monitor (48, z, 0, tail); <* clear evt gammel fil *>
tail (1) := 88;
tofrom (tail.laf2, disc1, 8);
tail (6) := systime (7, 0, 0.0);
tail (7) := tail (8) := tail (9) := tail (10) := 0;
if monitor (40, z, 0, tail) <> 0 <* create fil *>
then fejl (<:Fejl ved create entry, for få resourcer:>, - 1)
else
if monitor (92, z, 0, tail) <> 0 <* entry lock *>
or monitor (8, z, 0, tail) <> 0 <* reserve *>
then fejl (<:Fejl ved reserve:>, - 1)
else
begin
for adr := 0 step 2 until 16 - 2 do <* varier startadr i buffer *>
begin
write (out, "nl", 1, <:io til/fra absolut lageradresse:>, adr_base + adr_rel + adr);
if online then setposition (out, 0, 0);
for segm := 1 step 1 until 88 do <* varier bufferlængde *>
begin
buf_start := 512 + adr;
buf_slut := segm * 512 + buf_start;
for inf := 2 step 2 until buf_start,
buf_slut + 2 step 2 until 90 * 512
do z.inf := - 5 592 406; <* AAAAAAh i alt udenom buf *>
for inf := buf_start + 2 step 2 until buf_slut
do z.inf := inf - buf_start; <* hw adr i buf *>
io (z, buf_start, buf_slut, false); <* skriv til disk *>
<* fyld bufferdelen af lagret med AAAAAAh *>
for inf := buf_start + 2 step 2 until buf_slut
do z.inf := - 5 592 406; <* AAAAAAh i buf *>
io (z, buf_start, buf_slut, true); <* læs fra disk *>
<* check omgivelser omkring buf *>
for inf := 2 step 2 until buf_start,
buf_slut + 2 step 2 until 90 * 512 do
if z.inf <> - 5 592 406 then
begin <* fejl *>
ant_fejl := ant_fejl + 1;
fejl (<:Fejl læsning til lageradr.:>, adr_base + adr_rel + inf);
write (out, <: segm pr io:>, segm,
"nl", 1, <:lager udenom buffer ødelagt:>,
"nl", 1, <:forventet: :>, string xhex (- 5 592 406, 6), "H", 1,
<: fundet: :>, string xhex (z.inf, 6), "H", 1);
if online then setposition (out, 0, 0);
if pause then system (10, 1, <:<10>pause pga fejl:>); <* pause *>
end fejl;
<* check bufferindhold *>
for inf := buf_start + 2 step 2 until buf_slut do
if z.inf <> inf - buf_start then <* hw adr i buf *>
begin <* fejl *>
ant_fejl := ant_fejl + 1;
fejl (<:Fejl læsning til lageradr.:>, adr_base + adr_rel + inf);
write (out, <: segm pr io:>, segm,
"nl", 1, <:fejlagtige data fundet:>,
"nl", 1, <:forventet: :>, string xhex (inf, 6), "H", 1,
<: fundet: :>, string xhex (z.inf, 6), "H", 1);
if online then setposition (out, 0, 0);
if pause then system (10, 1, <:<10>pause pga fejl:>); <* pause *>
end fejl;
end varier segm;
end varier adr;
end create entry ok;
open (z, 4, name, 1 shift 9);
close (z, true);
if ant_fejl = 0 then monitor (48, z, 0, tail) <* clear fil hvis ok *>
else write (out, "nl", 1, <:pga. fejl slettes :>, name,
<: på :>, disc1, <: ikke:>);
test_ioc := ant_fejl;
end procedure test_ioc;
\f
if not trapstop then trap (trap_ud);
antal := 1;
test_proc := true;
xnulstil (sidst_rørt);
xnulstil (antal_io);
xnulstil (blok_lgd);
xnulstil (segment_nr);
xnulstil (bs_nr);
xnulstil (antal_fejl);
xnulstil (aktivitet);
if testno = 11 then
begin <* integer *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Integer regning (+, -, *, //, mod):>);
if online then setposition (out, 0, 0);
test_integer;
end integer
else
if testno = 12 then
begin <* long *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Long regning (+, -, *, //, mod):>);
if online then setposition (out, 0, 0);
test_long;
end long
else
if testno = 13 then
begin <* real *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Real regning (+, -, *, /):>);
if online then setposition (out, 0, 0);
test_real;
end real
else
if testno = 14 then
begin <* exponentiation *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Exponentiationsberegninger (integer, long, real):>);
if online then setposition (out, 0, 0);
test_exp;
end exponentiation
else
if testno = 21 then
begin <* tofrom *>
i := xmaxbuflgd (10, if corelock then 1000 else 4000, true) - 50; <* ca 50 hw til zonedescr mv *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Tofrom lagerflytninger (10 * :>, i, <: hw):>);
if online then setposition (out, 0, 0);
test_tofrom (i);
end tofrom
else
if testno = 31 then
begin <* sieve *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Sieve-benchmark (25000):>);
if online then setposition (out, 0, 0);
mål_sieve (antal, 25000);
end sieve
else
if testno = 32 then
begin <* quicksort *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Quicksort (25000 words):>);
if online then setposition (out, 0, 0);
mål_qsort (antal, 25 000);
end qsort
else
if testno = 33 then
begin <* shellsort *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Shellsort (25000 words):>);
if online then setposition (out, 0, 0);
mål_ssort (antal, 25 000);
end ssort
else
if testno = 34 then
begin <* heapsort *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Heapsort (25000 words):>);
if online then setposition (out, 0, 0);
mål_hsort (antal, 25 000);
end hsort
else
if testno = 35 then
begin <* matrix *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Matrixberegning (50x50 words):>);
if online then setposition (out, 0, 0);
mål_matrix (antal, 50);
end matrix
else
if testno = 36 then
begin <* flydende matrix *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Matrixberegning med flydende tal (50x50 reals):>);
if online then setposition (out, 0, 0);
mål_fmatrix (antal, 50);
end fmatrix
else
if testno = 51 then
begin <* write seq *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Disktest, seq write, cross read:>);
if online then setposition (out, 0, 0);
j := abs test_disk (1, antbs, antdiske);
writeint (out, "nl", 1, <<zddd.dd>, xkl, ":", 1,
<:disktest slut,:>, <<-d>, j, <: fejl:>);
if online then setposition (out, 0, 0);
end seq
else
if testno = 56 then
begin <* write cross *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Disktest, cross write, seq read:>);
if online then setposition (out, 0, 0);
j := abs test_disk (2, antbs, antdiske);
writeint (out, "nl", 1, <<zddd.dd>, xkl, ":", 1,
<:disktest slut,:>, <<-d>, j, <: fejl:>);
if online then setposition (out, 0, 0);
end cross
else
if testno = 59 then
begin <* copy *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Disktest, disk-disk-copy:>);
if online then setposition (out, 0, 0);
test_disk (3, antbs, antdiske); <* lav filer *>
j := abs test_disk (5, antbs, antdiske); <* copy *>
test_disk (4, antbs, antdiske); <* slet filer *>
writeint (out, "nl", 1, <<zddd.dd>, xkl, ":", 1,
<:disktest slut,:>, <<-d>, j, <: fejl:>);
if online then setposition (out, 0, 0);
end copy
else
if testno = 61 then
begin <* tape *>
mt_no := mt_no + 1;
makename (mt_no, la, 't');
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:Tapetest (:>, la, <:):>);
if online then setposition (out, 0, 0);
j := abs test_tape (la);
writeint (out, "nl", 1, <<zddd.dd>, xkl, ":", 1,
<:tapetest slut:>, <<-d>, j, <: fejl:>);
if online then setposition (out, 0, 0);
end tapetest
else
if testno = 71 then
begin <* ioc *>
writeint (out, "nl", 2, <<zddd.dd>, xkl, ":", 1,
<<d>, <:IOC-test:>);
if online then setposition (out, 0, 0);
j := test_ioc;
writeint (out, "nl", 1, <<zddd.dd>, xkl, ":", 1,
<:IOC-test slut:>, <<-d>, j, <: fejl:>);
if online then setposition (out, 0, 0);
end ioctest
else
test_proc := false; <* ukendt test *>
if false then
trap_ud:
begin
xwritealarm;
xtrapbreak;
fejl (<:programnedgang:>, - 1);
end;
end procedure test_proc;
▶EOF◀