DataMuseum.dk

top - metrics - download

    Length: 42240 (0xa500)
    Types: TextFileVerbose
    Names: »tnet2«

└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
    └─⟦6b41451d2⟧ 
        └─⟦this⟧ »tnet2« 

TextFileVerbose

prefix return_empty;
procedure return_empty (var msg: reference; ok: boolean);
begin
msg^.u1 := input_msg;
msg^.u4 := empty_buf;
if ok then
msg^.u2 := result_ok
else
msg^.u2 := result_error;
return (msg);
end;

<* ************************************************* *>

prefix return_full;
procedure return_full (var msg: reference; ok: boolean);
begin
msg^.u1 := output_msg;
msg^.u4 := full_buf;
if ok then
msg^.u2 := result_ok
else
msg^.u2 := result_error;
return (msg);
end;

<* ************************************************ *>
(* this routine has been incorporated in  stdlib revision 6

prefix outnl;
procedure outnl (var z: zone);
begin
outchar (z, nl);
outend  (z);
end;
(* *)

<* ************************************************ *>

prefix outtime;
procedure outtime (var z: zone; t: timetype);
var
min, sec : integer;
begin
with t do
begin
outinteger (z, hours, 2);
outchar (z, '.');
min := seconds div 60;
sec := seconds mod 60;
outinteger (z, min div 10, 1);
outinteger (z, min mod 10, 1);
outchar (z, '.');
outinteger (z, sec div 10, 1);
outinteger (z, sec mod 10, 1);
end;
end;

<* ************************************************ *>

prefix print_msg;
procedure print_msg (var z: zone; var msg: reference; text: alfa);
begin
lock msg as buf:stdpart do
with buf do
begin
outtext (z, text);
outinteger (z, msg^.u1, 2);
outinteger (z, msg^.u2, 2);
outinteger (z, msg^.u3, 2);
outinteger (z, msg^.u4, 2);
outinteger (z, msg^.size, 4);
outinteger (z, first, 4);
outinteger (z, last,  4);
outinteger (z, next, 4);
outnl (z);
end;
end; <* print_msg *>

<* ************************************************ *>

process fpadriver(n: integer; var pdescr: proc_descrs; var sems: sem_arr);

const
<* definition of control-commands *>
reset_contr = 0;
repeat_int  = 2;
start_read  = 3;
<* definition of status-bits *>
st_parity_error      = 1;
st_reset_received    = 2;
st_disconnected      = 4;
st_autoload_received = 8;
st_receive_end       = 16;
st_timeout           = 32;
st_transmit_end      = 64;
<* definition of start char *>
block_start = #b10000110;  <* does not interfere with ncp-chars *>
<* definition of timers *>
read_period = 15; <* seconds *>
write_period = 15; <* seconds *>
after_error = 2; <* seconds pause *>

var
chm      : reference;
msg      : reference;
dummy    : integer;
start_char: integer;
mainsem  : ^ semaphore;
ch_ptr   : ^ array (1..maxint) of byte;
test     : boolean;
s        : integer;  <* last status read *>
result   : integer;  <* suggested result *>

zout     : zone;
out_pool : pool 1 of opbuffer;

procedure make_sense;
begin
sense (s, 0, chm);
if (s <> st_receive_end) and (s <> st_transmit_end) then
begin
result := result_error;
control (reset_contr, chm);
end
else
result := result_ok;
end;

begin
openopzone (zout, own.secret_pointer^(opsem), ref(zout.free), 1, out_pool, 2,7,0,0);
with pdescr(n) do
begin
dummy   := reservech (chm, first_devno_fpa - 1 + inc, 0);
mainsem := ref (sems(sem));
definetimer (true);
make_sense;

channel chm do
repeat <* forever *>

wait (msg, mainsem^);

test := pdescr(n).testval <> 0;
if test then print_msg (zout, msg, 'after wait:');

case msg^.u4 of

empty_buf:
begin
own.timer := read_period;
lock msg as buf: stdpart do
with buf, header do
begin
repeat
controlclr(start_read, chm);
inword (start_char, chm);
controlclr (repeat_int, chm);
inbyteblock(next, first, last, msg, chm);
make_sense;
until (own.timer = 0) or ((s and st_reset_received) = 0);
last := next - 1;
end;
if test then print_msg (zout, msg, 'after read:');
return_full (msg, (start_char = block_start) and (result = result_ok) and (not timedout));
end;

full_buf:
begin
own.timer := write_period;
ch_ptr := ptraddr(msg^.start);
lock msg as buf: stdpart do
with buf do
begin
outwordclr (0 <* irrel start char *>, chm);
outbyteblock (next, first, last-1, msg, chm);
controlclr (repeat_int, chm);
outwordclr (256 + ch_ptr^(last), chm);
end;
make_sense;
if test then print_msg (zout, msg, 'after write:');
return_empty (msg, (result = result_ok) and (not timedout));
if result <> result_ok then
begin
own.timer := after_error;
waitt;
end;
end;

end; <* case *>

until doomsday;

end; <* with pdescr *>
end; <* fpadriver *>

<* *********************************************************** *>

process hdlcdriver (n: integer; var pdescr: proc_descrs; var sems: sem_arr);

const

<* control commands *>
dma_reset    =  0*256;
trm_control  =  3*256;
mode_control =  5*256;
datalength   =  7*256;
setadrl      =  8*256;
setadrh      =  9*256;
setcntl      = 10*256;
setcnth      = 11*256;
setfll       = 12*256;
setflh       = 13*256;
setmsel      = 14*256;
start_rec    = 16*256;
start_xmit   = 17*256;
enable       = 18*256;
modem_control= 19*256;
step_pointer3= 20*256;
step_pointer0= 21*256;

<* sense registers *>
statusreg0   =  0*256;
countreg0    = 24*256;

<* xmit flags (high) *>
set_int      = 8;
set_teom     = 4;
clear_tsom   = 2;

<* xmit flags (low) *>
trm_valid    = 2;

<* rec flags (high) *>
exp_reom     = 4;

<* rec flags (low) *>
rec_valid    = 2;

<* status bits *>
rec_errors   = #h40fc;
xmit_errors  = #h1080;

<* modem bits *>
txe          = 2;
rxe          = 1;

<* timer periods *>
read_period  = 15; <* seconds *>
write_period = 10; <* seconds *>

var
mainsem   : ^ semaphore;
msg       : reference;
dev       : reference;
dummy     : integer;
ok        : boolean;
remcount  : integer;
status    : integer;

zout      : zone;
out_pool  : pool 1 of opbuffer;

procedure dodma (fh, fl, ctrl, period, mask: integer);
type
word = record h, l: byte end;
procedure asgn = asgnintset (var w: word; i: integer); external;
var
w: word;
begin
lock msg as buf: stdpart do
with buf do
begin

control (setmsel + msg^.start.base.mem_no, dev);
control (fh, dev);

asgn (w, first-last-1);
control (setcnth + w.h, dev);
control (setcntl + w.l, dev);

asgn (w, uadd(msg^.start.disp, first));
control (setadrh + w.h, dev);
control (setadrl + w.l, dev);

control (fl, dev);

control (step_pointer3, dev);

control (ctrl, dev);

own.timer := period;
controlclr (enable, dev);
if timedout then
begin
control (dma_reset, dev);
ok := false;
remcount := 0;
end
else
begin
sense (remcount, countreg0, dev);
sense (status, statusreg0, dev);
control (step_pointer0, dev);
ok := (status and mask) = 0;
end;

last := last + remcount;
end;

end; <* dodma *>

begin <* body of hdlc *>

with pdescr(n) do
begin
openopzone (zout, own.secret_pointer^(opsem), ref(zout.free), 1, out_pool, 2,7,0,0);
dummy := reservech (dev, first_devno_hdlc + inc - 1, 0);
definetimer (true);
mainsem := ref (sems(sem));

control (dma_reset, dev);
control (trm_control + 0, dev);
control (mode_control + 0, dev);
control (datalength + 0, dev);
control (modem_control + txe + rxe, dev);

channel dev do
repeat

wait (msg, mainsem^);
if testval <> 0 then print_msg (zout, msg, 'after wait:');
case msg^.u4 of
empty_buf:
begin
dodma (
setflh + exp_reom,
setfll + rec_valid,
setfll + 0-0-0, <* dummy *>
read_period,
rec_errors);
if testval <> 0 then print_msg (zout, msg, 'after read:');
return_full (msg, ok);
end;
full_buf:
begin
dodma(
setflh + set_int + set_teom + clear_tsom,
setfll + 0-0-0,
start_xmit + trm_valid,
write_period,
xmit_errors);
if testval <> 0 then print_msg (zout, msg, 'after write:');
return_empty (msg, ok);
end;
end;

until doomsday;
end;
end; <* hdlc driver *>

<* *********************************************************** *>

process gcidriver (n: integer; var pdescr: proc_descrs; var sems: sem_arr);

const
read_period  = 15; <* seconds *>
write_period = 10; <* seconds *>


var
mainsem   : ^ semaphore;
msg       : reference;
dev       : reference;
dummy     : integer;
newlast   : integer;
ok        : boolean;

zout      : zone;
out_pool  : pool 1 of opbuffer;

procedure get_last (var last: integer);
var
dummy : integer;
begin
with pdescr (n) do
begin
repeat
if testval <> 0 then
begin
outtext (zout, 'wait eoi#');
outnl (zout);
end;
controlclr (0, dev);
inword (dummy, dev);
until eoi or (own.timer = 0);
if own.timer = 0 then
last := 0
else
sense (last, 0, dev);
if testval <> 0 then
begin
outtext (zout, 'newlast=#');
outinteger (zout, last, 1);
outnl (zout);
end;
end;
end;

begin <* body of gci-driver *>

with pdescr(n) do
begin
openopzone (zout, own.secret_pointer^(opsem), ref(zout.free), 1, out_pool, 2,7,0,0);
dummy := reservech (dev, first_devno_gci + inc - 2 * ((inc + 1) and 1), 0);
definetimer (true);
mainsem := ref (sems(sem));

channel dev do
repeat <* forever *>

wait (msg, mainsem^);
if testval <> 0 then print_msg (zout, msg, 'after wait:');
case msg^.u4 of

empty_buf:
begin
repeat
own.timer := read_period;

<* get into sync *>
repeat
get_last (newlast);
until (own.timer = 0) or (newlast > 0);

ok := false;
if newlast > 0 then
lock msg as buf: stdpart do
with buf do
begin
controlclr (0, dev);
inwordblock (next, first, newlast or 1, msg, dev);
last := newlast;
ok := next > last;
end;
if testval <> 0 then print_msg (zout, msg, 'after read:');
get_last (newlast);
ok := ok and (not timedout);
until newlast <> -1;

return_full (msg, (newlast = 0) and ok);

end;

full_buf:
begin
own.timer := write_period;
repeat
lock msg as buf: stdpart do
with buf do
begin
controlclr (-1, dev);
controlclr (last, dev);
outwordblock (next, first, last or 1, msg, dev);
<* wait for the last interrupt *>
repeat
sense (dummy, 0, dev);
until ((dummy and 1) = 1) or (own.timer = 0);
ok := next > last;
end;
if testval <> 0 then print_msg (zout, msg, 'after write:');
until ok or (own.timer = 0);
controlclr (0, dev);
return_empty (msg, (not timedout) and ok);
end;

end; <* buffer type *>

until doomsday;

end; <* with pdescr *>
end; <* gcidriver *>

<* *********************************************************** *>

process onteldriver (n: integer; var pdescr: proc_descrs; var sems: sem_arr);

const
<* control-commands to ontel *>
reset       = 0;
ready       = 1;
start_read  = 4;
keyb_locked = 5;
start_write = 8;
end_write   = 10;
answer_void = 32;

<* status_bits from ontel *>
ontel_ready_xmit = 2;

<* dummy delay periods *>
loop_count = 1000;

<* timer-periods *>
read_period  = 15; <* seconds *>
write_period = 10; <* seconds *>

var
request_sem     : ^ semaphore;
reply_sem       : ^ semaphore;
msg             : reference;
ont_dev         : reference;

saved_header    : net_header;
transaction_no  : integer;
ontel_status    : integer;
cpu             : byte;
new_req_demanded: boolean;
accepted        : boolean;
dummy           : integer;

i               : integer;
zout            : zone;
out_pool        : pool 1 of opbuffer;


procedure busy_loop (count: integer);
begin
for count := count downto 0 do <* nothing but wait ... *>;
end;

procedure control_no_ack (c: integer; var dev: reference);
begin
control (c, dev); busy_loop (loop_count);
end;
begin <* body of ontel driver *>
with pdescr(n) do
begin
openopzone (zout, own.secret_pointer^(opsem), ref(zout.free), 1, out_pool, 2,7,0,0);
dummy := reservech (ont_dev, first_devno_ontel + inc - 1, 0);
definetimer (true);
request_sem  := ref (sems(sem));
reply_sem    := ref (sems(sem+1));
transaction_no := 0;

control_no_ack (reset, ont_dev);

channel ont_dev do
repeat <* forever *>

repeat <* until acceptable reply *>

case ctrwaitis (keyb_locked, msg, reply_sem^) of

a_interrupt:
begin <* terminal has timed out *>
sense (ontel_status, 0, ont_dev);
if testval <> 0 then
begin
outtext (zout, 'ontel void#');
outhex (zout, ontel_status, 6);
outnl (zout);
end;
accepted := (ontel_status and ontel_ready_xmit) <> 0;
if accepted then
begin <* ontel wants to send a new transaction *>
<* I don't know, if ontel really wants the following *>
control_no_ack (keyb_locked, ont_dev);
control_no_ack (answer_void, ont_dev);
new_req_demanded := true;
end;
end;

a_semaphore:
begin <* reply has arrived *>
lock msg as buf: stdpart do
with buf, header do
begin
if testval <> 0 then
begin
outtext ( zout, 'reply :#');
outinteger (zout, addr(1), 4);
outinteger (zout, transaction_no, 4);
outnl (zout);
end;
accepted := addr(1) = transaction_no;
if accepted then
begin
saved_header := header;
own.timer := write_period;
controlclr (start_write, ont_dev);
outbyteblock (next, size_stdpart, last, msg, ont_dev);
outword (255, ont_dev);
controlclr (end_write, ont_dev);
sense (ontel_status, 0, ont_dev);
<* maybe retrans, if wanted *>
if timedout then
control_no_ack (reset, ont_dev);
end;
end;
return_empty (msg, true);
end; <* reply *>

end; <* case *>

until accepted;

repeat
controlclr (ready, ont_dev);
sense (ontel_status, 0, ont_dev);
if testval <> 0 then
begin
outtext (zout, 'ontel int#');
outhex (zout, ontel_status, 6);
outnl (zout);
end;
until (ontel_status and ontel_ready_xmit) <> 0;

wait (msg, request_sem^);

lock msg as buf: request_buffer do
with buf, req_head, header do
begin
own.timer := read_period;
controlclr (start_read, ont_dev);
inbyteblock (next, size_stdpart, last, msg, ont_dev);
if timedout then
begin
control_no_ack (reset, ont_dev);
new_req_demanded := true;
end
else
begin
if testval <> 0 then
begin
outtext (zout, 'request:#');
if testval > 1 then
for i := 1 to next - size_stdpart do
begin
if i mod 10 = 1 then if i <> 1 then
begin
outnl (zout);
outfill (zout, sp, 8);
end;
outinteger (zout, ord(req_buf(i)), 4);
end;
outnl (zout);
end;
cpu := ord (req_buf(1));
if (cpu = #h30) or (cpu = #h3f) then
begin <* any rc8000 (or master), i.e. new request *>
new_req_demanded := false;
routing_mode     := new_request;
service_kind     := das_search;
req_buf(1)       := chr (#h31);  <* simulate cpu # 1 *>
end
else
begin <* specific rc8000, i.e. next-request *>
header           := saved_header;
routing_mode     := next_request;
end;
if not new_req_demanded then
last := next - 1;
cur        := 1;
transaction_no := (transaction_no + 1) mod 128;
addr(1)    := transaction_no;
end;
end; <* lock msg *>

if new_req_demanded then signal (msg, request_sem^)
else return_full (msg, true);

until doomsday;

end; <* with pdescr *>
end; <* onteldriver *>

<* *********************************************************** *>

process consdriver (n: integer; var pdescr: proc_descrs; var sems: sem_arr);

const
textlgth = 20;
rc8000_period = 15; <* seconds *>

var
msg            : reference;
emptysem       : ^ semaphore;
fullsem        : ^ semaphore;
i              : integer;
transaction_no : integer;
rep_count      : integer;
saved_last     : integer;
before_first   : boolean;
expecting_answ : boolean;

zin, zout      : zone;
in_pool        : pool 1 of opbuffer;
out_pool       : pool 1 of opbuffer;
in_sem         : semaphore;
act            : activation;
latest_time    : integer;

<* phony function... must be replaced later *>
function spec_waitst (var msg: reference; var sem: semaphore): activation;
begin
repeat
sensesem (msg, sem);
until (own.timer = latest_time) or (not nil(msg));
if nil(msg) then spec_waitst := a_delay
else             spec_waitst := a_semaphore;
end;

label
rep_input;

procedure alarm (text: array (1..textlgth) of char);
var
i: integer;
begin
for i := 1 to textlgth do
if text(i) = '#' then i := textlgth
else outchar (zout, text(i));
outnl (zout);
end;

begin
openopzone (zin, own.secret_pointer^(opsem), ref(in_sem), 1, in_pool, 1,7,0,0);
openopzone (zout, own.secret_pointer^(opsem), ref(zout.free), 1, out_pool, 2,7,0,0);
before_first   := true;
transaction_no := 0;

with pdescr(n) do
begin
emptysem := ref (sems(sem));
fullsem  := ref (sems(sem+1));
definetimer(true);
expecting_answ := false;
rep_count := 0;

repeat <* forever *>

if expecting_answ then
if testval = 0 then
act := waitst (msg, fullsem^)
else
act := spec_waitst (msg, fullsem^)
else
wait (msg, emptysem^);

if not (nil(msg)) then
case msg^.u4 of
empty_buf:
begin
lock msg as buf: request_buffer do
with buf, req_head, header do
rep_input:
begin
if rep_count <= 0 then
begin
opin (zin);  opwait (zin, in_pool);

i := 0;
repeat
if i < size_request then i := i + 1;
inchar (zin, req_buf(i));
until req_buf(i) = nl;
saved_last := i + size_stdpart;

<* check syntax *>
case req_buf(1) of
's':
begin
if i<3 then
begin
alarm ('type more data#');  goto rep_input;
end;
case req_buf(2) of
'a': service_kind := serv_a;
'b': service_kind := serv_b;
'c': service_kind := serv_c;
otherwise
begin
alarm ('no such service#');  goto rep_input;
end;
end;
routing_mode := new_request;  before_first := false;
i := 3;
end;
'p':
begin
if before_first then
begin
alarm ("don't start with p#");  goto rep_input;
end;
routing_mode := next_request;
i := 2;
end;
otherwise
begin
alarm ('only s or p#');  goto rep_input;
end;
end;

rep_count := 0;
while (rep_count <= 3200) and (req_buf(i) in (.'0'..'9'.)) do
begin
rep_count := rep_count * 10 + ord(req_buf(i)) - ord('0');
i := i + 1;
end;

own.timer := 32000;  <* prepare for time-test *>

end; <* if rep_count <= 0 *>

<* send request *>
last := saved_last;
cur := 1;
transaction_no := (transaction_no + 1) mod 128;
addr(1) := transaction_no;
end;

return_full (msg, true);

if testval = 0 then
begin
own.timer := rc8000_period;  <* expect answer soon *>
latest_time := 0;
end
else
latest_time := own.timer - rc8000_period;
expecting_answ := true;
end;

full_buf:
begin <* reply arrived *>
lock msg as buf: reply_buffer do
with buf, reply_head, header do
if addr(1) = transaction_no then
begin
if testval = 0 then
own.timer := 0;
expecting_answ := false;
rep_count := rep_count - 1;
if rep_count <= 0 then
begin
if testval <> 0 then
begin
outtext (zout, 'time was:#');
outinteger (zout, 32000-own.timer,3);
outtext (zout, 'seconds#');
outnl (zout);
own.timer := 0;
end;
for i := 1 to last - size_stdpart do
if reply_buf(i) <> nul then
outchar (zout, reply_buf(i));
outend (zout);
end;
end
else
alarm ('wrong answer#');
return_empty (msg, true);
end;
end

else

begin
alarm ('time out#');
own.timer := 0;
expecting_answ := false;
before_first := true;
rep_count := 0;
end;

until doomsday;

end; <* with pdescr *>
end; <* consdriver *>

<* ****************************************************** *>

process server (n: integer; var pdescr: proc_descrs; var sems: sem_arr);

var
msg      : reference;
answ     : reference;
emptysem : ^ semaphore;
fullsem  : ^ semaphore;
serv     : serv_range;
dist     : dist_range;
rout     : routing_modes;

begin
with pdescr(n) do
begin
emptysem := ref (sems(sem));
fullsem  := ref (sems(sem+1));

wait (answ, emptysem^);
lock answ as data: cap_buffer do
with data, cap_head, header do
begin
for serv := 1 to max_serv do
for dist := 0 to max_dist do cap(serv, dist) := 0;
if testval = 0 then
cap(serv_b, 0) := 1
else
cap(serv_c, 0) := 1;
last         := size_cap_buffer - 1;
routing_mode := inform;
cur          := 1;
end;
return_full (answ, true);

repeat <* forever *>
wait (msg, fullsem^);
lock msg as buf: stdpart do
with buf, header do
rout := routing_mode;

case rout of
reply: ; <* nothing *>
next_request,
new_request:
begin
wait (answ, emptysem^);
lock msg as buf1: request_buffer do
lock answ as buf2: request_buffer do
begin
buf2.req_head.last   := buf1.req_head.last;
buf2.req_head.header := buf1.req_head.header;
buf2.req_buf         := buf1.req_buf;
end;
lock answ as buf: reply_buffer do
with buf, reply_head, header do
begin
routing_mode := reply;
cur          := cur + 1;
end;
return_full (answ, true);
end;
inform: ; <* nothing *>
end;
return_empty (msg, true);

until doomsday;
end;
end; <* server *>

<* ******************************************************* *>

process router (var semvect: system_vector);

const
poll_accuracy = 2; <* number of seconds between poll_update *>
poll_period   = 10; <* seconds *>
no_of_outbufs = 8;

var
zin, zout: zone;
in_pool : pool 1 of opbuffer;
out_pool: pool no_of_outbufs of opbuffer;
local_time : timetype := timetype (0, 0);

var
pdescr   : proc_descrs;
sems     : sem_arr;
children : array (1..max_process) of
record
child : shadow;
end;
code_descr: array (prockinds) of
record
name : alfa;
size : integer;
prio : integer;
inc_count: integer;
end;

<* definition of child images *>
process fpa(n: integer; var pdescr: proc_descrs; var sems: sem_arr);
external;

process hdlc(n: integer; var pdescr: proc_descrs; var sems: sem_arr);
external;

process gci(n: integer; var pdescr: proc_descrs; var sems: sem_arr);
external;

process cons(n: integer; var pdescr: proc_descrs; var sems: sem_arr);
external;

process ontel(n: integer; var pdescr: proc_descrs; var sems: sem_arr);
external;

process bbm(n: integer; var pdescr: proc_descrs; var sems: sem_arr);
external;

process server(n: integer; var pdescr: proc_descrs; var sems: sem_arr);
external;



var
mainsem  : ^ semaphore;
msg      : reference;
test     : boolean;

ports    : array (ports_range) of
record
insem       : ^ semaphore;
outsem      : ^ semaphore;
pp          : 0 .. max_port;  <* index in 'portx' *>
proc_no     : 0 .. max_process; <* index in 'pdescr', used only for printouts *>
outstandings: integer; <* note: offset by one... *>
max_outs    : integer; <* note: offset by one... *>
last_status : byte;
end;

portx     : array (port_range) of
record
deliver_status : boolean;  <* true, when status must be sent *>
busy           : boolean;  <* true, while status is being sent *>
pno            : ports_range;  <* index in 'ports' *>
poll_time      : integer;
end;

capability : array (port_range, serv_range, dist_range) of boolean;

dists      : array (serv_range) of
record
last_p  : port_range;
min_dist: array (port_range) of 0..top_dist+1;
end;

status_pool : pool max_status of cap_buffer;
large_pool  : pool max_largepool of reply_buffer;
small_pool  : pool max_smallpool of request_buffer;

procedure testput (text: alfa; var m: reference);
var
i : integer;
begin
print_msg (zout, m, text);
lock m as buf: stdpart do
with buf, header do
begin
outinteger (zout, receiver, 7);
outinteger (zout, routing_mode, 2);
outinteger (zout, service_kind, 2);
outinteger (zout, cur, 3);
if pdescr(0).testval > 1 then
for i := 1 to cur do outinteger (zout, -addr(i), 1);
end;
outnl (zout);
end;

procedure alarm (text: alfa);
begin
outtext (zout, '*** error: #');
outtext (zout, text);
outnl (zout);
exception (0);
end;

procedure clean_pool (var poo: pool 1);
var msg: reference;
begin
while openpool (poo) do
begin
alloc (msg, poo, mainsem^);
case msg^.u4 of
empty_buf: return_full  (msg, false);
full_buf : return_empty (msg, false);
end;
end;
end;

procedure clean_sem (sem: ^ semaphore);
var
msg : reference;
begin
sensesem (msg, sem^);
while not nil(msg) do
begin
release (msg);
sensesem (msg, sem^);
end;
end;

procedure kill_all (from, upto: integer);
var
msg    : reference;
dummy  : integer;
p      : ports_range;
begin
if upto > max_process then upto := max_process;
if (from > 0) and (from <= max_process) then
repeat
with children(from) do
if not nil(child) then
begin
remove(child);
for p := 1 to max_ports do
with ports(p) do
if proc_no = from then
begin
clean_sem (insem);
clean_sem (outsem);
end;
end;
from := from + 1;
until from > upto;

<* provoke cleanup of buffers *>
dummy := reservech (msg, 0, 0);

clean_pool (small_pool);
clean_pool (large_pool);

end;  <* kill_all *>

procedure break_all (cause, from, upto: integer);
begin
if upto > max_process then upto := max_process;
if (from > 0) and (from <= max_process) then
repeat
with children(from) do
if not nil(child) then break (child, cause);
from := from + 1;
until from > upto;
end;

procedure run_all (from, upto: integer);
var
res : integer;
name_n : alfa;
i, n   : integer;
begin
kill_all (from, upto);
if upto > max_process then upto := max_process;
if (from > 0) and (from <= max_process) then
repeat
with children(from), pdescr(from), code_descr(kind) do
begin
name_n := name;
i := alfalength;
n := inc;
repeat
name_n(i) := chr (n mod 10 + ord('0'));
n := n div 10;
i := i - 1;
until n = 0;
repeat
name_n(i) := '_';
i := i-1;
until name_n(i) <> sp;
case kind of
fpa_kind   : res := create (name_n, fpa   (from, pdescr, sems), child, size);
hdlc_kind  : res := create (name_n, hdlc  (from, pdescr, sems), child, size);
gci_kind   : res := create (name_n, gci   (from, pdescr, sems), child, size);
cons_kind  : res := create (name_n, cons  (from, pdescr, sems), child, size);
ontel_kind : res := create (name_n, ontel (from, pdescr, sems), child, size);
bbm_kind   : res := create (name_n, bbm   (from, pdescr, sems), child, size);
server_kind: res := create (name_n, server(from, pdescr, sems), child, size);
end;
if res <> 0 then alarm ('create#');
start (child, prio);
end;
from := from + 1;
until from > upto;
end;

procedure test_all (t, from, upto: integer);
begin
if upto > max_process then upto := max_process;
if (from > -1) and (from <= max_process) then
repeat
with pdescr(from) do
testval := t;
from := from + 1;
until from > upto;
end;

procedure print_portx (from, upto: integer);
begin
if upto > max_port then upto := max_port;
if (from > 0) and (from <= max_port) then
begin
outtext (zout, 'p  port #');
outtext (zout, 'poll  st.#');
outtext (zout, '   busy#');
outnl (zout);
repeat
outinteger (zout, from, 2);
outchar (zout, ':');
with portx(from) do
begin
outinteger (zout, pno, 4);
outinteger (zout, poll_time, 5);
if deliver_status or busy then
begin
if deliver_status then outtext (zout, ' true #')
else                   outtext (zout, ' false#');
if busy then outtext (zout, ' true#')
else         outtext (zout, ' false#');
end;
end;
outnl (zout);
from := from + 1;
until from > upto;
end;
end;

procedure print_ports (from, upto: integer);
begin
if upto > max_ports then upto := max_ports;
if (from > 0) and (from <= max_ports) then
begin
outtext (zout, ' p  outs max#'); outtext (zout, ' inp outp#');
outnl (zout);
repeat
outinteger (zout, from, 2);
outchar (zout, ':');
with ports(from) do
begin
outinteger (zout, outstandings - 1, 4);
outinteger (zout, max_outs - 1, 4);
outinteger (zout, proc_no, 4);
if insem <> outsem then
outinteger (zout, proc_no+1, 4);
if last_status <> result_ok then
outtext (zout, ' down#');
end;
outnl (zout);
from := from + 1;
until from > upto;
end;
end;

procedure print_proc (from, upto: integer);
begin
if upto > max_process then upto := max_process;
if (from > 0) and (from <= max_process) then
begin
outtext (zout, ' i  name    #');
outtext (zout, '     #');
outtext (zout, ' inc sem tst#');
outtext (zout, ' state#');
outnl (zout);
repeat
outinteger (zout, from, 2);
outchar (zout, ':');  outchar (zout, sp);

with pdescr(from), children(from) do
begin
outtext (zout, code_descr(kind).name);
outinteger (zout, inc, 4);
outinteger (zout, sem, 4);
outinteger (zout, testval, 4);
if nil(child) then outtext (zout, ' removed#');
end;
outnl (zout);
from := from + 1;
until from > upto;
end;
end;

procedure write_all (from, upto: integer);
begin
if upto > max_sem then upto := max_sem;
if (from > -1) and (from <= max_sem) then
begin
outtext (zout, 'sem  state#');
outnl (zout);
repeat
outinteger(zout, from, 3);
if open(sems(from)) then     outtext (zout, '  open#')
else
if locked(sems(from)) then outtext (zout, '  locked#')
else                       outtext (zout, '  passive#');
outnl (zout);
from := from + 1;
until from > upto;
end;
end;

procedure print_cap (from, upto: integer);
var
p    : port_range;
serv : serv_range;
dist : dist_range;
begin
if (upto <= 0) or (upto > max_port) then upto := max_port;
if from <= 0 then from := 1;
if from <= max_port then
for p := from to upto do
begin
outtext (zout, 'port no =#');
outinteger (zout, p, 2);
outtext (zout, ', outstand.=#');
with portx(p), ports(pno) do
outinteger (zout, outstandings, 2);
outnl (zout);
for serv := 1 to max_serv do
begin
outtext (zout, 'service #');
outchar (zout, chr(64 + serv));
outchar (zout, ',');
outinteger (zout, dists(serv).min_dist(p),2);
outchar (zout, ':');
for dist := 0 to max_dist do
if capability (p, serv, dist) then
outtext (zout, ' * #')
else
outtext (zout, ' . #');
outnl (zout);
end;
end;
end;

procedure conversation;
var
ch    : char;
val,
from,
upto  : integer;

procedure read_from_to;
begin
ininteger (zin, from); ininteger (zin, upto);
end;

procedure read_val_from_to;
begin
ininteger (zin, val); read_from_to;
end;

procedure print_f_t (text: alfa);
begin
outtext (zout, text);
outtext (zout, ' <from> <to>#');
outnl (zout);
end;

procedure print_v_f_t (text: alfa);
begin
outtext (zout, text);
outtext (zout, ' <value>#');
outtext (zout, ' <from> <to>#');
outnl (zout);
end;

begin
opanswer (msg, zin); opwait (zin, in_pool);

repeat <* next command *>

repeat inchar (zin, ch) until ch <> sp;

case ch of
'r':  <* run <from> <to> *>
begin
read_from_to; run_all (from, upto);
end;
'b':  <* break <val> <from> <to> *>
begin
read_val_from_to; break_all (val, from, upto);
end;
'k':  <* kill <from> <to> *>
begin
read_from_to; kill_all (from, upto);
end;
't':  <* test <val> <from> <to> *>
begin
read_val_from_to; test_all (val, from, upto);
end;
'x': <* print portx <from> <to> *>
begin
read_from_to;  print_portx (from, upto);
end;
'p': <* print procs <from> <to> *>
begin
read_from_to;  print_ports (from, upto);
end;
'i': <* print pdescr (incarnations) <from> <to> *>
begin
read_from_to;  print_proc (from, upto);
end;
'w':  <* write <from> <to> *>
begin
read_from_to; write_all (from, upto);
end;
'c':  <* capability <from> <to> *>
begin
read_from_to;  print_cap (from, upto);
end;
'd':  <* date <hour> <min> <sec> *>
begin
read_val_from_to;
if (val >= 0) and (val < 24) and
(from >= 0) and (from < 60) and
(upto >= 0) and (upto < 60) then
if val + from + upto > 0 then
with local_time do
begin
hours := val;
seconds := from * 60 + upto;
end;
outtime (zout, local_time);
outnl (zout);
end;
'?',
'h': <* help *>
begin
print_f_t   ('r: run#');
print_v_f_t ('b: break#');
print_f_t   ('k: kill#');
print_v_f_t ('t: test#');
print_f_t   ('x: listportx#');
print_f_t   ('p: listports#');
print_f_t   ('i: listpdescr#');
print_f_t   ('w: listsems#');
print_f_t   ('c: list capab.#');
outtext (zout, 'd: date #');
outtext (zout, '<hour> <min>#');
outtext (zout, ' <sec>#');
outnl (zout);
end;
otherwise <* blind command *>
end;

repeat inchar (zin, ch) until (ch=nl) or (ch=';');

until ch=nl;

opin (zin);
end; <* conversation *>

procedure initialize;
var
i, p, inc_no, port_no, sem_no: integer;
serv : serv_range;
dist : dist_range;

procedure def_code (k: prockinds; var p: process_descriptor;
n: alfa; s: integer; pr: minpriority..maxpriority);
var
dummy : integer;
begin
with code_descr(k) do
begin
name := n;
size := s;
prio := pr;
inc_count := 0;
end;
dummy := link (n, p);
end;

procedure def_inc (k: prockinds);
begin
with pdescr(inc_no) do
with code_descr(k) do
begin
kind    := k;
inc_count := inc_count + 1;
inc     := inc_count;
testval := 0;
sem     := sem_no;
end;
inc_no := inc_no + 1;
end;

procedure def_port (insems: integer; max: integer; erlang: boolean);
begin
with ports (port_no) do
begin
insem        := ref (sems(sem_no));
outstandings := 1;       <* note: offset by one... *>
max_outs     := max + 1; <* note: offset by one... *>
last_status  := result_ok;
proc_no      := inc_no - 1;
sem_no       := sem_no + insems;
if erlang then
begin
pp := p;
with portx(p) do
begin
deliver_status := false;
busy           := false;
pno            := port_no;
poll_time      := poll_period;
end;
p := p + 1;
end
else
pp := 0;
end;
end;

procedure out_port (outsems: integer);
begin
with ports (port_no) do
if outsems <> 0 then
outsem := ref (sems(sem_no))
else
outsem := insem;
sem_no := sem_no + outsems;
port_no := port_no + 1;
end;

procedure alloc_bufs (n: integer; var p: pool 1);
var
msg   : reference;
i     : integer;
begin
for i := 1 to n do
begin
if not openpool (p) then alarm ('no bufs#');
alloc (msg, p, mainsem^);
lock msg as buf: stdpart do
with buf, header do
begin
receiver := port_no;
first    := first_buffer;
end;
msg^.u3 := 0;
return_empty (msg, false);
end;
end;

procedure def_end;
begin
if p       <> max_port    + 1 then alarm ('max_port#');
if inc_no  <> max_process + 1 then alarm ('max_process#');
if port_no <> max_ports   + 1 then alarm ('max_ports#');
if sem_no  <> max_sem     + 1 then alarm ('max_sem#');

if openpool (small_pool)       then alarm ('smallpool#');
if openpool (large_pool)       then alarm ('largepool#');
end;

begin <* body of initialize *>

mainsem := ref (sems(0));
definetimer (true);
openopzone (zin , semvect(operatorsem), mainsem,        1, in_pool,  1,7,0,0);
openopzone (zout, semvect(operatorsem), ref(zout.free), no_of_outbufs, out_pool, 2,7,0,0);
opin (zin);

outtext (zout, 'welcome...#');
outnl (zout);

def_code (fpa_kind   , fpa    , fpa_name    , fpa_size    , fpa_prio);
def_code (hdlc_kind  , hdlc   , hdlc_name   , hdlc_size   , hdlc_prio);
def_code (gci_kind   , gci    , gci_name    , gci_size    , gci_prio);
def_code (cons_kind  , cons   , cons_name   , cons_size   , cons_prio);
def_code (ontel_kind , ontel  , ontel_name  , ontel_size  , ontel_prio);
def_code (bbm_kind   , bbm    , bbm_name    , bbm_size    , bbm_prio);
def_code (server_kind, server , server_name , server_size , server_prio);

for p := 1 to max_port do
for serv := 1 to max_serv do
for dist := 0 to max_dist do
capability (p, serv, dist) := false;

for i := 1 to max_serv do
with dists(i) do
begin
last_p := max_port;
for p := 1 to max_port do min_dist(p) := top_dist + 1;
end;

p       := 1;
inc_no  := 1;
port_no := 1;
sem_no  := 1;

for i := 1 to no_of_fpa do
begin
def_inc (fpa_kind); def_port (1, outbufs_fpa, true); alloc_bufs (inbufs_fpa, large_pool);
def_inc (fpa_kind); out_port (1);
end;

for i := 1 to no_of_hdlc do
begin
def_inc (hdlc_kind); def_port (1, outbufs_hdlc, true); alloc_bufs (inbufs_hdlc, large_pool);
def_inc (hdlc_kind); out_port (1);
end;

for i := 1 to no_of_gci do
begin
def_inc (gci_kind); def_port (1, outbufs_gci, true); alloc_bufs (inbufs_gci, large_pool);
def_inc (gci_kind); out_port (1);
end;

for i := 1 to no_of_cons do
begin
def_inc (cons_kind); def_port (1, 1, false); alloc_bufs (inbufs_cons, small_pool);
out_port (1);
end;

for i := 1 to no_of_ontel do
begin
def_inc (ontel_kind); def_port (1, 1, false); alloc_bufs (inbufs_ontel, small_pool);
out_port (1);
end;

for i := 1 to no_of_bbm do
begin
def_inc (bbm_kind); def_port (1, outbufs_bbm, true); alloc_bufs (inbufs_bbm, large_pool);
out_port (0);
end;

for i := 1 to no_of_server do
begin
def_inc (server_kind); def_port (1, outbufs_server, true); alloc_bufs (inbufs_server, large_pool);
out_port (1);
end;

def_end;

test_all (0, 0, 0);  <* set test-pattern for router itself *>
run_all (1, max_process);

end; <* initialize *>

procedure deliver (var m: reference; p: integer);
begin
m^.u3 := p;
if p = 0 then
return_empty (msg, true)
else
begin
if test then testput ('sent#', m);
with ports(p) do
begin
signal (m, outsem^);
outstandings := outstandings + 1;
if pp <> 0 then
with portx(pp) do
poll_time := poll_period;
end;
end;
end;

function get_capability (pno: ports_range): boolean;
var
new_cap : boolean;
min     : integer;
p       : port_range;
serv    : serv_range;
dist    : dist_range;
begin
get_capability := false;
with ports(pno) do p := pp;
lock msg as data: cap_buffer do
for serv := 1 to max_serv do
begin
min := top_dist;
for dist := 0 to max_dist do
begin
new_cap := data.cap(serv, dist) = 1;
if capability (p, serv, dist) <> new_cap then
begin <* change *>
capability (p, serv, dist) := new_cap;
get_capability := true;
end;
if new_cap then
if min = top_dist then min := dist;
end;
with dists(serv) do
min_dist (p) := min + 1;
end;
return_empty (msg, true);
end; <* get_capability *>

function clear_capability (p: port_range): boolean;
var
serv: serv_range;
dist: dist_range;
begin
clear_capability := false;
for serv := 1 to max_serv do
begin
for dist := 0 to max_dist do
begin
if capability (p, serv, dist) then
clear_capability := true;
capability (p, serv, dist) := false;
end;
with dists(serv) do
min_dist (p) := top_dist + 1;
end;
end;

procedure send_capabilities;
var
i, p   : port_range;
serv   : serv_range;
dist   : dist_range;
sum    : boolean;
msg    : reference;
begin
for p := 1 to max_port do
with portx(p), ports(pno), children(proc_no) do
if deliver_status then
if not busy then
if not nil (child) then
if openpool (status_pool) then
begin
alloc (msg, status_pool, mainsem^);
deliver_status := false;
busy           := true;
lock msg as buf: cap_buffer do
with buf, cap_head, header do
begin
first        := first_buffer;
last         := size_cap_buffer - 1;
routing_mode := inform;
receiver     := -pno;
cur          := 1;
addr(cur)    := pno;
for serv := 1 to max_serv do
for dist := 0 to max_dist do
begin
sum := false;
if dist <> 0 then
for i := 1 to max_port do
if i <> p then
sum := sum or capability (i, serv, dist - 1);
cap(serv, dist) := ord(sum);
end;
end;
msg^.u1 := output_msg;
msg^.u2 := result_answer;
msg^.u4 := full_buf;
deliver (msg, pno);
end;
end;

function find_port (serv: serv_range): 0..max_ports;
var
port_1   , port_2    : integer;
mincost_1, mincost_2 : integer;
cost                 : integer;
i, p                 : integer;
begin
port_1 := 0;  mincost_1 := maxint;
port_2 := 0;  mincost_2 := maxint;

with dists(serv) do
begin
p := last_p;
for i := 1 to max_port do
begin
p := p mod max_port + 1;
if min_dist(p) <= top_dist then
with portx(p), ports(pno) do
begin
cost := min_dist(p) * outstandings;
if outstandings <= max_outs then
begin
if cost < mincost_1 then
begin
port_1 := p; mincost_1 := cost;
end;
end
else
begin
if cost < mincost_2 then
begin
port_2 := p; mincost_2 := cost;
end;
end;
end;
end;
if port_1 = 0 then port_1 := port_2;
if port_1 <> 0 then
begin
last_p := port_1;
port_1 := portx(port_1).pno;
end;
end;
find_port := port_1;
end;

procedure status_change (p: ports_range; new_status: byte);
var
i : port_range;
begin
with ports(p) do
begin
last_status := new_status;
if pp <> 0 then
if new_status = result_ok then
with portx(pp) do
begin
deliver_status := true;
send_capabilities;
end
else
if clear_capability (pp) then
begin
for i := 1 to max_port do
if i <> pp then
with portx (i) do
deliver_status := true;
send_capabilities;
end;
end;
outtime (zout, local_time);
outtext (zout, ' *** port #');
outinteger (zout, p, 2);
if new_status = result_ok then
outtext (zout, ' comming up#')
else
outtext (zout, ' gone down#');
outnl (zout);
end;

var
rec  : integer;
p    : integer;
rout : routing_modes;

begin <* main program of router *>
initialize;
own.timer := poll_accuracy;
with pdescr (0) do
repeat <* forever *>

case waitst (msg, mainsem^) of

a_delay:
begin <* time for updating poll_timers *>
own.timer := poll_accuracy;
with local_time do
begin
seconds := seconds + poll_accuracy;
if seconds >= 60*60 then
begin
seconds := seconds - 60*60;
hours   := hours + 1;
if hours >= 24 then
hours := 0;
end;
end;
for p := 1 to max_port do
with portx(p) do
if poll_time > 0 then
begin
poll_time := poll_time - poll_accuracy;
if poll_time <= 0 then
deliver_status := true;
end;
send_capabilities;
end;

a_semaphore:
begin
test := testval <> 0;
if ownertest (in_pool, msg) then conversation
else
case msg^.u4 of
empty_buf:
begin
if test then testput ('empty#', msg);
if msg^.u3 <> 0 then
begin
with ports(msg^.u3) do
begin
outstandings := outstandings - 1;
if last_status <> msg^.u2 then
status_change (msg^.u3, msg^.u2);
end;
msg^.u3 := 0;
end;
lock msg as buf: stdpart do
begin
buf.last := msg^.size * 2 - 1;
rec := buf.receiver;
end;
if rec < 0 then
begin <* inform-buffer has returned, use it again *>
with ports(-rec), portx(pp) do
busy := false;
release (msg);
send_capabilities;
end
else
signal (msg, ports(rec).insem^);
end;
full_buf:
if msg^.u3 <> 0 then
return_empty (msg, false)  <* driver was removed, and message returned *>
else
begin <* real message to the router *>
if test then testput ('got #', msg);
lock msg as buf: stdpart do
with buf, header do
begin
rec  := receiver;
with ports(rec) do
if last_status <> msg^.u2 then
status_change (rec, msg^.u2);
if msg^.u2 = result_ok then
begin
rout := routing_mode;
case rout of
reply        : cur := cur - 2;
next_request : cur := cur + 2;
new_request  :
begin
cur := cur + 2;
addr (cur-1) := rec;
addr (cur)   := find_port (service_kind);
end;
inform       : <* empty *>
end;
if cur > max_dist*2 then p := 0
else p := addr(cur);
end
else
begin <* bad status *>
rout := reply;
p    := 0;
end;
end; <* lock *>
case rout of
reply,
next_request,
new_request: deliver (msg, p);
inform:
begin
if get_capability (rec) then
begin
for p := 1 to max_port do
with portx(p), ports(pno) do
deliver_status := true;
send_capabilities;
end;
end;
end; <* case *>

end; <* full buf *>

end; <* case buffer-type *>
end;

end; <* case timeout-or-message *>

until doomsday;

end; <* router *>

<* ************************************************** *>

process s (var sem_vector: system_vector);

type
adamtype = record
name1 : alfa;
name2 : alfa;
aux1  : integer;
end;
opbuffer = record
first,last,next : integer;
name : alfa;
go      : array (16..17) of char;
databuf : array (20..97) of char;
end;

var
msg      : reference;
mainsem  : semaphore;
p        : pool 1 of opbuffer;
re_run   : boolean;

procedure adam (fct: byte; i: integer);
begin
msg^.u1 := fct;
lock msg as buf: adamtype do
with buf do
begin
name1 := 'router';
name2 := 'r ';
aux1  := i;
end;
signal (msg, sem_vector(adamsem)^);
wait (msg, mainsem);
end;

begin
(*$5 10 512*)  <* default create-size := 512 words *>
alloc (msg, p, mainsem);

adam (1 <* link*>   , 0-0-0);
repeat
adam (2 <* create *>, 2000);
adam (3 <* start *> , 0);

repeat

msg^.u1 := 1;
lock msg as buf: opbuffer do
with buf do
begin
first := 18;
last  := 97;
name  := 's ';
go    := '**';
end;
signal (msg, sem_vector (operatorsem)^);
wait (msg, mainsem);

lock msg as buf: opbuffer do
with buf do
re_run := go = 'go';

until re_run;

adam (5 <* remove *>, 0-0-0);

until false;
end;
.
«eof»