⟦a237df42a⟧

TextFileVerbose

(******************************************************************)
(*                                                                *)
(* process local    transmitter                                   *)
(* ---------------------------------------------------------------*)
(*                                                                *)
(* ltrm:          transmit semaphores for connectors in the node  *)
(* cparams:       constant params for this connector              *)
(* rtables:       routing tables for levels 1, 2, ... rlmax       *)
(* queues:        queue and state for each connector in the node  *)
(* netwtime:      network time                                    *)
(* supv:          supervisor semaphore                            *)
(* utrm_sem:      main semaphore of local receiver                *)
(* ownaddr:       network address of this node                    *)
(* nnpflags:      table with nnp information                      *)
(* nnpreq:        waiting nnp requests from connectors            *)
(* c:             connector number of this connector (index in    *)
(*                arrays 1..cmax)                                 *)
(*                                                                *)
(******************************************************************)



process lotrm( var sysvec: system_vector;
var ltrm: !ltsmarray;
var cparams: cparams_type;
var rtables: rtabarray;
var queues: qinftable;
var netwtime: nwtime;
var supv: ! tap_pointer;
var utrm_sem: ! tap_pointer;
var ownaddr: nwadr;
var nnpflags: nnpfltable;
var nnpreq: csemarray;
c: integer);

const
version='ver. 810424/';

(* u1 values *)

timer_ps=wait_event_buf+1;

(* u4 values *)

eventstream=1;



type
pacttype=(pinsertps,copypk,preturn,proute);



var

z:zone;
(*=====================================================*)
(* extension level routing table ELRT                  *)
(*=====================================================*)
no_of_ext:integer:=0;
ext_rout_tab:extrouttable:=extrouttable
(?,1,extdarray(extmax***extdescript(true,?,0,?,0,ext_stat_type(0,0,0))));
index_elrt:indextab;

(*======================================================*)
(* packet storage area                                  *)
(*======================================================*)
ps:p_s_type:=p_s_type(0,psarray(psmax***pselement(true,?,?)));



lorecsh: shadow;
lcp_op: lcp_oper_type;

dropped: integer:=0;
i: integer;
ext_no: integer;
dest: integer;
extindex: integer;
daddr: nwadr;
paction: pacttype;
namerec: alfa;
msg: reference;
ref: reference;

timerhead: pool 1;
eventpool: pool 2 of int_event_type;
lostevent: event_lost_type:=event_lost_type(
eventrecordtype(ev_lost,4,connector_mod,?),0);

process lorec( var sysvec:system_vector;
var ltrm: ! ltsmarray; var rtables:rtabarray;
var queues:qinftable; var netwtime:nwtime; var ext_rout_table:extrouttable;
var index_elrt:indextab;var cparams:cparams_type;  var utrm: !tap_pointer;
var supv: !tap_pointer; var no_of_ext:integer; var ownaddr:nwadr;
c:integer);
external;


(*-----------------------------------------------------------*)
(* internal procedures                                       *)
(*-----------------------------------------------------------*)



function copypacket(var frompack: pack1; var topack:pack1):boolean;

(* The function copies the content of frompack to topack.
Note that the routerparameters in topack are unchanged. If
topack cannot hold the packet the function is false else true *)

var
ph:rparamtype;


begin
ph:=topack.rparam; (* save routerparams *)
topack:=frompack;
topack.rparam:=ph;
copypacket:=true;
end;

function create_ext(extno:integer) : boolean;

(* The function creates an extension number in the ELRT and
the index_elrt. If no free entry exists or the extension
number exists already, the function is false else true. If
true the statistics in the ELRT are initialized and no_of_ext
is incremented. The firstfree entry in ELRT is updated too.
The function insert_table is called. *)

var
i:integer;


begin
if no_of_ext=extmax then create_ext:=false else
begin
i:=ext_rout_tab.first_free;
case insert_table(extno,i,1,no_of_ext,index_elrt) of
true:
begin (* extension inserted in index_table *)
with ext_rout_tab.tab(ext_rout_tab.first_free) do
begin
free:=false;
ext_no:=extno;
ubd_type:=0;
wait_p_ps:=0;

