|
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: 34560 (0x8700)
Types: TextFile
Names: »timctest «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦f546e193b⟧
└─⟦this⟧ »timctest «
limctest = set 1 disc1
o limctest
head iso
( oimctest=algol list.yes blocks.yes ix.no connect.no , xref.yes survey.yes ,
list.on copy.timctest1 list.off
if ok.yes
if warning.yes
( o c
message kikset
visfejl limctest
finis
)
o c
message ok
scope user oimctest
end
)
begin
procedure help;
begin
<* udskriver syntaksen for programmet *>
writeint (out, <:
jsc d. 8/12-1988
program: oimctest v.:>, <<d.d>, rel, vers, 1, <:
formål: belastning af rclan
kald:
(ud=)oimctest (a.<antconnect>.<antio> (b.<buf>) ,
(c(.<j/n>)) (d(.<j/n>)) ,
(f.<fil>) (h.<host>) ,
(i.<inc>(.<idx>)) (m.<j/n>) ,
(r.<j/n>) (s.<sh>) ,
(w.<j/n>) (t.<j/n>) ,
(l.<no>) (p.<txt>) ;
UD ::= udskriftsfil
Antal ::= antal connect før afslut, default=10
antal io-operationer pr connect default=100
ved positiv laves random,
ved negativ benyttes tallets
absolutte værdi
Buflgd ::= antal tegn pr io, default=maxsendsize
Check ::= alle data checkes default=nej
Duplex ::= både read og write default=nej
Fil ::= io til fra fil default=ingen fil
Host ::= hostname for remote default=egen host
Inc ::= incarnationer, index default=0.0
max 9.99 dog max inc*idx=99
Lanno ::= lokalnetnummer default=1
Makelink ::= makelink udføres til remotehost default=ja
Print ::= text til udskrift ved tidsmåling default=ingen
Read ::= read eller write default=ja
Shares ::= antal shares overfor imc default=1
Test ::= testudskrifter default=nej
Write ::= write eller read default=nej
hvis duplex laver første port read (ell write), anden det modsate osv.
hvis inc<1 benyttes ikke activities og idx := 0
der oprettes en port pr incarnation og et connectionindex pr index
hvis inc<1 benyttes ikke activities og der benyttes et index
hvis idx<1 sættes til et index
hvis eget hostname er "balsys" gælder følgende defaultværdier:
host.balsu1 read.ja
hvis eget hostname er "balsu1" gælder følgende defaultværdier:
host.balsys write.ja
Rettelser:
v.1.0D jsc d.27/2-1989:
fejl i imc-sense rettet
:>);
end procedure help;
integer rel, fp, buf, res, nr, idx, inc, i, j, k, monrel,
lanno, buflgd, buflgd_hw, maxio, anttest, maxinc, maxidx, shares;
boolean vers, input, output, duplex, online, test, link, datacheck, fil, ok, coroutine;
long reason;
integer array ia (1 : 20);
long array la, filnavn, name_lan, name_imc,
name_local, name_remote, name_l, name_r (1 : 2), txt (1 : 14);
real cpu_ialt, tid_ialt, begin_cpu, begin_tid;
long bytes_ialt, io_ialt;
long array field laf2;
zone zhlp, zlan (1, 1, xstderror);
procedure x_ldsense (z, hostname);
zone z;
long array hostname;
begin
<* lav sense på mainprocessen og returner eget navn *>
integer array ia (1 : 12);
long array field laf8;
laf8 := 8;
getshare6 (z, ia, 1);
ia (3 + 1) := 0 shift 12 + 1; <* sense operation *>
setshare6 (z, ia, 1);
if monitor (16, z, 1, ia) = 0
then system (9, 6, <:<10>break:>)
else i := monitor (18, z, 1, ia);
tofrom (hostname, ia.laf8, 6);
end procedure x_ldsense;
\f
rel := 1 0; <* release * 10 *>
vers := "D"; <* små bogstaver for testversioner, store for rettelser *>
laf2 := 2;
fp := if xconnectout then 2 else 1;
getzone6 (out, ia);
online := ia (1) <> 4;
if system (4, fp, la) = 0 then
begin <* help og så slut *>
help;
goto trap_heltyt; <* slut *>
end;
lanno := 1;
anttest := 10;
buflgd := 0;
datacheck := false;
fil := false;
maxio := 100;
maxinc := 0;
maxidx := 0;
input := output := false;
duplex := false;
test := false;
link := true;
shares := 1;
name_local (1) := name_local (2) := long <::>;
name_remote (1) := name_remote (2) := long <::>;
txt (1) := long <::>;
filnavn (1) := long <::>;
system (5, 64, ia); <* get monitor version *>
monrel := ia (1);
\f
for j := system (4, fp, la) while j <> 0 do
if j shift (- 12) <> 4
or j extract 12 < 10
then system (9, fp, <:<10>***call:>)
else
begin <* text *>
if la (1) shift (- 40) extract 8 = 'a' then
begin <* a.<antalconnect>(.<antalio>) *>
if system (4, fp + 1, la) = 8 shift 12 + 4
then anttest := la (1)
else system (9, fp, <:<10>***call:>);
j := system (4, fp + 2, la);
if j = 8 shift 12 + 4 then maxio := la (1);
fp := fp + (if j = 8 shift 12 + 4 then 3 else 2);
end anttest
else
if la (1) shift (- 40) extract 8 = 'b' then
begin <* b.<buflgd> *>
if system (4, fp + 1, la) = 8 shift 12 + 4
then buflgd := la (1)
else system (9, fp, <:<10>***call:>);
fp := fp + 2;
end buflgd
else
if la (1) shift (- 40) extract 8 = 'c' then
begin <* check(.<janej>) *>
j := system (4, fp + 1, la);
if j = 8 shift 12 + 10
and (la (1) shift (- 40) extract 8 = 'j' or la (1) shift (- 40) extract 8 = 'y')
or j shift (- 12) <> 8
then datacheck := true
else
if j = 8 shift 12 + 10 and la (1) shift (- 40) extract 8 = 'n'
then datacheck := false
else
system (9, fp, <:<10>***call:>);
fp := fp + (if j shift (- 12) = 8 then 2 else 1);
end check
else
if la (1) shift (- 40) extract 8 = 'd' then
begin <* duplex(.<janej>) *>
j := system (4, fp + 1, la);
if j = 8 shift 12 + 10
and (la (1) shift (- 40) extract 8 = 'j' or la (1) shift (- 40) extract 8 = 'y')
or j shift (- 12) <> 8
then duplex := true
else
if j = 8 shift 12 + 10 and la (1) shift (- 40) extract 8 = 'n'
then duplex := false
else
system (9, fp, <:<10>***call:>);
fp := fp + (if j shift (- 12) = 8 then 2 else 1);
end duplex
else
if la (1) shift (- 40) extract 8 = 'h' then
begin <* h.<remotehost> *>
j := system (4, fp + 1, la);
if j = 8 shift 12 + 10
then tofrom (name_remote, la, 8)
else system (9, fp, <:<10>***call:>);
name_remote (2) := name_remote (2) shift (- 32) shift 32; <* max 8 char *>
fp := fp + 2;
end host
else
if la (1) shift (- 40) extract 8 = 'f' then
begin <* fil.<filnavn> *>
fil := true;
j := system (4, fp + 1, la);
if j = 8 shift 12 + 10
then tofrom (filnavn, la, 8)
else system (9, fp, <:<10>***call:>);
fp := fp + 2;
end fil
else
if la (1) shift (- 40) extract 8 = 'i' then
begin <* i.<inc>(.<idx>) *>
if system (4, fp + 1, la) = 8 shift 12 + 4
then maxinc := la (1)
else system (9, fp, <:<10>***call:>);
j := system (4, fp + 2, la);
if j = 8 shift 12 + 4 then maxidx := la (1);
fp := fp + (if j = 8 shift 12 + 4 then 3 else 2);
end inc
else
if la (1) shift (- 40) extract 8 = 'l' then
begin <* lanno *>
if system (4, fp + 1, la) = 8 shift 12 + 4
then lanno := la (1)
else system (9, fp, <:<10>***call:>);
fp := fp + 2;
end lanno
else
if la (1) shift (- 40) extract 8 = 'm' then
begin <* makelink(.<janej>) *>
j := system (4, fp + 1, la);
if j = 8 shift 12 + 10
and (la (1) shift (- 40) extract 8 = 'j' or la (1) shift (- 40) extract 8 = 'y')
or j shift (- 12) <> 8
then link := true
else
if j = 8 shift 12 + 10 and la (1) shift (- 40) extract 8 = 'n'
then link := false
else
system (9, fp, <:<10>***call:>);
fp := fp + (if j shift (- 12) = 8 then 2 else 1);
end makelink
else
if la (1) shift (- 40) extract 8 = 'p' then
begin <* print.<txt> *>
j := system (4, fp + 1, txt);
if j shift (- 12) = 8 and j extract 12 >= 10
then fp := fp + 2
else system (9, fp, <:<10>***call:>);
end write
else
if la (1) shift (- 40) extract 8 = 'r' then
begin <* read(.<janej>) *>
j := system (4, fp + 1, la);
if j = 8 shift 12 + 10
and (la (1) shift (- 40) extract 8 = 'j' or la (1) shift (- 40) extract 8 = 'y')
or j shift (- 12) <> 8
then input := true
else
if j = 8 shift 12 + 10 and la (1) shift (- 40) extract 8 = 'n'
then input := false
else
system (9, fp, <:<10>***call:>);
output := not input;
fp := fp + (if j shift (- 12) = 8 then 2 else 1);
end read
else
if la (1) shift (- 40) extract 8 = 's' then
begin <* s.<shares> *>
if system (4, fp + 1, la) = 8 shift 12 + 4
then shares := la (1)
else system (9, fp, <:<10>***call:>);
fp := fp + 2;
end shares
else
if la (1) shift (- 40) extract 8 = 't' then
begin <* test(.<janej>) *>
j := system (4, fp + 1, la);
if j = 8 shift 12 + 10
and (la (1) shift (- 40) extract 8 = 'j' or la (1) shift (- 40) extract 8 = 'y')
or j shift (- 12) <> 8
then test := true
else
if j = 8 shift 12 + 10 and la (1) shift (- 40) extract 8 = 'n'
then test := false
else
system (9, fp, <:<10>***call:>);
fp := fp + (if j shift (- 12) = 8 then 2 else 1);
end test
else
if la (1) shift (- 40) extract 8 = 'w' then
begin <* write(.<janej>) *>
j := system (4, fp + 1, la);
if j = 8 shift 12 + 10
and (la (1) shift (- 40) extract 8 = 'j' or la (1) shift (- 40) extract 8 = 'y')
or j shift (- 12) <> 8
then output := true
else
if j = 8 shift 12 + 10 and la (1) shift (- 40) extract 8 = 'n'
then output := false
else
system (9, fp, <:<10>***call:>);
input := not output;
fp := fp + (if j shift (- 12) = 8 then 2 else 1);
end write
else
system (9, fp, <:<10>***call:>);
end pr fp;
if shares < 1 then shares := 1;
if maxinc > 10 then maxinc := 10;
if maxinc < 1 then
begin
maxinc := 1;
coroutine := false;
end
else coroutine := true;
if maxidx < 1 then maxidx := 1 else
if maxidx > 99 then maxidx := 99;
if maxidx * maxinc > 99 then maxidx := 99 // maxinc;
if monrel shift (- 12) < 15
then movestring (name_lan, 1, <:ifpmain:>)
else movestring (name_lan, 1, <:lanmain:>);
name_lan (2) := name_lan (2) shift (- 40) shift 40
+ extend (lanno mod 10 + '0') shift 32;
open (zlan, 0 shift 12 + 0, name_lan, 1 shift 9); <* mode=0 => kun mig som user *>
if monrel shift (- 12) < 15
then xhost (name_local)
else x_ldsense (zlan, name_local);
name_local (2) := name_local (2) shift (- 32) shift 32; <* max 8 char *>
name_remote (2) := name_remote (2) shift (- 32) shift 32; <* max 8 char *>
if name_remote (1) <> long <::> then
begin <* parameter indsat *>
if input == output then
begin <* beregn input/output *>
input := name_local (1) < name_remote (1)
or name_local (1) = name_remote (1) and name_local (1) extract 8 <> 0
and name_local (2) < name_remote (2);
if name_local (1) = name_remote (1) and name_local (2) = name_remote (2)
then output := input
else output := not input;
end beregn;
end parameter
else
if name_local (1) = long <:balsu:> add '1' and name_local (2) = long <::> then
begin <* specielle defaultparametre for balsu1 *>
movestring (name_remote, 1, <:balsys:>);
input := false;
output := true;
end
else
if name_local (1) = long <:balsy:> add 's' and name_local (2) = long <::> then
begin <* specielle defaultparametre for balsys *>
movestring (name_remote, 1, <:balsu1:>);
input := true;
output := false;
end
else tofrom (name_remote, name_local, 8);
if input == output then system (9, 8, <:<10>r/w?:>);
\f
begin <* extra *>
zone array zimc (maxinc, 1, 1, xstderror);
<* statusinformation *>
real array sidst_rørt (1 : maxinc * maxidx);
integer array antal_io (1 : maxinc * maxidx);
integer first_buf, last_buf;
procedure fejl (nr, idx, txt, tal);
value tal;
integer nr, idx;
string txt;
integer tal;
begin
errorbits := 1 shift 0 + 1 shift 1;
wr_test (nr, idx, txt, tal);
end procedure fejl;
procedure fejl_reason (nr, idx, txt, la, reason);
value reason;
integer nr, idx;
string txt;
long array la;
long reason;
begin
integer i;
fejl (nr, idx, txt, - 1);
write (out,
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);
system (9, 8, <:<10>break:>);
end procedure fejl_reason;
procedure wr_test (nr, idx, txt, tal);
value tal;
integer nr, idx;
string txt;
integer tal;
begin
writeint (out, <<d>, "nl", 1, nr, ".", 1, idx, ":", 1,
<<zddd.dd>, xkl, ":", 1, txt, "sp", 1);
if tal <> - 1 then write (out, <<d>, tal, "sp", 1);
if online then setposition (out, 0, 0);
end procedure wr_test;
procedure wr_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 wr_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 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,
<: rørt:>,
<: read/write:>,
<: antio:>,
<: waitbuf:>,
<: status:>);
for nr := 1 step 1 until maxinc * maxidx do
begin
systime (4, sidst_rørt (nr), kl);
system (12, nr, ia);
writeint (z, "nl", 1,
<<zddd.dd>, round (kl),
"sp", 1, true, 10, if if not duplex or nr extract 1 = 1 then input else output
then <:read:> else <:write:>,
<<bdddddd>, antal_io (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
procedure latest_answer (z, nr, idx, buf);
zone z;
integer nr, idx, buf;
begin
integer array ia (1 : 20);
integer i, j;
system (5, buf + 8, ia);
write (z, "nl", 1, <<d>, nr, ".", 1, idx, ":", 1,
<: latest answer, buf.:>, buf, "nl", 1);
for i := 1 step 1 until 8 do
begin
write (z, <<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 (z, <<-ddd>, ia (i) shift j extract 8)
else write (z, "sp", 3, false add (ia (i) shift j extract 8), 1);
write (z, "sp", 2);
for j := 0 step 1 until 23 do
write (z, "sp", if j mod 6 <> 0 then 0 else 1,
if ia (i) shift (j - 23) extract 1 = 0 then "." else "1", 1);
write (z, "nl", 1);
end;
getzone6 (z, ia);
if ia (1) <> 4 then setposition (z, 0, 0);
end procedure latest_answer;
procedure vent (tid);
value tid;
long tid;
begin <* vent i tid 0.0001 sekunder *>
integer array ia (1 : 20);
zone z (1, 1, xstderror);
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;
\f
procedure regret (z, sh);
zone z;
integer sh;
begin
<* proceduren sender en regret på sidste message udført i z's share sh *>
integer array ia (1 : 12);
getshare6 (z, ia, sh);
if ia (1) > 1 <* buffer ude *>
and ia (4) shift (- 12) extract 1 = 0 <* ulige operation *>
then monitor (82, z, sh, ia);
end procedure regret;
boolean procedure imc_sense (z, index, reason);
zone z;
integer index;
long reason;
begin <* proceduren udfører en imc-sense *>
integer i;
integer array ia (1 : 12);
getshare6 (z, ia, 1);
ia (4) := 0; <* sense operation *>
ia (5) := ia (6) := 0;
ia (7) := index; <* hvis index = 0 så portstate ellers connectionstate *>
setshare6 (z, ia, 1);
if test then
begin
wr_test (nr, idx, <:sense:>, - 1);
write (out, <: index=:>, <<d>, index, <: segm=:>, segm (z), "sp", 1);
end test;
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;
if test then wr_test_reason (reason);
imc_sense := i = 1;
end procedure imc_sense;
boolean procedure test_imc_connection (z, index, reason);
zone z;
integer index;
long reason;
begin <* proceduren udfører en række imc-sense for at kontrolere connection *>
while imc_sense (z, index, reason)
and (reason shift (- 12) extract 12 = 1 <* accepting *>
or reason shift (- 12) extract 12 = 2) <* connecting *>
do vent (0 2500);
test_imc_connection := reason shift (- 12) extract 12 = 3; <* connected *>
if test then outchar (out, 'nl');
end procedure test_imc_connection;
boolean procedure x_vent_imc_connect (z, index, name, reason);
zone z;
integer index;
long array name;
long reason;
begin <* afventer en connection på ubestemt tid *>
boolean ok;
integer forsøg;
if test then wr_test (nr, idx, <:x-vent-imc-connect, index=:>, index);
forsøg := 0;
repeat
forsøg := forsøg + 1;
ok := x_imc_connect (z, index, name, reason);
if not ok then vent (if forsøg <= 5 then 0 5000 else
if forsøg <= 10 then 1 0000 else
if forsøg <= 25 then 2 5000 else 10 0000); <* antal 1/10000 sek imellem forsøgene *>
until ok;
x_vent_imc_connect := ok;
end procedure x_vent_imc_connect;
boolean procedure x_lav_imc_connect (zimc, index, local, remote, reason);
zone zimc;
integer index;
long array local, remote;
long reason;
begin
<* proceduren afventer connection for index portindex på følgende vis:
porten med laveste værdi af navn laver getconnect, den anden connect
*>
if local (1) < remote (1)
or local (1) = remote (1) and local (2) < remote (2)
then x_lav_imc_connect := x_imc_getconnect (zimc, index, reason)
else x_lav_imc_connect := x_vent_imc_connect (zimc, index, remote, reason);
end procedure x_lav_imc_connect;
boolean procedure x_imc_connect (z, index, name, reason);
zone z;
integer index;
long array name;
long reason;
begin <* udfører connect og afventer ok *>
boolean ok, connected;
integer gem_index;
gem_index := index;
ok := connected := false;
if test then
begin
wr_test (nr, idx, <:imcconnect, index=:>, index);
write (out, <: index=:>, <<d>, index, "sp", 1);
end test;
if imcconnect (z, index, name, reason) then
begin <* connect *>
if test then write (out, <:imcconnect=true, index=:>, <<d>, index, "sp", 1);
ok := true;
if index = 0
or index <> gem_index and gem_index <> 0
or segm (z) <> index
then system (9, nr * 100 + idx, <:<10>index?:>);
if test_imc_connection (z, index, reason) then
begin <* connection ok *>
if test then write (out, <:imcconnect=true, connect=ok, index=:>, <<d>, index, "sp", 1);
connected := true;
end connection ok
else
begin <* connection ej ok *>
if test then write (out, <:imcconnect=true, connect=ej-ok, index=:>, <<d>, index, "sp", 1);
imcdisconn (z, reason);
connected := false;
end connection ej ok;
end connect ok
else
begin <* connect ej ok *>
if test then write (out, <:imcconnect=false, index=:>, <<d>, index, "sp", 1);
ok := connected := false;
imcdisconn (z, reason);
end connect ej ok;
if test then wr_test_reason (reason);
if index <> gem_index and gem_index <> 0
then system (9, nr * 100 + idx, <:<10>index??:>);
x_imc_connect := ok and connected;
end procedure x_imc_connect;
boolean procedure x_imc_getconnect (z, index, reason);
zone z;
integer index;
long reason;
begin <* udfører getconnect og afventer ok *>
boolean ok, connected;
integer gem_index;
gem_index := index;
ok := connected := false;
repeat
if test then
begin
wr_test (nr, idx, <:imcgetconn, index=:>, index);
write (out, <: index=:>, <<d>, index, "sp", 1);
end test;
if imcgetconn (z, index, reason) then
begin <* getconnect *>
if test then write (out, <:imcgetconn=true, index=:>, <<d>, index, "sp", 1);
ok := true;
if index = 0
or index <> gem_index and gem_index <> 0
or segm (z) <> index
then system (9, nr * 100 + idx, <:<10>index?:>);
if test_imc_connection (z, index, reason) then
begin <* connection ok *>
if test then write (out, <:imcgetconn=true, connect=ok, index=:>, <<d>, index, "sp", 1);
connected := true;
end connection ok
else
begin <* connection ej ok *>
if test then write (out, <:imcgetconn=true, connect=ej-ok, index=:>, <<d>, index, "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 *>
if test then write (out, <:imcgetconn=false, index=:>, <<d>, index, "sp", 1);
ok := connected := false;
imcdisconn (z, reason);
end getconnect ej ok;
if test then wr_test_reason (reason);
until connected or not ok;
if index <> gem_index and gem_index <> 0
then system (9, nr * 100 + idx, <:<10>index??:>);
x_imc_getconnect := ok and connected;
end procedure x_imc_getconnect;
\f
algol copy.1;
\f
system (5, 86, ia); <* first/last buf *>
first_buf := ia (1);
last_buf := ia (2);
system (5, system (6, 0, la) + 26, ia); <* get bufferclaim *>
i := 2 + (maxinc * maxidx) * (if duplex then shares + 1 else shares); <* wanted bufs *>
if ia (1) shift (- 12) < i
then system (9, i, <:<10>bufs:>);
trap (trap_død);
cpu_ialt := tid_ialt := 0;
bytes_ialt := io_ialt := 0;
xnulstil (antal_io);
if buflgd = 0 then
begin <* benyt maxsendsize *>
i := - 1; <* første frie device *>
reason := 1; <* antal imc bufs *>
ldlink (zlan, i, <::>, 2, <::>, reason); <* lav link for at få maxsend *>
buflgd := reason shift (- 32) extract 16; <* maxsendsize *>
ldunlink (zlan, i, <::>, reason); <* fjern link *>
end maxsendsize;
if fil then
begin
anttest := 1;
buflgd := buflgd // 6 // 128 * 128 * 6;
maxidx := 1;
maxinc := 1;
coroutine := false;
end fil;
buflgd := buflgd // 6 * 6;
buflgd_hw := buflgd // 6 * 4;
if maxinc <= 1 then duplex := false;
if coroutine then activity (maxinc * maxidx);
inc := maxinc * maxidx;
write (out, <<d>,
"nl", 1, "-", 70,
"nl", 1, ";", 1,
<: Antal.:>, anttest, ".", 1, maxio,
<: Buflgd.:>, buflgd,
if datacheck then <: Check.ja:> else <::>,
if duplex then <: Duplex.ja:> else <::>,
if fil then <: Fil.:> else <::>, filnavn,
<: Hostremote.:>, name_remote,
<: Inc.:>, maxinc, ".", 1, maxidx,
"nl", 1, ";", 1,
<: Lanno.:>, lanno,
if not link then <: Makelink.nej:> else <::>,
if input then <: Read.ja:> else <::>,
if output then <: Write.ja:> else <::>,
<: Shares.:>, shares,
if test then <: Test.ja:> else <::>,
"nl", 1, ";", 1,
if coroutine then <::> else <: ingen:>, <: activities:>,
"nl", 1, "-", 70, "nl", 1);
if online then setposition (out, 0, 0);
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;
for nr := 1 step 1 until maxinc do
begin
idx := 0;
name_imc (1) := long <::>
+ extend (if input then 'r' else 'w') shift 40
+ extend ('0' + nr // 10 mod 10) shift 32
+ extend ('0' + nr // 1 mod 10) shift 24;
tofrom (name_imc.laf2, name_local, 6);
name_l (1) := long <::>
+ extend (if input then 'i' else 'o') shift 40
+ extend ('0' + nr // 10 mod 10) shift 32
+ extend ('0' + nr // 1 mod 10) shift 24;
tofrom (name_l.laf2, name_local, 6);
name_r (1) := long <::>
+ extend (if output then 'i' else 'o') shift 40
+ extend ('0' + nr // 10 mod 10) shift 32
+ extend ('0' + nr // 1 mod 10) shift 24;
tofrom (name_r.laf2, name_remote, 6);
open (zimc (nr), 20, name_imc, 1 shift 9);
if link then ldunlink (zlan, 0, name_imc, reason); <* fjern evt gammelt link *>
i := - 1; <* første frie device *>
j := maxidx * shares + (if duplex then maxidx else 0) + 1; <* antal imc bufs *>
reason := j;
if test and link then wr_test (nr, idx, <:ldlink:>, - 1);
if (if link then not ldlink (zlan, i, name_imc, 2, <::>, reason) else false)
then fejl_reason (nr, idx, <:ldlink:>, name_imc, reason);
if link and reason shift (- 24) extract 8 < j then
begin <* for få buffere skaffet *>
wr_test (nr, idx, <:bufs wanted=:>, j);
wr_test (nr, idx, <:bufsunused=:>, reason shift (- 24) extract 8);
fejl_reason (nr, idx, <:ldlink:>, name_imc, reason);
end for få;
if link then
begin
wr_test (nr, idx, <:deviceno=:>, i);
wr_test (nr, idx, <:maxsendsize=:>, reason shift (- 32) extract 16);
wr_test (nr, idx, <:bufsunused=:>, reason shift (- 24) extract 8);
end link;
if test then wr_test (nr, idx, <:imcopenport:>, - 1);
if not imcopenport (zimc (nr), 3, name_l, reason)
then fejl_reason (nr, idx, <:imcopenport:>, name_imc, reason);
if not coroutine then
begin <* ej activities *>
nr := 1;
idx := 1;
systime (1, 0, sidst_rørt ((nr - 1) * maxidx + idx));
io_proc (1, nr, idx, input, name_imc, name_l, name_r)
end not coroutine
else
begin <* start activities *>
for idx := 1 step 1 until maxidx do
begin <* start coroutiner *>
systime (1, 0, sidst_rørt ((nr - 1) * maxidx + idx));
i := newactivity ((nr - 1) * maxidx + idx, 0, io_proc,
(nr - 1) * maxidx + idx, nr, idx,
if not duplex or nr extract 1 = 1 then input else output,
name_imc, name_l, name_r) extract 24;
if i <= 0 then system (9, i, <:<10>error:>); <* fejlet i opstarten *>
end start;
end start activities;
end for nr;
if coroutine then
begin <* kør activities *>
begin_cpu := systime (1, 0, begin_tid);
while inc > 0 do
begin <* reaktiver *>
buf := 0;
for res := w_activity (buf) while res < 0 do
if test then write (out, <<d>, "nl", 1, <:w-activity=:>, res, <: buf.:>, buf);
if res = 0 then
begin <* skriv status *>
zone z (128, 1, stderror);
monitor (20, zhlp, buf, ia); <* get message *>
ia (9) := 2; <* rejected *>
monitor (22, zhlp, buf, ia); <* send answer *>
getzone6 (zhlp, ia);
open (z, ia (1), ia.laf2, 0);
write_status (z);
close (z, false);
end fjern message
else
begin <* answer *>
nr := res;
if datacheck then
begin <* check korrekt buffer *>
system (12, nr, ia);
if ia (1) <> buf then
begin <* forkert buf *>
latest_answer (out, nr, idx, buf);
system (9, 8, <:<10>break:>);
end forkert buf;
end datacheck;
comment write (out, <<d>, <:activate (:>, nr, <:) buf.:>, buf, "sp", 1);
systime (1, 0, sidst_rørt (nr));
i := activate (nr) extract 24;
if i > 0 then <* pasivated activity *> else
if i = 0 then inc := inc - 1 <* afsluttet activity *>
else system (9, nr, <:<10>activity:>); <* fejlet activity *>
end answer;
end while inc > 0;
cpu_ialt := systime (1, begin_tid, tid_ialt) - begin_cpu;
end kør activities;
if cpu_ialt > 0 then
begin
write (out, <<d>,
"nl", 1, "-", 70,
"nl", 1, ";", 1,
<: Antal.:>, anttest, ".", 1, maxio,
<: Buflgd.:>, buflgd,
if datacheck then <: Check.ja:> else <::>,
if duplex then <: Duplex.ja:> else <::>,
if fil then <: Fil.:> else <::>, filnavn,
<: Hostremote.:>, name_remote,
<: Inc.:>, maxinc, ".", 1, maxidx,
"nl", 1, ";", 1,
<: Lanno.:>, lanno,
if not link then <: Makelink.nej:> else <::>,
if input then <: Read.ja:> else <::>,
if output then <: Write.ja:> else <::>,
<: Shares.:>, shares,
if test then <: Test.ja:> else <::>,
"nl", 1, ";", 1,
if coroutine then <::> else <: ingen:>, <: activities:>,
"nl", 1, "-", 70, "nl", 1);
if txt (1) <> long <::>
then write (out, "nl", 1, "-", 70, "nl", 1, txt);
write (out,
"nl", 1, "-", 70, "nl", 1,
<:Hastighedsmålinger:>,
"nl", 1, <:Local host :>, "sp", 10 - xtextlgd (name_local), name_local,
"nl", 1, <:Remote host :>, "sp", 10 - xtextlgd (name_remote), name_remote,
"nl", 1, <:Lokalnet :>, "sp", 10 - xtextlgd (name_lan), name_lan,
"nl", 1, <:Bufferlængde :>, <<dd ddd ddd>, buflgd, <: byte:>,
"nl", 1, <:Porte :>, <<dd ddd ddd>, maxinc,
"nl", 1, <:Connections pr port :>, <<dd ddd ddd>, maxidx,
"nl", 1, <:Shares pr connect :>, <<dd ddd ddd>, shares,
"nl", 1, <:Transmiteret :>, <<dd ddd ddd>, bytes_ialt // 1024, <: kbyte:>,
"nl", 1, <:Antal buffere :>, <<dd ddd ddd>, io_ialt, <: io:>,
"nl", 1, <:Realtidsforbrug :>, <<dd ddd.ddd>, tid_ialt, <: sek:>,
"nl", 1, <:Kbyte/sek :>, <<dd ddd ddd>, bytes_ialt / 1024 / tid_ialt,
"nl", 1, "-", 70, "nl", 1);
end;
if false then
trap_død:
begin <* fejlet *>
comment write_status (out);
end;
trap (trap_yt);
for nr := 1 step 1 until maxinc do
begin
name_imc (1) := long <::>
+ extend (if input then 'r' else 'w') shift 40
+ extend ('0' + nr // 10 mod 10) shift 32
+ extend ('0' + nr // 1 mod 10) shift 24;
tofrom (name_imc.laf2, name_local, 6);
name_l (1) := long <::>
+ extend (if input then 'i' else 'o') shift 40
+ extend ('0' + nr // 10 mod 10) shift 32
+ extend ('0' + nr // 1 mod 10) shift 24;
tofrom (name_l.laf2, name_local, 6);
name_r (1) := long <::>
+ extend (if output then 'i' else 'o') shift 40
+ extend ('0' + nr // 10 mod 10) shift 32
+ extend ('0' + nr // 1 mod 10) shift 24;
tofrom (name_r.laf2, name_remote, 6);
if test then wr_test (nr, idx, <:imccloseprt:>, - 1);
imccloseprt (zimc (nr), reason);
if test and link then wr_test (nr, idx, <:ldunlink:>, - 1);
if (if link then not ldunlink (zlan, 0, name_imc, reason) else false)
then fejl_reason (nr, idx, <:ldunlink:>, name_imc, reason);
close (zimc (nr), true);
end closeport;
close (zlan, true);
if false then
trap_yt:
begin <* fejlet *>
comment write_status (out);
fejl (0, 0, <:programnedgang:>, - 1);
end;
end extra;
trap_heltyt:
outchar (out, 'nl');
xconnectout;
trapmode := 1 shift 10;
end
▶EOF◀