|
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: 18432 (0x4800)
Types: TextFile
Names: »timctest «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »timctest «
limctest = set 1 disc1
;o limctest
;head iso
;( oimctest=algol list.on blocks.yes xref.no connect.no
( oimctest=algol survey.yes connect.no
if ok.yes
if warning.yes
( o c
message kikset
visfejl limctest
end
)
o c
message ok
scope user oimctest
end
)
begin
<* jsc d. 3/6-1988
program: oimctest
formål: belastning af rclan
kald: oimctest io.r/w (b.<buflgd>) (m.<maxio>) (a.<anttest>) (i.<inc>)
io ::= r=>read lan, w=>write lan default=r
buflgd ::= antal tegn pr io, default=768
maxio ::= maximal antal io pr connect, default=100
anttest ::= antal connect før afslut, default=4
inc ::= incarnationer default=2
hvis inc<1 benyttes ikke activities
*>
integer res, buf, nr, buflgd, maxio, anttest, inc, i, j;
boolean input, online;
integer array ia (1 : 20);
long array la (1 : 2);
procedure xclaim (i);
value i ;
integer i ;
begin
boolean
array ba (1:i);
end;
procedure test (nr, txt);
integer nr;
string txt;
begin
write (out, <<d>, "nl", 1, nr, ":", 1, txt, "sp", 1);
if online then setposition (out, 0, 0);
end procedure test;
procedure test_reason (reason);
value reason;
long reason;
begin
write (out, <<d>,
<: status=:>, reason shift (- 36) extract 12,
<: result=:>, reason shift (- 24) extract 12,
<: portst=:>, reason shift (- 12) extract 12,
<: closers=:>, reason shift (- 0) extract 12,
"sp", 1);
if online then setposition (out, 0, 0);
end procedure test_reason;
integer procedure segm (z);
zone z;
begin <* returnerer segmcount fra z's zonedescriptor *>
integer array ia (1 : 20);
getzone6 (z, ia);
segm := ia (9);
end procedure segm;
procedure latest_answer (nr, buf);
integer nr, buf;
begin
integer array ia (1 : 8);
integer i, j;
system (5, buf + 8, ia);
write (out, <<d>, "nl", 2, nr, ":", 1, <:latest answer, buf.:>, buf, "nl", 1);
for i := 1 step 1 until 8 do
begin
write (out, <<ddd>, i, ")", 1,
<<-ddddddddd>, ia (i), "sp", 3,
<<-dddd>, ia (i) shift (- 12), ia (i) extract 12, "sp", 3);
for j := -16, -8, -0 do
if ia (i) shift j extract 8 <= 32
or ia (i) shift j extract 8 >= 127
then write (out, <<-ddd>, ia (i) shift j extract 8)
else write (out, "sp", 3, false add (ia (i) shift j extract 8), 1);
write (out, "sp", 2);
for j := 0 step 1 until 23 do
write (out, "sp", if j mod 6 <> 0 then 0 else 1,
if ia (i) shift (j - 23) extract 1 = 0 then "." else "1", 1);
write (out, "nl", 1);
end;
if online then setposition (out, 0, 0);
end procedure latest_answer;
procedure fejl (nr, txt, la, reason);
value reason;
integer nr;
string txt;
long array la;
long reason;
begin
integer i;
write (out, "nl", 1, <<d>, nr, ":", 1,
<:*** :>, txt, "sp", 1, la,
<: status=:>, reason shift (- 36) extract 12,
<: result=:>, reason shift (- 24) extract 12,
<: portst=:>, reason shift (- 12) extract 12,
<: closers=:>, reason shift (- 0) extract 12,
"nl", 1);
if online then setposition (out, 0, 0);
end procedure fejl;
procedure vent (tid);
value tid;
long tid;
begin <* vent i tid 0.0001 sekunder *>
integer array ia (1 : 20);
zone z (1, 1, bp);
long field lf;
open (z, 2, <:clock:>, 1 shift 9);
lf := 12;
getshare6 (z, ia, 1);
ia (3 + 1) := 2; <* antal 1/10000 sekunder *>
ia.lf := tid; <* antal 1/10000 sekunder *>
setshare6 (z, ia, 1);
if monitor (16, z, 1, ia) = 0 then system (9, 6, <:<10>break:>) else
if monitor (18, z, 1, ia) <> 1 then system (9, 6, <:<10>break:>);
end procedure vent;
procedure bp (z, s, b);
zone z;
integer s, b;
begin
integer array ia (1 : 20);
long array field laf2;
integer i;
laf2 := 2;
getzone6 (z, ia);
write (out, "nl", 1, <:bp kaldt for :>, ia.laf2,
<<d>, <: b=:>, b, <: s=:>);
for i := 1 step 1 until 24 do
write (out, if s shift (i - 24) extract 1 = 1 then "1" else ".", 1,
"sp", if i mod 6 <> 0 then 0 else 1);
outchar (out, 'nl');
if online then setposition (out, 0, 0);
stderror (z, s, b);
end procedure bp;
\f
boolean procedure imc_sense (z, idx, reason);
zone z;
integer idx;
long reason;
begin
imc_sense := true;
end; <* tes test *>
procedure testtesttest (z, idx, reason); <* test test *>
zone z;
integer idx;
long reason;
begin <* proceduren udfører en imc-sense *>
integer i;
integer array ia (1 : 12);
getshare6 (z, ia, 1);
ia (3 + 1) := 0; <* sense operation *>
ia (3 + 6) := idx; <* hvis index = 0 så portstate ellers connectionstate *>
setshare6 (z, ia, 1);
test (nr, <:sense:>);
write (out, <: idx=:>, <<d>, idx, <: segm=:>, segm (z), "sp", 1);
if monitor (16, z, 1, ia) = 0
then system (9, 6, <:<10>break:>)
else i := monitor (18, z, 1, ia);
reason := extend (ia (1) extract 12) shift 36
+ extend (i extract 12) shift 24
+ (ia (7) extract 12) shift 12
+ (ia (8) extract 12) shift 0;
test_reason (reason);
comment imc_sense := i = 1;
end procedure imc_sense;
boolean procedure test_imc_connection (z, idx, reason);
zone z;
integer idx;
long reason;
begin <* proceduren udfører en række imc-sense for at kontrolere connection *>
while imc_sense (z, idx, reason)
and (reason shift (- 12) extract 12 = 1 <* accepting *>
or reason shift (- 12) extract 12 = 2) <* connecting *>
do vent (0 1000);
test_imc_connection := reason shift (- 12) extract 12 = 3 <* connected *>
end procedure test_imc_connection;
boolean procedure x_imc_connect (z, idx, name, reason);
zone z;
integer idx;
long array name;
long reason;
begin
boolean ok, connected;
integer forsøg;
comment trap (fejl);
ok := connected := false;
forsøg := 0;
repeat
forsøg := forsøg + 1;
test (nr, <:imcconnect:>);
write (out, <: idx=:>, <<d>, idx, <: segm=:>, segm (z), "sp", 1);
if imcconnect (z, idx, name, reason) then
begin <* connect *>
write (out, <:imcconnect=true, idx=:>, <<d>, idx, <: segm=:>, segm (z), "sp", 1);
ok := true;
if idx = 0 then system (9, nr, <:<10>sludder:>);
if test_imc_connection (z, idx, reason) then
begin <* connection ok *>
write (out, <:imcconnect=true, connect=ok, idx=:>, <<d>, idx, <: segm=:>, segm (z), "sp", 1);
connected := true;
end connection ok
else
begin <* connection ej ok *>
write (out, <:imcconnect=true, connect=ej-ok, idx=:>, <<d>, idx, <: segm=:>, segm (z), "sp", 1);
imcdisconn (z, reason);
connected := false;
vent (if forsøg < 5 then 0 1000 else
if forsøg < 10 then 1 0000 else
if forsøg < 15 then 2 5000 else 5 0000); <* antal 1/10000 sek imellem forsøgene *>
end connection ej ok;
end connect ok
else
begin <* connect ej ok *>
write (out, <:imcconnect=false, idx=:>, <<d>, idx, <: segm=:>, segm (z), "sp", 1);
ok := connected := false;
imcdisconn (z, reason);
end connect ej ok;
test_reason (reason);
until connected or not ok;
fejl:
x_imc_connect := ok and connected;
end procedure x_imc_connect;
boolean procedure x_imc_getconnect (z, idx, reason);
zone z;
integer idx;
long reason;
begin
boolean ok, connected;
comment trap (fejl);
ok := connected := false;
repeat
test (nr, <:imcgetconn:>);
write (out, <: idx=:>, <<d>, idx, <: segm=:>, segm (z), "sp", 1);
if imcgetconn (z, idx, reason) then
begin <* getconnect *>
write (out, <:imcgetconn=true, idx=:>, <<d>, idx, <: segm=:>, segm (z), "sp", 1);
ok := true;
if idx = 0 then system (9, nr, <:<10>sludder:>);
if test_imc_connection (z, idx, reason) then
begin <* connection ok *>
write (out, <:imcgetconn=true, connect=ok, idx=:>, <<d>, idx, <: segm=:>, segm (z), "sp", 1);
connected := true;
end connection ok
else
begin <* connection ej ok *>
write (out, <:imcgetconn=true, connect=ej-ok, idx=:>, <<d>, idx, <: segm=:>, segm (z), "sp", 1);
imcdisconn (z, reason);
connected := false;
vent (5 0000); <* 5 sek imellem forsøgene *>
end connection ej ok;
end getconnect ok
else
begin <* connect ej ok *>
write (out, <:imcgetconn=false, idx=:>, <<d>, idx, <: segm=:>, segm (z), "sp", 1);
ok := connected := false;
imcdisconn (z, reason);
end getconnect ej ok;
test_reason (reason);
until connected or not ok;
fejl:
x_imc_getconnect := ok and connected;
end procedure x_imc_getconnect;
\f
procedure w (nr);
value nr;
integer nr;
begin
<* proceduren sender på nettet
1. ord i data = 25 => end of data
*>
zone zifp (1, 1, bp), zimc ((buflgd + 5) // 6, 1, bp);
long array nameifp, nameimc, namein, nameout (1 : 2);
long reason;
integer index, rand, antio, ionr, testnr, i, j;
long res;
xclaim (1024); <* extra stack *>
movestring (nameifp, 1, <:ifpmain1:>);
nameimc (1) := namein (1) := nameout (1) := long <:imcte:> add 's';
nameimc (2) := namein (2) := nameout (2) := long <:t:>;
nameimc (2) := nameimc (2)
+ extend ('0' + nr // 100 mod 10) shift 32
+ extend ('0' + nr // 10 mod 10) shift 24
+ extend ('0' + nr // 1 mod 10) shift 16
+ extend 'w' shift 8;
namein (2) := namein (2)
+ extend ('0' + nr // 100 mod 10) shift 32
+ extend ('0' + nr // 10 mod 10) shift 24
+ extend ('0' + nr // 1 mod 10) shift 16
+ extend 'i' shift 8;
nameout (2) := nameout (2)
+ extend ('0' + nr // 100 mod 10) shift 32
+ extend ('0' + nr // 10 mod 10) shift 24
+ extend ('0' + nr // 1 mod 10) shift 16
+ extend 'o' shift 8;
write (out, "nl", 1, <:begin w:>,
<: main.:>, nameifp, <: adpdev.:>, nameimc,
<: port.:>, namein, <: & :>, nameout);
open (zifp, 0 shift 12 + 0, nameifp, 1 shift 9); <* mode=0 => kun mig som user *>
ldunlink (zifp, 0, nameimc, res); <* fjern evt gammelt link *>
test (nr, <:ldlink:>);
i := - 1; <* første frie device *>
if ldlink (zifp, i, nameimc, 2, <::>, res) then
begin <* makelink ok *>
open (zimc, 20, nameimc, 1 shift 9);
test (nr, <:imcopenport:>);
if imcopenport (zimc, 3, nameout, reason) then
begin <* ok *>
rand := systime (7, 0, 0.0); <* basis for random *>
for testnr := 1 step 1 until anttest do
begin <* pr connect *>
antio := entier (random (rand) * maxio);
write (out, <<d>, "nl", 1, <:antio=:>, antio);
comment trap (rydop);
index := 0;
if x_imc_getconnect (zimc, index, reason) then
begin <* connect ok *>
for ionr := 1 step 1 until antio do
begin
test (nr, <:o:>);
outrec6 (zimc, (buflgd + 2) // 3 * 2);
if ionr <> antio
then zimc (1) := real <::>
else zimc (1) := real <:<25><25><25><25><25>:> add 25;
write (out, "sp", 1, <<d>, "'", 1, zimc (1) extract 8, "'", 1, ":", 1, ionr);
setposition (zimc, 0, 0);
end;
end getconnect ok
else fejl (nr, <:imcgetconn:>, namein, reason);
rydop:
trap (0);
test (nr, <:imcdisconn:>);
imcdisconn (zimc, reason);
end pr connect;
end imcopenport ok
else fejl (nr, <:imcopenport:>, nameimc, reason);
test (nr, <:imccloseprt:>);
imccloseprt (zimc, reason);
close (zimc, true);
end makelink ok
else fejl (nr, <:ldlink:>, nameimc, res);
test (nr, <:ldunlink:>);
if not ldunlink (zifp, 0, nameimc, res)
then fejl (nr, <:ldunlink:>, nameimc, res);
close (zifp, true);
test (nr, <:end w:>);
end procedure w;
\f
procedure r (nr);
value nr;
integer nr;
begin
<* proceduren læser fra nettet
1. ord i data = 25 => end of data
*>
zone zifp (1, 1, bp), zimc ((buflgd + 5) // 6, 1, bp);
long array nameifp, nameimc, namein, nameout (1 : 2);
long reason, res;
integer index, ionr, testnr, i, j;
xclaim (1024); <* extra stack *>
movestring (nameifp, 1, <:ifpmain1:>);
nameimc (1) := namein (1) := nameout (1) := long <:imcte:> add 's';
nameimc (2) := namein (2) := nameout (2) := long <:t:>;
nameimc (2) := nameimc (2)
+ extend ('0' + nr // 100 mod 10) shift 32
+ extend ('0' + nr // 10 mod 10) shift 24
+ extend ('0' + nr // 1 mod 10) shift 16
+ extend 'r' shift 8;
namein (2) := namein (2)
+ extend ('0' + nr // 100 mod 10) shift 32
+ extend ('0' + nr // 10 mod 10) shift 24
+ extend ('0' + nr // 1 mod 10) shift 16
+ extend 'i' shift 8;
nameout (2) := nameout (2)
+ extend ('0' + nr // 100 mod 10) shift 32
+ extend ('0' + nr // 10 mod 10) shift 24
+ extend ('0' + nr // 1 mod 10) shift 16
+ extend 'o' shift 8;
write (out, "nl", 1, <:begin r:>,
<: main.:>, nameifp, <: adpdev.:>, nameimc,
<: port.:>, namein, <: & :>, nameout);
open (zifp, 0 shift 12 + 0, nameifp, 1 shift 9); <* mode=0 => kun mig som user *>
ldunlink (zifp, 0, nameimc, res); <* fjern evt gammelt link *>
test (nr, <:ldlink:>);
i := - 1; <* første frie device *>
if ldlink (zifp, i, nameimc, 2, <::>, res) then
begin <* makelink ok *>
open (zimc, 20, nameimc, 1 shift 9);
test (nr, <:imcopenport:>);
if imcopenport (zimc, 0, namein, reason) then
begin <* ok *>
for testnr := 1 step 1 until anttest do
begin <* pr connect *>
comment trap (rydop);
index := 0;
if x_imc_connect (zimc, index, nameout, reason) then
begin <* connect ok *>
ionr := 0;
repeat
test (nr, <:i:>);
setposition (zimc, 0, 0);
inrec6 (zimc, (buflgd + 2) // 3 * 2);
ionr := ionr + 1;
write (out, "sp", 1, <<d>, "'", 1, zimc (1) extract 8, "'", 1, ":", 1, ionr);
until zimc (1) = real <:<25><25><25><25><25>:> add 25;
end connect ok
else fejl (nr, <:imcconnect:>, nameout, reason);
rydop:
trap (0);
test (nr, <:imcdisconn:>);
imcdisconn (zimc, reason);
end pr connect;
end imcopenport ok
else fejl (nr, <:imcopenport:>, namein, reason);
test (nr, <:imccloseprt:>);
imccloseprt (zimc, reason);
close (zimc, true);
end makelink ok
else fejl (nr, <:ldlink:>, nameimc, res);
test (nr, <:ldunlink:>);
if not ldunlink (zifp, 0, nameimc, res)
then fejl (nr, <:ldunlink:>, nameimc, res);
close (zifp, true);
test (nr, <:end r:>);
end procedure r;
\f
getzone6 (out, ia);
online := ia (1) <> 4;
input := true;
buflgd := 768;
maxio := 100;
anttest := 4;
inc := 2;
i := 1;
for j := system (4, i, la) while j <> 0 do
if j shift (- 12) <> 4
or j extract 12 < 10
then system (9, i, <:<10>***call:>)
else
begin <* text *>
if la (1) = long <:io:> then
begin <* io.i/o *>
j := system (4, i + 1, la);
if j = 8 shift 12 + 10 and la (1) shift (- 40) extract 8 = 'r'
then input := true
else
if j = 8 shift 12 + 10 and la (1) shift (- 40) extract 8 = 'w'
then input := false
else
system (9, i, <:<10>***call:>);
end buflgd
else
if la (1) shift (- 40) extract 8 = 'b' then
begin <* b.<buflgd> *>
if system (4, i + 1, la) = 8 shift 12 + 4
then buflgd := la (1)
else system (9, i, <:<10>***call:>);
end buflgd
else
if la (1) shift (- 40) extract 8 = 'm' then
begin <* m.<maxio> *>
if system (4, i + 1, la) = 8 shift 12 + 4
then maxio := la (1)
else system (9, i, <:<10>***call:>);
end buflgd
else
if la (1) shift (- 40) extract 8 = 'a' then
begin <* a.<anttest> *>
if system (4, i + 1, la) = 8 shift 12 + 4
then anttest := la (1)
else system (9, i, <:<10>***call:>);
end buflgd
else
if la (1) shift (- 40) extract 8 = 'i' then
begin <* i.<inc> *>
if system (4, i + 1, la) = 8 shift 12 + 4
then inc := la (1)
else system (9, i, <:<10>***call:>);
end buflgd
else
system (9, i, <:<10>***call:>);
i := i + 2;
end pr fp;
write (out, <:imctest:>, <<d>,
<: io.:>, if input then "r" else "w", 1,
<: b.:>, buflgd,
<: m.:>, maxio,
<: a.:>, anttest,
<: i.:>, inc,
if inc < 0 then <: ; ingen activities:> else <: ; activities:>,
"nl", 1);
if online then setposition (out, 0, 0);
if inc < 1 then
begin <* ej activities *>
nr := 0;
if input then r (nr) else w (nr);
end inc < 1
else
begin <* activities *>
activity (inc);
for nr := 1 step 1 until inc do
begin <* start coroutiner *>
if input
then newactivity (nr, 0, r, nr)
else newactivity (nr, 0, w, nr);
end start;
while inc > 0 do
begin <* reaktiver *>
buf := 0;
for res := w_activity (buf) while res <= 0
do write (out, <<d>, "nl", 1, <:w-activity=:>, res, <: buf.:>, buf);
nr := res;
latest_answer (nr, buf);
write (out, <<d>, <:activate (:>, nr, <:) buf.:>, buf, "sp", 1);
if activate (nr) extract 24 < 1 then system (9, nr, <:<10>død:>); <* inc := inc - 1; *><* afsluttet activity *>
end while inc > 0;
end activities;
end
▶EOF◀