st.xmit:=0;
st.rec:=0;
st.lost:=0;

end;
extindex:=ext_rout_tab.first_free;
ext_rout_tab.first_free:=ext_rout_tab.first_free-1;
repeat
ext_rout_tab.first_free:=ext_rout_tab.first_free+1;
until (ext_rout_tab.tab(ext_rout_tab.first_free).free) or
(ext_rout_tab.first_free=extmax);
create_ext:=true;
end;
false:
create_ext:=false;
end;  (* case insert_table *)
end;
end;


function remove_ext(ext_no: integer) : boolean;

(* The function removes the specified extension number
from the ELRT by setting free=true and from the index_elrt. The 
function remove_table is called. If the extension number does
not exist the function is false else true. If true
no_of_ext is decremented and first_free in ELRT is updated *)

var
i:integer;

begin
case remove_table(ext_no,i,1,no_of_ext,index_elrt) of
true:
begin (* ext removed from index table *)
ext_rout_tab.tab(i).free:=true;
if ext_rout_tab.first_free>i then
ext_rout_tab.first_free:=i;
remove_ext:=true;
end;
false:
remove_ext:=false;
end;
end;


procedure empty_sem(var sem:semaphore);

(* The specified semaphore is emptied. The pending references
are returned with the u2 field set to not_processed *)

var
ref: reference;

begin
while open(sem) do
begin
wait(ref,sem);
ref^.u2:=not_processed;
return(ref);
end;
end;


procedure ins_pack_ps(var packet: reference);

(* The procedure inserts the packet referenced by packet in
the packet storage area as the newest element i.e. at
element oldest that is incremented at return. The number
of waiting packets at the PS for the specified extension
number is incremented. Before the packet is inserted the 
procedure check_index_ps(..oldest...) must be called *)

begin
ps.tab(ps.oldest).free:=false;
ps.tab(ps.oldest).ext_no:=ext_no;
ps.tab(ps.oldest).ref:=:packet;
ps.oldest:=(ps.oldest+1) mod psmax;
ext_rout_tab.tab(extindex).wait_p_ps:=ext_rout_tab.
tab(extindex).wait_p_ps+1;
end;


procedure ret_pack_ps(var buf: reference);

(* The packet storage is searched to find the oldest element
with the specified extension number. When found the pending
packet is copied to the buffer referenced by buf if possible,
and the number of waiting packets at the PS for that extension
number(extindex) is decremented. The element in the PS is then
set free. NOte that there must exist at least one packet at
the PS for the specified ext_no or else the procedure loops.If
the buffer referenced by buf is too small to hold the packet
the buffer is returned with result=buf_lgth_err and the packet
remains at the PS *)

var
i:integer;
paction: boolean;

begin
i:=ps.oldest;
while (ps.tab(i).free) or (ext_no<>ps.tab(i).ext_no) do
i:=(i+1) mod psmax;
lock ps.tab(i).ref as p:pack1 do
begin (* copy packet to buf *)
lock buf as p1: pack1 do
paction:=copypacket(p,p1); (* copy *)
end;  (* copy packet *)
if paction then
begin (* copy ok *)
ps.tab(i).ref^.u2:=ok;
return(ps.tab(i).ref);
buf^.u2:=ok;
return(buf);
ps.tab(i).free:=true;
ext_rout_tab.tab(extindex).wait_p_ps:=
ext_rout_tab.tab(extindex).wait_p_ps-1;
end   else
begin (* no copy *)
buf^.u2:=buf_lgth_err;
return(buf);
end;
end;


procedure check_index_ps( index:integer);

(* The procedure checks the element in the packet storage area
pointed out by index. If present, the pending packet pointed
out by index is rejected (or returned ) to its origin.
The number of waiting packets at the PS and the number of lost packets
for the extension number is decremented and the element at the PS is set free *)

var
i,dest:integer;
proute:boolean;
daddr:nwadr;

