|
DataMuseum.dkPresents historical artifacts from the history of: RC3500 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC3500 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 29952 (0x7500)
Types: TextFileVerbose
Names: »tssupjob«
└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system
└─⟦72244f0ef⟧
└─⟦this⟧ »tssupjob«
job hj 3 200 time 11 0 area 10 size 100000
( message ts supervisor
source = copy 25.1
tssuplst = set 1 disc1
tssuplst = indent source mark lc
listc = cross tssuplst
o errors
message ts supervisor
pascal80 spacing.1200 codesize.1200 alarmenv source
o c
lookup pass6code
if ok.yes
( tssupbin = set 1 disc1
tssupbin = move pass6code
scope user tssupbin
; if ok.yes
; newjob linktssjob
)
tssuplst = copy listc errors
scope user tssuplst
convert errors
finis
)
\f
(*----------------------------------------------------*)
(* *)
(* ts supervisor *)
(* *)
(*----------------------------------------------------*)
process tssupervisor (
opsem: sempointer; (* allocator, operator *)
var sem : !ts_pointer_vector (* ts semaphores *)
);
const
version= "vers 3.06 /";
(*---------------------- externals -------------------------------*)
process timout ( opsem: sempointer;
var tim: !ts_pointer; t, m: integer );
external;
process tsconnector ( opsem: sempointer;
var tss, dc, nc, lam, tim, com : !sempointer;
var net, s1, s2, s3, s4: !ts_pointer );
external;
process at_handler ( opsem: sempointer;
var dca, tsa : macroaddr;
var sem : !ts_pointer_vector );
external;
process vc_handler ( opsem: sempointer;
var dca, tsa : macroaddr;
var sem : !ts_pointer_vector );
external;
process lam ( opsem: sempointer;
pu, level: integer;
var main_sem: !ts_pointer
);
external;
\f
const
maxroute = 12; (* for u3 routing *)
type (*----------------- options ------------------------------*)
grouptable = array (func_grp) of integer;
modulref = ( netc, vch, ath, traffic, nc, dc, tss, dummy, empty );
modulident = array (netc..ath) of byte;
modultable = array (modulref) of integer;
modulstate = array (modulref) of boolean;
modulroute = array (0..maxroute) of modulref;
leveltab = array (0..max_lam+1) of byte;
const (*-------------- options -------------------------------*)
traffic_id = 24; (* for time_out *)
nc_ident = 25;
dc_ident = 26;
microadr = modultable ( netc_mic_addr, vch_mic_addr, ath_mic_addr,
traffic_id, nc_ident, dc_ident, 0, 0, 0 );
book_id = modulident(1,2,3);
interval = modultable(tss_netc_time,tss_vch_time,tss_ath_time,
tss_nc_ltime,tss_nc_stime,tss_dc_stime,-1,-1,-1);
from = modulroute(tss,tss,netc,netc,ath,ath,4***vch,3***tss);
u3val= modulident(netc_route1, netc_route, netc_route);
\f
(*-------------------- op codes ---------------------------------*)
log_code = #h00; (* 0.0 *)
nb_code = #h10; (* 1.0 *)
refuse_code= #h12; (* 1.2 *)
dc_down = #h20; (* 2.0 *)
dc_up = #h21; (* 2.1 *)
nc_down = #h22; (* 2.2 *)
nc_up = #h23; (* 2.3 *)
ts_down = #h24; (* 2.4 *)
ts_up = #h25; (* 2.5 *)
vc_down = #h26; (* 2.6 *)
vc_up = #h27; (* 2.7 *)
at_down = #h28; (* 2.8 *)
at_up = #h29; (* 2.9 *)
newlam_code= #h9c; (* 9.12 *)
anslam_code= #h9d; (* 9.13 *)
new_addr_code= #hb0; (* 11.0 *)
new_ans_code = #hb1; (* 11.1 *)
nodetest_code= #hc0; (* 12.0 *)
nodeans_code= #hc1; (* 12.1 *)
input_code = #hc5; (* 12.5 *)
contest_code= #hc8; (* 12.8 *)
conansw_code= #hc9; (* 12.9 *)
(*---------------------- other constants -------------------------*)
maxno = 2*2*2*2; (* 4 bits *)
read_clock = 2;
write = 2;
by_father = 47; (* break parameter *)
forever = false;
label_length = label_size; (* size in words, length in bytes *)
testlength = label_length+2; (* length of testshape *)
free_sem_no = com_pool; (* free listen buffers are here *)
queue = tssup_int1;
done = tssup_int2;
supp_sem_no = tssup_int3; (* log buffers *)
\f
(*------------------------ message formats --------------------------*)
type
testshape = packed record (* for nodetest *)
head: alarmlabel;
data: array (1..5) of integer
end;
flawshape = packed record (* for 1.0 and 1.2 *)
head : alarmlabel;
data : alarmlabel
end;
note = packed record (* for broadcast *)
head: alarmlabel;
component: alarmnetaddr;
count: integer
end;
lammess = packed record (* for new lam *)
head: alarmlabel;
lam_num,
lam_level : integer
end;
\f
(*----------------------------------------------------------
variables section
----------------------------------------------------------*)
var
here : alarmnetaddr; (* my own addr updated by 11.00 *)
debug : integer:= 1; (* controls testoutput *)
cv, (* value of create *)
lost, (* num of loast messages *)
quelen, (* actual queuelength *)
maxqueue, (* max queuelength *)
queput, (* number of queings *)
nodetest_cnt : integer:=0; (* numb of nodetests send *)
running : modulstate := modulstate(5***true, false, 3***true);
ms1, (* a free buffer *)
ms : reference; (* mess arrived *)
console : zone; (**debug for output **)
(*----------------- for ts modules ----------------------*)
no : array (netc..ath) of integer;
suppool: pool no_req_supp of array (1..size_supp) of integer;
lamname : alfa := "lam00 ";
leveltable : leveltab := leveltab((max_lam+2) *** 0);
proc_lam : array(0..max_lam) of shadow;
proc_timeout,
proc_netcon,
proc_vchan,
proc_athan : shadow;
(*----------------- for timing ---------------------------*)
nc_long, nc_short, (* timeouts from 11.0 *)
cnt : integer;
netaddr: array (nc..dc) of alarmnetaddr;
module: modulref;
t_out, (* module timeouts *)
t_up : array (netc..dc) of reference; (* book and update *)
u_pool: pool no_tss_tim of updates;
t_pool: pool no_tss_tim of timers;
clockpool: pool 1 of ts_time; (**demo **)
clock_msg: reference;
(*---------------- end of data section -----------------------*)
\f
<*q q*>
(*------------------------ display -----------------------------*)
procedure display ( var msg: reference); (* write contents *)
const
lastword = 16;
type
abuf = record w: array(1..lastword) of integer end;
var
i,m : integer;
begin
lock msg as buf: abuf do
with buf do
begin
m:= (w(1)+1) div 2;
if m<7 then m:= 7;
if m>lastword then m:=lastword;
for i:= 1 to m do testout ( console," data ", w(i));
end;
end;
<*q q*>
\f
(*------------------------ gettime -----------------------------*)
function gettime : ts_time;
type
clock_form = record time: ts_time end;
begin
signal ( clock_msg, sem(timeout_sem_no).s^);
wait ( clock_msg, sem(done).w^);
lock clock_msg as buf : clock_form do gettime:= buf.time
end;
\f
(*--------------------- odd ------------------------------------*)
function odd ( number: integer ) : boolean;
begin
odd:= number mod 2 = 1
end;
\f
(*---------------------- send up ---------------------------*)
procedure send_up ( (* signals to net-con *)
var msg : reference; (* mess to be send *)
operation : byte ); (* op code *)
begin
msg^.u1:= write;
msg^.u3:= tss_route;
msg^.u4:= operation;
if ( debug mod 16 ) >= 8 then display ( msg);
signal ( msg, sem(netc_sem_no).s^ );
end;
\f
(*------------------------ to queue ------------------------------*)
procedure to_queue ( var msg : reference );
begin
count ( queput);
quelen:= quelen+1;
if quelen > maxqueue then maxqueue:= quelen;
signal ( msg, sem(queue).s^)
end;
\f
<* -- only used in nc
(*---------------------- nodetest --------------------------*)
procedure nodetest (
node : modulref ); (* node to be tested *)
var
try : reference; (* node test message *)
begin
sensesem ( try, sem(free_sem_no).w^);
if not nil ( try) then
begin
nodetest_cnt:= nodetest_cnt+1;
lock try as buf : testshape do
begin
with buf, head do
begin
no_of_by:= testlength;
rec:= netaddr(node);
send:= here;
result:= 0;
ts_add:= gettime;
end;
buf.data(1):= nodetest_cnt;
end;
send_up ( try, nodetest_code);
timerupdate ( t_up(node), interval(node),
sem(timeout_sem_no).s^, sem(done).w^ )
end
end;
*>
\f
(*---------------------- broadcast -------------------------*)
procedure broadcast ( (* send a broadcast message *)
var msg : reference; (* used for message *)
element : alarmnetaddr; (* unit in question *)
cnt : integer; (* counter in datapart *)
operation: byte; (* op code *)
recip : modulref); (* reveiver *)
const
broadlength = label_length+6;
begin
lock msg as buf : note do
with buf, head do
begin
no_of_by:= broadlength;
if recip = netc then rec:= netaddr(nc) else
begin
rec:= here;
rec.micro:= microadr(recip)
end;
send:= here;
result:= operation mod 2;
op_code:= operation;
ts_add:= gettime;
component:= element;
count:= cnt
end;
msg^.u1:= write;
if recip = netc then msg^.u3:= tss_route else msg^.u3:= netc_route1;
msg^.u4:= operation;
signal ( msg, sem(no(recip)).s^ )
(* end *)
end;
\f
(*--------------------- start timeout -------------------------*)
procedure start_timeout;
begin
if nil ( proc_timeout ) then
begin
cv:= link ("timout ", timout );
cv:= create ( "timout ",
timout ( opsem,
sem(timeout_sem_no), time_out_unit, timeout_l),
proc_timeout, tim_size);
if cv = 0 then start ( proc_timeout, tim_pri)
else
begin
testout ( console,"timeoutstart", cv);
cv:= unlink ( timout)
end
end
end;
\f
(*------------------- start lam --------------------------------*)
procedure start_lam ( nr, level: byte );
begin
if nil ( proc_lam(nr)) then
begin
lamname(4):= chr ( ord("0") + nr div 10);
lamname(5):= chr ( ord("0") + nr mod 10);
cv:= create ( lamname,
lam ( opsem, pu_no, level,
sem(lam_sem_no+nr) ),
proc_lam(nr), lam_size);
if cv = 0 then
begin
start ( proc_lam(nr), lam_pri);
leveltable(nr):= level
end
else testout ( console,"lam start ", cv);
end;
end;
\f
(*------------------- start netcon ----------------------------*)
procedure start_netcon;
begin
if nil ( proc_netcon ) then
begin
(*
cv:= link ("netconnector", netconnector );
*)
cv:= link ("tsconnector ", tsconnector);
cv:= create ( "tsconnector ",
tsconnector (
opsem,
sem(tssup_sem_no).s,
sem(dc_sem_no).s,
sem(nc_sem_no).s,
sem(lam_sem_no).s,
sem(timeout_sem_no).s,
sem(com_pool).w,
sem(netc_sem_no),
sem(net_int1), sem(net_int2), sem(net_int3),
sem(net_int4)
),
proc_netcon, netc_size);
if cv = 0 then start ( proc_netcon, netc_pri)
else
begin
testout ( console,"netcon start", cv );
cv:= unlink ( tsconnector)
end;
end
end;
\f
(*----------------------- start vchandler ---------------------*)
procedure start_vchan;
begin
if nil ( proc_vchan ) then
begin
cv:= link ( "vc_handler ", vc_handler);
cv:= create ( "vc_handler ",
vc_handler ( opsem,
netaddr(dc).macro,
here.macro,
sem
),
proc_vchan, vch_size);
if cv = 0 then start ( proc_vchan, vch_pri)
else
begin
testout ( console, "vc_han start", cv);
cv:= unlink ( vc_handler)
end
end
end;
\f
(*------------------------ start athandler -----------------------*)
procedure start_athan;
begin
if nil ( proc_athan ) then
begin
cv:= link ( "at_handler ", at_handler);
cv:= create ( "at_handler ",
at_handler ( opsem,
netaddr(dc).macro,
here.macro,
sem
),
proc_athan, ath_size);
if cv = 0 then start ( proc_athan, ath_pri )
else
begin
testout ( console, "at_han start", cv);
cv:= unlink ( at_handler )
end
end
end;
\f
(*---------------------- module timeout --------------------*)
procedure module_timeout (
var msg : reference; (* received mess *)
var res : modulref); (* becomes dummy *)
var
cnt,
who : integer;
elem : alarmnetaddr;
bm1, bm2 : reference; (* 2 empty buffers *)
begin
sensesem ( bm1, sem(free_sem_no).w^);
if not nil ( bm1) then
sensesem ( bm2, sem(free_sem_no).w^);
if nil ( bm2 ) then
begin (* try later *)
if not nil ( bm1) then return ( bm1);
to_queue ( msg)
end else
begin
lock msg as buf : timers do who:= buf.object;
elem.macro:= here.macro;
elem.micro:= who;
case who of
<*
netc_mic_addr:
begin (* net-connector stopped, so remove it
and start a new one *)
break ( proc_netcon, by_father);
unlink ( tsconnector);
remove ( proc_netcon);
(* get released buffers. *)
start_netcon;
nodetest ( nc);
timerbook ( t_up(netc), msg, interval(netc), who,
sem(timeout_sem_no).s^, sem(done).w^)
end;
*>
ath_mic_addr:
begin
if running(ath) then
begin
broadcast ( bm1, elem, 0, at_down, netc);
broadcast ( bm2, elem, 0, at_down, vch )
end;
running(ath):= false;
timerbook ( t_up(ath), msg, -1, who,
sem(timeout_sem_no).s^, sem(done).w^)
end;
vch_mic_addr:
begin
if running(vch) then
begin
broadcast ( bm1, elem, 0, vc_down, netc);
broadcast ( bm2, elem, 0, vc_down, ath );
running(vch):= false
end;
timerbook ( t_up(vch), msg, -1, who,
sem(timeout_sem_no).s^, sem(done).w^)
end;
<*
traffic_id:
begin (* nc or paxnet stopped *)
nodetest ( nc);
timerbook ( t_up(traffic), msg, -1, who,
sem(timeout_sem_no).s^, sem(done).w^)
end;
*>
nc_ident:
begin (* nc down *)
if running(nc) then
begin
broadcast ( bm1, elem, 0, nc_down, ath);
broadcast ( bm2, elem, 0, nc_down, vch);
running(dc):= false;
running(nc):= false
end;
timerbook ( t_up(nc), msg, -1, who,
sem(timeout_sem_no).s^, sem(done).w^)
end;
<*
dc_ident:
begin (* dc down *)
if running(dc) then
begin
broadcast ( bm1, elem, dc_down, ath);
broadcast ( bm2, elem, dc_down, vch);
running(dc):= false
end;
timerbook ( t_up(dc), msg, -1, who,
sem(timeout_sem_no).s^, sem(done).w^);
end;
*>
otherwise
begin
return ( bm1);
return ( bm2)
end
end
end;
res:= dummy
end; (* of module timeout *)
\f
(*--------------------- route ---------------------------*)
function route (
microadr : integer (* addr of local module *)
) : modulref; (* the selected module *)
begin
if microadr >= at_addr_limit then route:= ath else
if microadr >= vc_addr_limit then route:= vch else
if microadr = vch_mic_addr then route:= vch else
if microadr = ath_mic_addr then route:= ath else
if microadr = netc_mic_addr then route:= netc else
if microadr = tss_mic_addr then route:= tss else
route:= dc
end;
\f
(*----------------------- waitlog ----------------------------------*)
procedure waitlog ( (* fetch a free logbuffer *)
var msg : reference ); (* a msg for log *)
begin
(* allocator may be used later ! *)
if open ( sem(supp_sem_no).w^) then
begin
wait ( msg, sem(supp_sem_no).w^ );
while msg^.u3 = dummy_route do
begin
return ( msg);
wait ( msg, sem(supp_sem_no).w^ )
end;
end
end;
\f
(*---------------------- make log --------------------------*)
procedure make_log ( var msg : reference );
(* makes a copy of msg.data and send to dc. *)
const
logleng = 2*size_supp - ( 2+label_length);
rawleng = 2*size_listen-2;
type
logshape = packed record
head : alarmlabel;
data : array (1..logleng) of byte;
end;
rawshape = packed record
bytes : integer;
rawdata : array (1..rawleng) of byte;
end;
var
cnt : 1..rawleng;
length : integer;
logm : reference;
begin
lock msg as head : alarmlabel do head.op_code:= msg^.u4;
(* if ( logmin <= msg^.u4) and ( msg^.u4 <= logmax ) then +++++++
begin -------------------------------------------------------*)
waitlog ( logm );
if nil ( logm) then to_queue ( msg) else
begin
if msg^.u4 = refuse_code then (* make copy 1.0 *)
begin
lock logm as copy: flawshape do
lock msg as buf: flawshape do
begin
copy:= buf;
copy.head.rec.macro:= netaddr(dc).macro;
copy.head.rec.micro:= dc_erh_mic_addr;
end;
send_up ( logm, nb_code)
end
else
begin
lock logm as log : logshape do
lock msg as buf : rawshape do
begin
length:= label_length;
if ( buf.bytes > label_length )
and ( buf.bytes <= rawleng )
and ( buf.bytes <= logleng ) then length:= buf.bytes;
with log, head do
begin
no_of_by:= label_length+length;
rec.macro:= netaddr(dc).macro;
rec.micro:= dc_log_mic_addr;
send:= here;
update:= insert_code;
ts_add:= gettime;
end;
for cnt:= 1 to length do log.data(cnt):= buf.rawdata(cnt);
end;
send_up ( logm, log_code)
end
end
(* end --------------------------------------- ++++++++++++++++*)
end;
\f
(*--------------------- refuse --------------------------*)
procedure refuse ( var msg : reference; cause : result_range );
(* send opcode 1.2 back *)
const
newleng = 2*label_length+2;
var
receiver : macroaddr;
who : integer;
begin
lock msg as buf : flawshape do
with buf do
begin
data:= head;
data.op_code:= msg^.u4;
with head do
begin
no_of_by:= newleng;
rec:= send;
receiver:= rec.macro;
who:= rec.micro;
send:= here;
result:= cause;
ts_add:= gettime
end
end;
if receiver <> here.macro then
send_up ( msg, refuse_code)
else
begin
if who < vc_addr_limit then msg^.u3:= netc_route1
else msg^.u3:= netc_route;
msg^.u4:= refuse_code;
case route ( who) of
ath: signal ( msg, sem(ath_sem_no).s^);
vch: signal ( msg, sem(vch_sem_no).s^);
otherwise
send_up ( msg, refuse_code)
end;
end;
end;
\f
(*---------------- downwards ----------------------------*)
procedure downwards (
var msg : reference; (* a msg from net *)
var modul : modulref); (* tells what to do later *)
var
receiver : macroaddr;
from : alarmnetaddr;
xmt_dc : 0..15;
who : integer;
begin
lock msg as head : alarmlabel do
with head do
begin
receiver:= rec.macro;
who := rec.micro;
xmt_dc := send.macro.dc_addr;
from := send;
end;
if ( debug mod 32 ) >= 16 then display ( msg);
if receiver <> here.macro then (* not for me *)
if msg^.u4 = refuse_code then modul:= empty else
begin
refuse ( msg, unknown_receiver);
modul:= dummy
end
else
begin (* addr ok *)
if (xmt_dc <> here.macro.dc_addr) and
( here.macro <> macroaddr(0,0,0) ) and
running(dc) then make_log ( msg );
if from = netaddr(dc) then running(dc):= true;
if nil ( msg) then modul:= dummy else
begin
modul:= route ( who );
if who < vc_addr_limit then msg^.u3:= netc_route1;
end
end
end; (* of downwards *)
\f
(*---------------- upwards -------------------------*)
procedure upwards (
var msg : reference; (* a msg from ath or vch *)
var modul : modulref); (* tells what to do later *)
var
receiver : macroaddr;
who : integer;
begin
lock msg as head : alarmlabel do
begin
head.ts_add:= gettime;
receiver:= head.rec.macro;
who:= head.rec.micro
end;
if receiver <> netaddr(dc).macro then (* log *)
if ( here.macro <> macroaddr(0,0,0) ) and
running(dc) then make_log ( msg );
if nil ( msg) then modul:= dummy else
begin
if receiver = here.macro then
begin
modul:= route ( who );
if modul < tss then
if who < vc_addr_limit then msg^.u3:= netc_route1
else msg^.u3:= netc_route
end
else modul:= netc
end
end;
\f
(*----------------------- rec broadcast ---------------------------*)
procedure rec_broadcast ( var msg : reference );
(* handle received broadcast *)
type
ncaddr = record
dcpart : 0..15;
ncpart : 0..63
end;
var
cnt : integer;
unit : alarmnetaddr;
own_dc, unit_dc : 0..15;
own_nc, unit_nc : ncaddr;
bm1, bm2 : reference;
begin
sensesem ( bm1, sem(free_sem_no).w^);
if nil ( bm1) then
begin (* try later *)
to_queue ( msg)
end else
begin
lock msg as buf: note do
with buf do
begin
unit:= component;
cnt := count
end;
own_dc:= here.macro.dc_addr;
own_nc.dcpart:= own_dc;
own_nc.ncpart:= here.macro.nc_addr;
unit_dc:= unit.macro.dc_addr;
unit_nc.dcpart:= unit_dc;
unit_nc.ncpart:= unit.macro.nc_addr;
case msg^.u4 of
dc_down: if unit_dc = own_dc then running(dc):= false;
dc_up: if unit_dc = own_dc then running(dc):= true;
nc_down: if unit_nc = own_nc then running(nc):= false;
nc_up: if unit_nc = own_nc then running(nc):= true
otherwise
end;
case msg^.u3 of
netc_route,
netc_route1: begin (* from net *)
testout ( console, "from net ", msg^.u3);
broadcast ( bm1, unit, cnt, msg^.u4, vch);
broadcast ( msg, unit, cnt, msg^.u4, ath)
end;
at_route,
at_route1: begin (* from at *)
testout ( console, "from at ", msg^.u3);
broadcast ( bm1, unit, cnt, msg^.u4, netc);
broadcast ( msg, unit, cnt, msg^.u4, vch)
end;
vca_route,
vca_route1,
vci_route,
vci_route1: begin (* from vc *)
testout ( console, "from vc ", msg^.u3);
broadcast ( bm1, unit, cnt, msg^.u4, netc);
broadcast ( msg, unit, cnt, msg^.u4, ath)
end
otherwise
begin
return ( bm1);
return ( msg)
end
end; (* case *)
end
end; (* of rec broadcast *)
\f
(*------------------------ new lam ---------------------------------*)
procedure new_lam ( var msg : reference );
(* start or check lam driver incarnation *)
const
top = max_lam+1;
var nr, level : integer;
index : 0..top;
begin
if msg^.u4 = newlam_code then
begin
(*q if debug >= 1 then testout ( console,"new lam ", msg^.u4); q*)
lock msg as buf: lammess do with buf, head do
begin
result:= rejected;
nr:= lam_num;
level:= lam_level;
index:= 0;
while leveltable(index) <> level do index:= index+1;
if update = start_code then (* start lam driver *)
begin
if index = top then start_lam ( nr, level);
if leveltable(nr) = level then result:= accepted;
end else
begin (* stop lam driver *)
if leveltable(nr) = level then
begin
remove ( proc_lam(nr));
leveltable(nr):= 0;
result:= accepted
end
end;
rec:= send;
send:= here;
ts_add:= gettime;
end;
send_up ( msg, anslam_code)
end else refuse ( msg, unknown_opcode)
end;
\f
(*----------------------- rec returned ----------------------------*)
procedure rec_returned ( var msg : reference );
(* handle op codes 1.0 1.2 *)
begin
(* not yet specified *)
if debug >= 1 then testout ( console, "returned ", msg^.u4);
if debug >= 1 then
lock msg as buf: flawshape do
with buf do
testout ( console, "orig op-code", data.op_code);
count ( lost);
return ( msg )
end;
\f
(*----------------------- tss var update ----------------------------*)
procedure var_update ( var msg : reference );
(* the buffer contains a new ts-macro-address *)
type
table = packed record
head : alarmlabel;
adr : macroaddr;
cn: integer
end;
begin
if msg^.u4 = new_addr_code then
begin
lock msg as buf : table do with buf, head do
begin
here.macro:= adr;
netaddr(dc).macro.dc_addr:= here.macro.dc_addr;
netaddr(nc).macro.dc_addr:= here.macro.dc_addr;
netaddr(nc).macro.nc_addr:= here.macro.nc_addr;
debug:= cn;
(* generate answer *)
rec:= send;
send:= here;
ts_add:= gettime;
result:= accepted;
end;
(*
if debug>=3 then display ( msg);
*)
running(dc):= true;
running(nc):= true;
send_up ( msg, new_ans_code);
end else refuse ( msg, unknown_opcode)
end; (* of table update *)
\f
(*----------------------- watch -----------------------------------*)
procedure watch ( var msg : reference );
(* nodetest received, so send node test answer *)
var
node : modulref;
node_up : byte;
begin
if msg^.u4 = nodetest_code then (* node test *)
begin
lock msg as buf : testshape do
with buf, head do
begin
rec:= send;
send:= here;
result:= accepted;
ts_add:= gettime;
data(2):= quelen;
data(3):= queput;
data(4):= maxqueue;
data(5):= lost;
end;
send_up ( msg, nodeans_code)
end else
if msg^.u4 = nodeans_code then (* node test answer *)
begin
lock msg as buf: testshape do
if buf.head.send.macro.nc_addr = 0 then
begin node_up:= dc_up; node:= dc end else
begin node_up:= nc_up; node:= nc end;
timerupdate ( t_up(node), -1,
sem(timeout_sem_no).s^, sem(done).w^);
if not running(node) then (* node running again *)
begin
(* broadcast ( ms1, netaddr(node), node_up, ath);
broadcast ( msg, netaddr(node), node_up, vch); *)
running(node):= true
end;
return ( msg);
end else refuse ( msg, unknown_opcode)
end; (* of watch *)
\f
(*------------------------- tss function --------------------------*)
procedure tss_function ( var msg : reference );
(* msg : received message for ts-supervisor *)
var
group : func_grp;
begin
(*q if debug>= 3 then testout ( console,"tss gets ", msg^.u4); q*)
group:= msg^.u4 div maxno;
case group of
0: (* returned log *)
begin return ( msg);
testout ( console, "log retur ", lost );
end;
1: (* returns *) rec_returned ( msg );
2: (* broadcast *) rec_broadcast( msg );
9: (* new lam *) new_lam ( msg );
11: (* new addr *) var_update ( msg );
12: (* watch *) watch ( msg )
otherwise (* refuse *) refuse ( msg, unknown_opcode)
end;
end; (* of tss function *)
\f
(*-------------------- exception ---------------------------------*)
procedure exception ( cause : integer);
begin
trace ( cause);
if not nil ( ms1) then return ( ms1);
if not nil ( ms ) then refuse ( ms, breaked);
sensesem ( ms, sem(queue).w^);
while not nil ( ms) do
begin
refuse ( ms, breaked);
sensesem ( ms, sem(queue).w^)
end;
for module:= netc to ath do
begin
wait ( ms, sem(free_sem_no).w^);
broadcast ( ms, here, lost, ts_down, module)
end;
repeat
wait ( ms, sem(tssup_sem_no).w^);
refuse ( ms, breaked)
until false;
end;
\f
(*---------------------------------------------------------------*)
(* *)
(* main program *)
(* *)
(*---------------------------------------------------------------*)
begin
testopen ( console, own.incname, opsem);
if debug>=0 then testout ( console, version, al_env_version);
here.macro:= macroaddr(0,0,0);
here.micro:= tss_mic_addr;
netaddr(dc):= here;
netaddr(nc):= here;
(**demo get buffers for log and clock **)
for cnt:= 1 to no_req_supp do
begin
alloc ( ms, suppool, sem(supp_sem_no).s^);
ms^.u3:= tss_route;
signal ( ms, sem(supp_sem_no).s^ )
end;
alloc ( clock_msg, clockpool, sem(done).s^);
clock_msg^.u1:= read_clock;
clock_msg^.u3:= tss_route;
no(netc):= netc_sem_no;
no( vch):= vch_sem_no;
no( ath):= ath_sem_no;
cv:= link ("lam ", lam);
if cv <> 0 then testout ( console, "link lam = ", cv);
start_lam ( 0, 5);
start_timeout;
(*q if debug>=1 then testout ( console,"timermodul ", 800 ); q*)
for module:= netc to dc do
begin
alloc ( t_out(module), t_pool, sem(tssup_sem_no).s^ );
alloc ( t_up(module), u_pool, sem(done).s^);
t_up(module)^.u3:= tss_route;
timerbook ( t_up(module), t_out(module), -1, microadr(module),
sem(timeout_sem_no).s^, sem(done).w^)
end;
start_netcon;
start_vchan;
start_athan;
(* kun for ts-connector
wait ( ms, sem(free_sem_no).w^);
lock ms as head: alarmlabel do
begin
head.rec:= here;
head.send:= here;
end;
send_up ( ms, new_ans_code); *)
(*q if debug>=1 then testout ( console,"init ok ", 820 ); q*)
\f
(*------------------ main loop -------------------------*)
repeat (* until forever *)
if open ( sem(queue).w^) then sensesem ( ms1, sem(free_sem_no).w^);
if open ( sem(queue).w^) and not nil ( ms1) then (* take queue *)
begin
wait ( ms, sem(queue).w^);
quelen:= quelen-1
end else
begin
(*q if (debug mod 8)>=4 then testout ( console,"wait mysem ", 960 ); q*)
wait ( ms, sem(tssup_sem_no).w^ );
end;
(*q if (debug mod 8)>=4 then testout ( console,"handle ", msg_ready); q*)
case ms^.u3 of
dummy_route: module:= empty;
tim_route,
tim_route1: module_timeout ( ms, module );
netc_route: downwards ( ms, module);
netc_route1:
begin
testout ( console, "netc-route1 ", ms^.u4);
module:= dc;
end;
otherwise upwards ( ms, module );
end;
case module of
dummy: ; (* no action *)
empty: return ( ms ); (* no data *)
tss: tss_function ( ms );
vch: signal ( ms, sem(vch_sem_no).s^ );
ath: signal ( ms, sem(ath_sem_no).s^ );
netc: begin
if ( debug mod 16 ) >= 8 then display ( ms);
signal ( ms, sem(netc_sem_no).s^ );
end
otherwise refuse ( ms, not_found)
end; (* case *)
until forever
end . (* of ts supervisor program *)
«eof»