|
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: 25344 (0x6300)
Types: TextFile
Names: »tmags6 «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »tmags6 «
begin comment rev.80.06.19 (efterredigeret af jahn);
comment magnetic-tape-testpprogram;
integer
action,
blockl,
no_of_runs,
mode,
pattern,
stations;
boolean
reread,
print,
change,
statuscheck,
pattprint,
testend,
zndesc;
no_of_runs := 100;
stations := 1;
pattern := 1; comment pe;
mode := 0; comment odd;
blockl := 512; comment regnet i words;
action := 3; comment write and read;
change := false;
statuscheck:= true;
reread := false;
print := true; comment tryk mest muligt output;
pattprint := false;
testend := false;
zndesc := false;
\f
begin comment indlæs evt ny trimning;
integer
i, no;
integer array
tabel(0:127);
real array
trim, result(1:2);
procedure stdtable(table);
integer array table;
comment table skal være erklæret fra 0 til 127;
begin
integer i;
for i:= 0, 127 do table(i):= 0;
for i:= 48 step 1 until 57 do table(i):= 2;
for i:= 43, 45 do table(i):= 3;
table(46):= 4;
table(39):= 5;
for i:= 65 step 1 until 93, 97 step 1 until 125 do
table(i):= 6;
for i:= 1 step 1 until 9, 11, 13 step 1 until 24,
26 step 1 until 38, 40, 41, 42, 44, 47,
58 step 1 until 64, 94, 95, 96, 126 do
table(i):= 7;
for i:= 10, 12, 25 do table(i):= 8;
for i:= 0 step 1 until 127 do
table(i):= table(i) shift 12 add i;
tableindex:= 0
end;
stdtable(tabel);
tabel(32):= 0;
intable(tabel);
write(out,<:<10> ***************************** :>);
write(out,<:<10> ******* rc 8000 ******* :>);
write(out,<:<10> ******* mag-tape test ******* :>);
write(out,<:<10> ******* ver.80.06.19. ******* :>);
write(out,<:<10> *****************************<10><10><10><10> :>);
\f
nytrim:
system(8,i,result);
if result(1) <> real<:s:> then
begin
no := 0;
readstring(in, trim, 1);
trim(1):= trim(1) shift(-16) shift 16;
for i:= 1 step 1 until 12 do
if trim(1) = real (case i of (
<:slut:>,
<:runs:>, <:stat:>, <:bloc:>,
<:bitp:>, <:mode:>, <:acti:>,
<:chec:>, <:rere:>, <:data:>, <:prin:>, <:znde:>)) then
begin
no := i;
i := 12;
end;
if no > 4 then readstring(in, result, 1);
case no + 1 of
begin
write(out, <:<10>wrong parametername : :>, string trim(1)); comment gal trimning;
goto trimslut;
read(in, no_of_runs);
read(in, stations);
read(in, blockl);
\f
begin comment bitpattern;
result(1):= result(1) shift(-8) shift 8;
if result(1) = real <:pe:> then
pattern:= 1 else
if result(1) = real <:nrz:> then
pattern:= 2 else
if result(1) = real <:allon:> then
pattern:= 3 else
write(out,<:<10>wrong bitpattern param : :>,string result(1));
end;
begin comment mode;
if result(1) = real <:peo:> then
mode:= 0 else
if result(1) = real <:pee:> then
mode:= 2 else
if result(1) = real <:nrzo:> then
mode:= 4 else
if result(1) = real <:nrze:> then
mode:= 6 else
write(out,<:<10>wrong mode param:>,string result(1));
end;
begin comment action;
result(1):= result(1) shift(-8) shift 8;
result(2):= result(2) shift(-8) shift 8;
if result(1) = real <:read:> then
action := 2
else
if result(1) = real <:write:> then
action := 1 + (if result(2) = real <:ndrea:> then 2 else 0)
else write(out,<:<10>wrong action param : :>,string result(1));
if action = 1 then change:= true;
end;
begin
if result(1) = real <:no:> then statuscheck:= false
else if result(1) <> real<:yes:> then
write(out,<:<10>wrong statuscheck param : :>,string result(1));
end;
begin
if result(1) = real <:yes:> then reread:= true
else if result(1) <> real<:no:> then
write(out,<:<10>wrong reread param : :>,string result(1));
end;
begin
if result(1) = real <:no:> then print:= false
else if result(1) <> real<:yes:> then
write(out,<:<10>wrong datacheck param : :>,string result(1));
end;
begin
if result(1) = real <:yes:> then pattprint:= true
else if result(1) <> real<:no:> then
write(out,<:<10>wrong patternprint param : :>,string result(1));
end;
begin
if result(1) = real <:yes:> then zndesc := true
else if result(1) <> real<:no:> then
write(out,<:<10>wrong zonedescr. param : :>,string result(1));
end;
end case no;
goto nytrim;
end not s;
\f
trimslut:
system(8,i,result);
write(out,<:<10><10><10>***:>,string result(1),
if result(1) = real <:s:> then
<:<10>***** warning : program will be stopped,when not started by the fp command
(mags <10>c=copy testoutput):> else <:<10>:>);
if result(1) = real <:s:> then
begin
write(out,<:<10><10><10>:>);
write(out,<:<10>online : :>);
setposition(out,0,0);
readstring(in,result,1);
if result(1) = real<:runs:> then system(9,0,<:<10>stopped:>);
write(out,<:<10> runs = :>);
setposition(out,0,0);
read(in, no_of_runs);
write(out,<:<10>stations = :>);
setposition(out,0,0);
read(in, stations);
write(out,<:<10>blocklength = :>);
setposition(out,0,0);
read(in, blockl);
back1 : write(out,<:<10>bitpattern = :>);
setposition(out,0,0);
readstring(in,result,1);
\f
begin comment bitpattern;
result(1):= result(1) shift(-8) shift 8;
if result(1) = real <:pe:> then
pattern:= 1 else
if result(1) = real <:nrz:> then
pattern:= 2 else
if result(1) = real <:allon:> then
pattern:= 3 else
go_to back1;
end;
back2 : write(out,<:<10>mode = :>);
setposition(out,0,0);
readstring(in,result,1);
begin comment mode;
if result(1) = real <:peo:> then
mode:= 0 else
if result(1) = real <:pee:> then
mode:= 2 else
if result(1) = real <:nrzo:> then
mode:= 4 else
if result(1) = real <:nrze:> then
mode:= 6 else
go_to back2;
end;
back3 : write(out,<:<10>action = :>);
setposition(out,0,0);
readstring(in,result,1);
begin comment action;
result(1):= result(1) shift(-8) shift 8;
result(2):= result(2) shift(-8) shift 8;
if result(1) = real <:reado:> then
action := 2
else
if result(1) = real <:write:> then
action := 1 + (if result(2) = real <:ndrea:> then 2 else 0)
else go_to back3;
if action = 1 then change:= true;
end;
back4 : write(out,<:<10>check status = :>);
setposition(out,0,0);
readstring(in,result,1);
if result(1) = real <:no:> then statuscheck:= false
else if result(1) <> real<:yes:> then go_to back4;
back5 : write(out,<:<10>reread = :>);
setposition(out,0,0);
readstring(in,result,1);
if result(1) = real <:yes:> then reread:= true
else if result(1) <> real<:no:> then go_to back5;
back6 : write(out,<:<10>datacheck = :>);
setposition(out,0,0);
readstring(in,result,1);
if result(1) = real <:no:> then print:= false
else if result(1) <> real<:yes:> then go_to back6;
back7 : write(out,<:<10>print pattern= :>);
setposition(out,0,0);
readstring(in,result,1);
if result(1) = real <:yes:> then pattprint:= true
else if result(1) <> real<:no:> then go_to back7;
back8 : write(out,<:<10>zonedescrip. = :>);
setposition(out,0,0);
readstring(in,result,1);
if result(1) = real <:yes:> then zndesc := true
else if result(1) <> real <:no:> then go_to back8;
end;
\f
if -, statuscheck then reread:= print:= false;
blockl:= blockl // 2 * 2;
if blockl > 1535 then blockl:= 1535;
if stations > 7 then stations:= 7;
intable(0);
end ny trimning;
\f
begin comment hovedblok;
integer
bytes,
expected,
line,
run,
stat;
boolean
star,
nul,
em,
ff,
nl,
sp;
integer array
content(1:blockl),
ia(1:12);
zone
pr(128, 1, stderror);
zone array
z(stations, blockl // 2 + 15, 1, error);
\f
procedure all_ones;
begin
integer array field
iaf;
iaf := 4;
content(1):= content(2):= -1;
tofrom(content.iaf, content, bytes - 4);
end;
\f
procedure error(z, s, b);
integer
b, s;
zone
z;
begin
integer
b0;
b0 := b;
b := bytes;
if s shift(-18) extract 1 = 1 then
begin comment end_of_tape;
own boolean
eot;
if -, eot then
begin
eot:= true;
close(z, true);
if statuscheck then
begin
write(pr, <:end of tape on station : :>, stat, nl, 1);
line:= line + 1;
write(out, <:end of tape on station : :>, stat, nl, 1);
setposition(out, 0, 0);
end;
eot:= false;
if change then
begin
if action = 2 then goto exit;
if action = 3 then goto exit;
action:= 3 - action;
run := 0;
end;
goto start;
end;
end end_of_tape else
if statuscheck then
begin
integer
bit;
integer array
ia(1:20);
getzone6(z, ia);
if testend then expected := expected + 1 shift 16;
if s <> expected then
begin
if line > 45 then
begin
write(pr,nl,1, ff, 1);
line:= 0;
end;
write(pr,star,80,nl,2);
line:= line + 2;
if stations > 1 then
begin
write(pr, <:*** station : :>, <<d>, stat, nl,1);
line:= line + 1;
end;
write(pr, <:*** run : :>, <<d>, run,nl,2);
line:= line + 2;
write(pr,if ia(13) = 6 then <:.01.status error during write ::> else
if ia(13) = 5 then <:.03.status error during read ::> else <:.00.status error during move ::>,nl,1);
line:= line + 1;
write(pr,<:recieved : :>);
skriv_bits(pr, s, expected, 3,23);
write(pr, nl, 1);
line:= line + 1;
write(pr,<:expected : :>);
skriv_bits(pr,expected,s,3,23);
write(pr, nl, 2);
line:= line + 2;
for bit:= 0 step 1 until 17 do
if s shift bit < 0 then
write(out, case bit+1 of (
<:*intervention*:>, <:*parity error*:>, <:*timer*:>, <:*data overrun*:>,
<:*blocklength*:>, <:*end document*:>, <:*loadpoint*:>, <:*eof*:>,
<:*write enable*:>, <:*mode error*:>, <:*read error*:>, <:*xx*:>,
<:*check sum*:>, <:*bit 15*:>, <:*bit 14*:>, <:*stopped*:>,
<:*word defect*:>, <:*position*:>),
sp, 1);
write(out, <<d>, <:on station : :>, stat, nl, 1);
setposition(out, 0, 0);
end;
if b0 > 2 and b0 <> bytes then
begin
if stations > 1 then
begin
write(pr,<:*** station : :>,<<d>,nl,1);
line:= line + 1;
end;
write(pr, <:*** run : :>, <<d>, run,nl,2);
line:= line + 2;
write(pr,if ia(13) = 6 then <:.01.length error during write ::> else
if ia(13) = 5 then <:.03.length error during read ::> else <:.00.length error during ::>,nl,1);
line:= line + 1;
write(pr,<:recieved : :>,b0 * 3 // 2, <: expected:>, bytes * 3 // 2, nl, 2);
line := line + 2;
end;
write(pr,star,80,nl,3);
line:= line + 3;
end statuscheck;
end error;
\f
procedure læs_blok(z);
zone
z;
begin
integer
b, up;
integer array field
iaf;
b:= inrec6(z, 0);
inrec6(z, b);
iaf:= 0;
up := if print then bytes//2 else 1;
for b:= 1 step 1 until up do
if z.iaf(b) <> content(b) then
begin
if line > 45 then
begin
write(pr, nl,1,ff, 1);
line:= 0;
end;
write(pr,star,80,nl,2);
line:= line + 2;
if stations > 1 then
begin
line:=line + 1;
write(pr, <:*** station : :>, <<d>, stat, nl,1);
end;
write(pr, <:*** run : :>, <<d>, run, nl,2);
line:= line + 2;
write(pr,<:.03.data error during read ::>,nl,1);
line:= line + 1;
write(pr,<:recieved : :>);
skriv_bits(pr, z.iaf(b), content(b), 8, 23);
write(pr, <: word no.:>, <<d>, b, nl, 1);
line:= line + 1;
write(pr,<:expected : :>);
skriv_bits(pr,content(b),z.iaf(b),8,23);
write(pr,nl,2,star,80,nl,3);
line:= line + 5;
end;
end læs blok;
\f
procedure nrz;
begin
integer
i, j,
length,
upper,
word;
integer array
help(1:58),
nrztabel(1:173),
tal(0:8);
integer array field
iaf;
for i:= 1 step 1 until 28 do
begin
help(i):= (case i of (
0, 32, 16, 8, 4, 48, 24, 40, 12, 36,
20, 6, 10, 18, 9, 56, 28, 44, 52, 14,
38, 50, 22, 26, 42, 11, 13, 19)) shift 2;
help(i) := help(i) shift 1 add 1 shift 8 add help(i);
help(59-i):= exor(help(i), -1) extract 16;
end;
help(29):= 21 shift 7 add 21 shift 1;
help(30):= 171 shift 9 add 171;
for word:= 1 step 3 until 85,
87 step 3 until 171 do
begin
i := (word + 3) // 3;
for j:= 0 step 1 until 8 do tal(j):= help(i) shift(-j) extract 8;
for i:= 0, 1, 2 do
nrztabel(word + i):=
tal(3*i) shift 8 add tal(3*i + 1) shift 8 add tal(3*i + 2);
end;
\f
length := 173 * 2;
for iaf:= 0 step length until bytes do
begin
upper:= if iaf + length <= bytes then length else bytes - iaf;
tofrom(content.iaf, nrztabel, upper);
end;
if pattprint then
begin
write(pr,nl,3,star,80,nl,2);
write(pr,sp,9,<:print out of buffer in use :>,nl,3);
for word:= 1 step 1 until 173 do
begin
write(pr,<:word :>, <<ddd>, word* 2 - 2, <:::>, sp, 3);
skrivbits(pr, nrztabel(word), nrztabel(word), 8, 23);
write(pr, if word mod 35 = 0 then ff else nul ,1, nl,1 );
end;
write(pr,nl,3,star,80);
write(pr, nl,1,ff, 1);
end;
end nrz-bitpattern;
\f
procedure pe;
begin
integer
i,
length,
t00, t01, t10, t11,
upper,
word;
integer array
petabel(1:96),
tal (1: 3);
integer array field
iaf;
t00:= 0; comment 00000000;
t01:= 125; comment 01111101;
t10:= 130; comment 10000010;
t11:= 255; comment 11111111;
length:= 96;
for word:= 1 step 1 until length do
begin
for i:= 1, 2, 3 do
tal(i):= case 3 * (word - 1) + i of (
t11, t11, t11,
t11, t11, t11,
t11, t11, t01,
t01, t01, t01,
t01, t01, t01,
t01, t11, t11,
t11, t11, t11,
t11, t11, t11,
t01, t01, t01,
t01, t00, t00,
t00, t00, t10,
t10, t10, t10,
t10, t10, t10,
t10, t00, t00,
t00, t00, t00,
t00, t00, t00,
t10, t10, t10,
t10, t10, t10,
t10, t10, t00,
t00, t00, t00,
t01, t01, t01,
t01, t11, t11,
t11, t10, t11,
t11, t11, t11,
t01, t01, t01,
\f
t01, t00, t00,
t00, t00, t10,
t10, t10, t10,
t11, t11, t11,
t11, t00, t00,
t00, t00, t01,
t01, t01, t01,
t11, t11, t11,
t10, t11, t11,
t11, t11, t01,
t01, t01, t00,
t01, t01, t01,
t01, t11, t11,
t11, t11, t10,
t10, t10, t10,
t00, t00, t00,
t01, t00, t00,
t00, t00, t10,
t10, t10, t11,
t10, t10, t10,
t10, t00, t00,
t00, t01, t00,
t00, t00, t00,
t10, t10, t10,
t11, t10, t11,
t11, t11, t01,
t01, t01, t00,
t01, t00, t00,
t00, t10, t10,
t10, t11, t10,
t11, t11, t11,
t01, t01, t01,
t00, t01, t00,
t00, t00, t10,
t10, t10, t11,
t10, t11, t11,
t11, t01, t01,
t01, t00, t01,
t00, t00, t00,
t11, t11, t10,
t10, t11, t11,
t10, t10, t01,
t01, t00, t00,
t01, t01, t00,
t00, t11, t11,
\f
t10, t10, t11,
t11, t10, t10,
t01, t00, t01,
t00, t01, t00,
t01, t00, t11,
t10, t11, t10,
t11, t10, t11,
t10, t01, t00,
t01, t00, t01,
t00, t01, t00,
t11, t11, t11,
t11, t10, t11,
t10, t11, t01,
t00, t01, t00,
t01, t01, t01,
t01, t10, t10,
t10, t10, t11,
t10, t11, t10,
t00, t01, t00,
t01, t00, t00,
t00, t00, t10,
t10, t11, t11,
t10, t10, t11,
t11, t01, t00,
t01, t00, t01,
t00, t01, t00);
petabel(word):= tal(1) shift 8 add tal(2) shift 8 add tal(3);
end;
length:= length * 2;
for iaf:= 0 step length until bytes do
begin
upper:= if iaf + length <= bytes then length else bytes - iaf;
tofrom(content.iaf, petabel, upper);
end;
if pattprint then
begin
write(pr,nl,3,star,80,nl,2);
write(pr,sp,9,<:print out of buffer in use :>,nl,3);
for word:= 1 step 1 until 96 do
begin
write(pr,<:word :>, <<ddd>, word* 2 - 2, <:::>, sp, 3);
skrivbits(pr, petabel(word), petabel(word), 8, 23);
write(pr ,if word mod 35 = 0 then ff else nul ,1, nl,1 );
end;
write(pr,nl,3,star,80);
write(pr,nl,1,ff,1);
end;
end pe-bitpattern;
\f
procedure set_block(z, back);
value
back;
boolean
back;
zone
z;
begin
integer array
ia, ia1(1:20);
if back then
begin
getshare6(z, ia, 1);
tofrom(ia1, ia, 24);
ia(4):= 8 shift 12 + mode ;
ia(5):= 3;
setshare6(z, ia, 1);
monitor(16, z, 1, ia);
monitor(18, z, 1, ia);
ia1(1):= 0;
ia1(4):= 3 shift 12 + mode;
setshare6(z, ia1, 1);
monitor(16, z, 1, ia);
monitor(18,z,1,ia);
end;
getzone6(z, ia);
ia(13):= if back then 5 else 6;
setzone6(z, ia);
end;
\f
procedure skriv_bits(pr, word, comp, grup, stop);
value
word, comp, grup, stop;
integer
word, comp, grup, stop;
zone
pr;
begin
integer
bit, g;
g := grup;
for bit:= 0 step 1 until stop do
begin
if bit = g then
begin
write(pr, sp, 1);
g := g + grup;
end;
write(pr, if word < 0 then <:1:> else <:0:>);
word:= word shift 1 ;
end bit-step;
end skriv bits;
\f
procedure udskriv_desc(z);
zone
z;
begin
integer a,b,c,d,e,f,g;
boolean nl,ff,sp;
integer array ia(1:22);
star:= false add 42;
nl:= false add 10;
sp:= false add 32;
ff:= false add 12;
write(pr,nl,1,<: zonedescription:>,nl,1);
getzone6(z,ia);
write(pr,nl,1,<:mode :>,<<dddddddd>,
((ia(1) shift (-12)) extract 12),
nl,1,<:kind :>,ia(1) extract 12);
write(pr,
nl,1,<:file: :>,<<dddddddd>,ia(7),
nl,1,<:block: :>,ia(8),
nl,1,<:give up mask: :>,ia(10),
nl,1,<:free param: :>,ia(11),
nl,1,<:zone state: :>,ia(13),
nl,1,<:last byte: :>,ia(15),
nl,1,<:rec. length: :>,ia(16),
nl,1,<:used share: :>,ia(17),
nl,1,<:numb. of shares: :>,ia(18),
nl,1,<:base buf area: :>,ia(19),
nl,1,<:buf length: :>,ia(20),nl,1);
end desc;
\f
procedure skriv_blok(z);
zone
z;
begin
if zndesc then udskriv_desc(z);
outrec6(z, bytes);
tofrom(z, content, bytes);
if zndesc then udskriv_desc(z);
outrec6(z, 62);
changerec6(z, 0); comment send blokken afsted;
if zndesc then udskriv_desc(z);
end;
\f
bytes := 2 * blockl;
expected := 1 shift 15 + 1 shift 1; comment skrivering og normal;
run := 0;
star:= false add 42;
nl:= false add 10;
ff:= false add 12;
em:= false add 25;
nul:= false add 0;
sp:= false add 32;
open(pr, 4, <:testoutput:>, 0);
write(pr,ff,1,star,80);
write(pr, nl, 2, <: used bitpattern :>, case pattern of (
<:pe:>, <:nrz:>, <:all ones:>), nl, 2);
write(pr,<: the station was run in :>,case mode + 1 of (
<:peo:>,<::>,<:pee:>,<::>,<:nrzo:>,<::>,<:nrze:>),
<: mode:>,nl,2);
write(pr,<:<10><10><10>:>);
write(pr,<:identification of statusbits : :>);
write(pr,<:<10>bit 0 : intervention :>,
<:<10>bit 1 : parity error :>,
<:<10>bit 2 : timer :>,
<:<10>bit 3 : data overrun :>,
<:<10>bit 4 : block length :>,
<:<10>bit 5 : end of tape :>,
<:<10>bit 6 : load point :>,
<:<10>bit 7 : tapemark :>,
<:<10>bit 8 : writing enabl:>,
<:<10>bit 9 : mode error :>,
<:<10>bit 10: read error :>,
<:<10>bit 11: xx :>,
<:<10>bit 12: checksum :>,
<:<10>bit 13: bit 15 :>,
<:<10>bit 14: bit 14 :>,
<:<10>bit 15: stopped :>,
<:<10>bit 16: word defect :>,
<:<10>bit 17: position :>,
<:<10>bit 18: xx :>,
<:<10>bit 19: disconnected :>,
<:<10>bit 20: unintelligib :>,
<:<10>bit 21: rejected :>,
<:<10>bit 22: normal :>,
<:<10>bit 23: hard error :>,
<:<10>:>,ff,1);
line:= 34;
case pattern of
begin
pe;
nrz;
all_ones;
end;
if pattprint then goto exit;
start:
for stat:= 1 step 1 until stations do
begin
close(z(stat), true);
testend:=false;
open(z(stat), mode shift 12 + 18, case stat of (
<:mt1:>, <:mt2:>, <:mt3:>, <:mt4:>,
<:mt5:>, <:mt6:>, <:mt7:>),
if reread then 0 else -1 - (expected + 1 shift 17 + 1 shift 8));
getshare6(z(stat), ia, 1);
ia(4):= 8 shift 12 + mode;
ia(5):= 4;
setshare6(z(stat), ia, 1);
monitor(16, z(stat), 1, ia);
end;
for stat:= 1 step 1 until stations do
begin
monitor(18, z(stat), 1, ia);
setposition(z(stat), 0, 0);
end;
\f
for run := run while run < no_of_runs do
begin
run:= run + 1;
for stat:= 1 step 1 until stations do
begin
case action of
begin
skriv_blok(z(stat));
læs_blok(z(stat));
begin comment write and read;
skriv_blok(z(stat));
setblock(z(stat), true);
læs_blok(z(stat));
setblock(z(stat), false);
end;
end case action;
end stat;
end run;
if action = 1 and change then
begin
run := 0;
action:= 2;
testend:=true;
goto start;
end;
exit:
testend:=true;
for stat:= 1 step 1 until stations do close(z(stat), true);
write(pr, nl, 1, em, 3);
close(pr, true);
end;
end;
▶EOF◀