begin
if ps.tab(index).free=false then
begin (* element not free *)
ps.tab(index).free:=true;
lock ps.tab(index).ref as p:pack1 do
begin (* reject packet *)
case reject(p,st_norecreso) of
true:
begin
get_addr(p,daddr);
proute:=masterroute(p,dest,ownaddr,daddr,rtables,queues);
end;
false:
proute:=false;
end;  (* case reject *)
end;   (* reject packet *)
if proute then
signal(ps.tab(index).ref,ltrm(dest).s^) else
begin 
ps.tab(index).ref^.u2:=ok;   (* ?????????????????      *)
return(ps.tab(index).ref);
end;
case search_table(ps.tab(index).ext_no,i,1,no_of_ext,index_elrt) of
true:
begin
i:=index_elrt(i).index;
ext_rout_tab.tab(i).wait_p_ps:=
ext_rout_tab.tab(i).wait_p_ps-1;
inc16(ext_rout_tab.tab(i).st.lost);
end;
false:      ;
end;  (* case search_table  *)
end; (* element not free *)
end;












procedure send_event(var ref: reference);
begin
ref^.u1:= wait_event_buf;
ref^.u2:=message;
ref^.u3:=c;
ref^.u4:=eventstream;
signal(ref,supv.s^);
end;



(* mangler:--------------------------------------------------------*)


begin
testopen(z,own.incname,sysvec(operatorsem));
testout(z,version,0);

new_conn_state(queues,c,running);
insert_local_node (rtables(1), c, cparams(1));
wait (ref, nnpflags.key);     (* enter critical region *)
for i:= 1 to cmax do
if nnpflags.nblevel(i)= 1 then
if set_nnp_fl (i, nnpi(nnp_nodrng), nnpflags) then
ret_nnp_req (nnpreq(i));
signal (ref, nnpflags.key);   (* exit critical region *)

lostevent.evtrec.incarnation:=c;

i:=link('lorec       ',lorec);
nameinit (namerec, 'lorec       ', 6, c);    (* init lorec name *)
i:=create(namerec,lorec(sysvec,ltrm,rtables,queues,netwtime,
ext_rout_tab,index_elrt,cparams,utrm_sem,supv,
no_of_ext, ownaddr, c),
lorecsh,300);
start(lorecsh,stdpriority);



alloc(msg,timerhead,ltrm(c).s^);
msg^.u1:=timer_ps;
msg^.u2:=message;
msg^.u3:=cparams(2);
msg^.u4:=cparams(3);  (* packet storage dealy *)
sendtimer(msg);


repeat
wait(msg,ltrm(c).w^);
case msg^.u2 of

(*------------------------------*)
(*     message                  *)
(*------------------------------*)
message:
begin (* message *)
(*  test size,first,last,next------------------------------------------*)

case msg^.u1 of

(*------------------------------*)
(*  output i.e. packet for user  *)
(*------------------------------*)
trm_packet,dir_transm:
begin (* output *)
update_queue(queues,c,-1);  (* critical region *)
lock msg as p1:pack1 do
begin (* lock msg *)
if (p1.head.fac.mirror=1) and (p1.head.state=0) then
begin (* mirror bit set *)
swaph1(p1);
p1.head.state:=st_mirrored;
get_addr(p1,daddr);
if masterroute(p1,dest,ownaddr,daddr,rtables,queues) then
paction:=proute else paction:=preturn;
end (* mirror *)    else
if p1.head.fac.drop=1 then
paction:=preturn    else

begin (* not mirror or drop *)
ext_no:=p1.head.ext_dst;
if search_table(p1.head.ext_dst,i,1,no_of_ext,index_elrt) then

(*------------------------------*)
(*  extension destination found  *)
(*------------------------------*)
begin (* extension destination found *)
extindex:=index_elrt(i).index;   (* find entry in ELRT *)
inc16(ext_rout_tab.tab(extindex).st.rec);
case ext_rout_tab.tab(extindex).ubd_type of

(*------------------------------*)
(*  no waiting buffers at ubd   *)
(*------------------------------*)
0:
 (* no waiting buffers at ubd *)
paction:=pinsertps;       (* action:= insert in ps *)

(*------------------------------*)
(*  empty buffer present at ubd *)
(*------------------------------*)
rec_packet:
begin (* empty buffer present at ubd *)
paction:=pinsertps;      (* action:=insert in ps *)
while open(ext_rout_tab.tab(extindex).ubd_sem) 
and ( paction = pinsertps ) do
begin (* find buffer in ubd that is big enough *)
wait(ref,ext_rout_tab.tab(extindex).ubd_sem);
lock ref as p2: pack1 do
case copypacket(p1,p2) of

true:
paction:=copypk;    (* action := copied *)

false:
begin (* buffer too small *)
ref^.u2:=buf_lgth_err;
return(ref);
end;  (* buf too small *)

end; (* case copypack *)
end; (* find buffer in ubd *)

if passive(ext_rout_tab.tab(extindex).ubd_sem) then
ext_rout_tab.tab(extindex).ubd_type:=0;
end; (* empty buffer present at ubd *)

(*------------------------------*)
(*  sense ready present at ubd  *)
(*------------------------------*)
sense_ready:
begin (* sense ready present at ubd *)
wait(ref,ext_rout_tab.tab(extindex).ubd_sem);
ref^.u2:=ok;
return(ref);
if passive(ext_rout_tab.tab(extindex).ubd_sem) then
ext_rout_tab.tab(extindex).ubd_type:=0;
paction:=pinsertps;    (* action := insert in ps *)
end; (* sense ready *)

end;  (* case ubd_type *)

end  (* ext dest found *) else

(*------------------------------*)
(*  extension number unknown    *)
(*------------------------------*)
begin (* extension number unknown *)
get_addr(p1,daddr);
case reject(p1,st_extunkn) of
true:
begin (* reject packet *)
case masterroute(p1,dest,ownaddr,daddr,rtables,queues) of
true:
paction:=proute;   (* action:=route packet *)

false:
paction:=preturn;   (* action:=return packet *)
end; (* case masterroute *)
end;  (* reject packet *)

false:
paction:=preturn;   (* action:=return packet *)
end; (* case reject *)

end; (* ext dest unknown *)
end;  (* not mirror or drop *)
end;  (* lock msg *)

case paction of

pinsertps:
 (* insert packet in packet storage *)
begin
check_index_ps(ps.oldest);
ins_pack_ps(msg);
end;

copypk:
begin (* packet copied to user buffer *)
msg^.u2:=ok;
return(msg);  (* return output  *)
ref^.u2:=ok;
return(ref);  (* return user input  *)
end;  (* packet copied *)

preturn:
begin (* return packet *)
inc16(dropped);
msg^.u2:=ok;     (* ?????????????? *)
return(msg);
end; (* return packet *)

proute:
 (* route packet - rejected *)
signal(msg,ltrm(dest).s^);
end; (* case paction *)

end;  (* output *)


(*------------------------------*)
(*  supervisor message buffer   *)
(*------------------------------*)
sup_mess_buf:
begin (* supervisor message buffer *)
lock msg as p: r_lcp_head do
lcp_op:=p.sp_head.lcp_oper;
case lcp_op.basic of

(*------------------------------*)
(*  illegal basic operations    *)
(*------------------------------*)
lcp_cntr,
lcp_sense,
lcp_event:
answ_lcp(msg,(.ill_lcp_oper.),2);

(*------------------------------*)
(*  get statistics operations   *)
(*------------------------------*)
lcp_get_stat:
begin (* get statistics operations *)
case lcp_op.modif of


(*------------------------------*)
(*   get extension statistics   *)
(*------------------------------*)
opc_g_ext_st:
begin (* get extension statistics *)
lock msg as p: extension_st_type do
begin (* lock msg *)
p.dropped:=dropped;
p.n_of_ext:=no_of_ext;
if no_of_ext<>0 then
begin (* form statistics *)
for i:=1 to no_of_ext do
begin
p.st(i).ext_no:=index_elrt(i).skey;
p.st(i).st:=ext_rout_tab.tab(index_elrt(i).index).st;
end;
end;  (* form stat *)
end;  (* lock msg *)
answ_lcp(msg,(..),6+(no_of_ext*statextlgt));

end;  (* get extension statistics *)

otherwise

(*-------------------------------*)
(* illegal get stat operation    *)
(*-------------------------------*)
answ_lcp(msg,(.ill_lcp_oper.),2);

end;  (* lcp_op.modif *)

end;  (* get statistic operations *)

end;  (* case lcp_op.basic *)

end;  (* supervisor message buffer *)




(*------------------------------*)
(*  connect extension           *)
(*------------------------------*)
connect_ext:
begin (* connect ext *)
if no_of_ext < extmax then
begin (* enough resources *)
lock msg as p: routptype do
ext_no:=p.rparam.rparam1;
case create_ext(ext_no) of

true:
begin (* extension connected *)
msg^.u2:=ok;
return(msg);
if openpool(eventpool) then
begin (* free eventmessages in ev.pool *)
alloc(msg,eventpool,ltrm(c).s^);
lock msg as p: event_extcon_type do
begin (* lock *)
p.evtrec.event_type:=ev_conext;
p.evtrec.bytecount:=4;
p.evtrec.rout_mod:=connector_mod;
p.evtrec.incarnation:=c;
p.ext_no:=ext_no;
end;  (* lock *)
send_event(msg);
end    else

(* no free eventmessages *)

lostevent.lost:=lostevent.lost+1;

end;  (* extension connected *)

false:
begin (* extension exists already *)
msg^.u2:=ext_exists;
return(msg);
end; (* ext exist already *)

end; (* case create_ext *)

end  (* enough resources *)   else

begin (* no resources *)
msg^.u2:=no_resources;
return(msg);
end;  (* no resources *)
end;  (* connect ext *)

(*------------------------------*)
(*                              *)
(*------------------------------*)
disconnect_ext,
reset,
rec_packet,
get_packet,
sense_ready:
begin (* functions where extension number must be known *)
lock msg as p: routptype do
ext_no:=p.rparam.rparam1;
case search_table(ext_no,i,1,no_of_ext,index_elrt) of

(*------------------------------*)
(*   extension number ok        *)
(*------------------------------*)
true:
begin (* ext_no ok *)
extindex:=index_elrt(i).index;   (* find entry in ELRT *)
case msg^.u1 of

(*------------------------------*)
(*  disconnect extension        *)
(*------------------------------*)
disconnect_ext:
begin (* disconnect ext *)
ext_rout_tab.tab(extindex).ubd_type:=0;

(* empty ubd_sem *)
empty_sem(ext_rout_tab.tab(extindex).ubd_sem); 

(* empty ps *)
i:=ps.oldest;
while ext_rout_tab.tab(extindex).wait_p_ps > 0 do
begin
while  ps.tab(i).free or
(ext_no<>ps.tab(i).ext_no ) do
i:=( i+1 ) mod psmax;
check_index_ps(i);
end;

case remove_ext(ext_no) of

true:
begin (* extension number disconnected *)
msg^.u2:=ok;
return(msg);
if openpool(eventpool) then
begin (* free eventmessages *)
alloc(msg,eventpool,ltrm(c).s^);
lock msg as p: event_extdisc_type do
begin (* lock *)
p.evtrec.event_type:=ev_discext;
p.evtrec.bytecount:=2+statextlgt;
p.evtrec.rout_mod:=connector_mod;
p.evtrec.incarnation:=c;
p.st.ext_no:=ext_no;
p.st.st:=ext_rout_tab.tab(extindex).st;
end;  (* lock *)
send_event(msg);
end    else

(* no free event messages *)

lostevent.lost:=lostevent.lost+1;

end;  (* extension number disconnected *)

false: ;      (* has been tested  *)

end; (* case remove_ext *)

end;  (* disconnect ext *)

(*------------------------------*)
(*  reset                       *)
(*------------------------------*)
reset:
begin (* reset *)
ext_rout_tab.tab(extindex).ubd_type:=0;
empty_sem(ext_rout_tab.tab(extindex).ubd_sem);
msg^.u2:=ok;
return(msg);
end;  (* reset *)

(*------------------------------*)
(*  receive packet              *)
(*------------------------------*)
rec_packet:
begin (* receive packet *)
if ext_rout_tab.tab(extindex).wait_p_ps>0 then
ret_pack_ps(msg)
else
begin (* no packets waiting at the ps *)
case ext_rout_tab.tab(extindex).ubd_type of

0:  (* ubd sem empty  *)
ext_rout_tab.tab(extindex).ubd_type:=rec_packet;

sense_ready:    (* sense ready at ubd sem *)
begin
ext_rout_tab.tab(extindex).ubd_type:=rec_packet;
empty_sem(ext_rout_tab.tab(extindex).ubd_sem);
end;

rec_packet:  ;   (* receive packet at ubd sem *)

end;  (* case ubd_type *)

signal(msg,ext_rout_tab.tab(extindex).ubd_sem);

end; (* no packets waiting at the ps *)
end;  (* receive packet *)

(*------------------------------*)
(*   get packet                 *)
(*------------------------------*)
get_packet:
begin (* get packet *)
if ext_rout_tab.tab(extindex).wait_p_ps>0 then
ret_pack_ps(msg)
else
begin (* no packets waiting at the ps *)
msg^.u2:=not_processed;
return(msg);
end;  (* no packets waiting at the ps *)
end;  (* get packet *)

(*------------------------------*)
(*  sense ready                 *)
(*------------------------------*)
sense_ready:
begin (* sense ready *)
if ext_rout_tab.tab(extindex).wait_p_ps > 0 then
begin (* packets waiting at the ps *)
msg^.u2:=ok;
return(msg);
end  (* packets waiting at the ps *)  else

begin (* no packets waiting at the ps *)
case ext_rout_tab.tab(extindex).ubd_type of

0:   (* ubd sem empty  *)
ext_rout_tab.tab(extindex).ubd_type:=sense_ready;

rec_packet:   (* receive packet present at ubd sem *)
begin
empty_sem(ext_rout_tab.tab(extindex).ubd_sem);
ext_rout_tab.tab(extindex).ubd_type:=sense_ready;
end;

sense_ready:  ;  (* sense ready present at ubd sem *)

end;  (* case ubd_type *)

signal(msg,ext_rout_tab.tab(extindex).ubd_sem);

end; (* no packets waiting at the ps *)

end;  (* sense ready *)

end; (* case msg^.u1 *)

end;  (* ext_no ok *)

(*------------------------------*)
(*  extension number unknown    *)
(*------------------------------*)
false:
begin (* ext_no unknown *)
msg^.u2:=ext_unkn;
return(msg);
end;  (* ext_no unknown *)

end; (* case search_table *)

end;  (* func where ext_no must be known *)

otherwise

(*------------------------------*)
(*  illegal function            *)
(*------------------------------*)
begin (* illegal function *)
msg^.u2:=illegal;
return(msg);
end;  (* illegal function *)

end; (* case msg^.u1 *)

end;  (* message *)

otherwise

(*------------------------------*)
(*     answer                   *)
(*------------------------------*)
begin (* answer *)
case msg^.u1 of

(*------------------------------*)
(*  timer for packet storage    *)
(*------------------------------*)
timer_ps:
begin (* timer for ps received *)
msg^.u2:=message;
msg^.u3:=cparams(2);
msg^.u4:=cparams(3);
sendtimer(msg);   (* send timer again *)

(* reject oldest packet at the ps *)
check_index_ps(ps.oldest);

ps.oldest:=(ps.oldest+1) mod psmax;
end; (* timer for ps received *)

(*------------------------------*)
(* eventbuf returned from ncp   *)
(*------------------------------*)
wait_event_buf:
begin (* event returned *)
copy_event(msg);   (* return event buffer to ncp *)
if lostevent.lost=0 then release(msg) else
begin (* events lost *)
lock msg as p: event_lost_type do
p:=lostevent;
lostevent.lost:=0;
send_event(msg);
end;  (* events lost *)
end;  (* event returned *)

otherwise

(*------------------------------*)
(*  illegal answer              *)
(*------------------------------*)
release(msg);    (* error *)

end;  (* case msg^.u1 *)

end;  (* answer *)

end; (* case msg^.u2 *)

until false;

end. (* process lotrm *)

«eof»
DataMuseum.dk

RC3500

⟦a237df42a⟧ TextFileVerbose

Derivation

TextFileVerbose
