⟦bbbf2abfb⟧

TextFileVerbose

job oer 5 200 time 11 0 area 10 size 100000
(
source = copy 25.1
tsalclst = set 1 disc1
tsalcerr = set 1 disc1
tsalclst = indent source mark lc
listc = cross tsalclst
o tsalcerr
message  pascal
pascal80 alarmenv source
o c
lookup pass6code
if ok.yes
( tsalcbin = set 1 disc1
  tsalcbin = move pass6code
  scope user tsalcbin
)
tsalclst = copy listc tsalcerr
scope user tsalclst
scope user tsalcerr
finis output.no
)
\f


process alc (
lam_port_no : 0..16;
opsem : sempointer;              (*  operator sem        *)
var
lamsem,                          (*  to lam              *)
timeoutsem,                      (*  to timeout          *)
listensem :    !sempointer;      (*  buffer pool         *)
var
mainsem,                         (*  my mainsem          *)
outsem,                          (*  transfer queue      *)
myfree,                          (*  my free buffers     *)
lamoutsem,                       (*  from lam            *)
timeoutanswer : !ts_pointer );   (*  from timeout        *)

(********************************************************
*
*
*  semaphores: the module receives messages on mainsem,
*              and sends messages aimed at:
*              timeoutmodule on timeoutsem,
*              lamdriver on lamsem,
*
*
*********************************************************)

(*-------------------------- configuration ----------------------------*)

const
 
version = "vers  1.01 /";
\f


enq_tmo = 4;
data_tmo = 6;

const

(*--  buffer  values  *)

tsbufleng= size_listen*2 -2; (* no of bytes in buffer from tss *)
lambufsize= 80;              (* no of bytes in buffer to lamdriver *)

con_lam_time= 0;             (*  lam driver timeout    *)

no_of_lamlis= 2;
no_of_lamout = 2;
no_of_mybuf= 2;  (*  buffers in my pool  *)

\f


(*--  buffer  types   *)
 
type
tsbuftype= (* message to/from tss *)
record
bytes: integer;
data: array (1..tsbufleng) of byte;
end;
 
lambuftype= (* message to/from lamdriver *)
packed record
stxt,
bll,
opc: byte;
text: array (1..lambufsize-3) of byte; 
end;

creatotal_errshtype= (* message format in creatotal_errshannel operation *)
record
controlinfo, timeout: byte;
end;
 
\f

 
(*------------------------------------------------------
.  ALC-protocol                                        .
.  types, constants, variables                         .
--------------------------------------------------------*)

type
statetype = ( discon, idle, w_r_data, w_r_enq );
eventtype = ( uo, reset, ack, timo, data, enq, nons );
actiontype = 0..15;

pri_action_row = array ( uo..timo ) of actiontype;
sec_action_row = array ( data..enq) of actiontype;

pri_act_t_type = array (discon..w_r_enq) of pri_action_row;
sec_act_t_type = array (  idle..idle   ) of sec_action_row;


pri_sta_row = array ( uo..timo ) of statetype;

pri_sta_t_type = array (discon..w_r_enq) of pri_sta_row;
\f


const
pri_states = (.discon..w_r_enq.);
sec_states = (.idle.);

pri_events = (.uo..timo.);
sec_events = (.data..enq.);

(*-- primary command codes --*)

data_0 = 128;
data_1 = 129;

enq_opc    = 5;

(*-- secondary receipt codes --*)

ack_0 = 19;
ack_1 = 20;

reset_opc = 21;

\f


pri_act_table =
pri_act_t_type (
             (*                             uo,  reset,  ack,  timo  *)
             (*discon  *) pri_action_row (   1,    0,     9,     2    ),
             (* idle   *) pri_action_row (   3,    0,     0,     0    ),
             (*w_r_data*) pri_action_row (   4,    0,     5,     8    ),
             (*w_r_enq *) pri_action_row (   4,    6,     7,     8    ));

sec_act_table =
sec_act_t_type (
             (*                            data,  enq   *)
             (* idle   *) sec_action_row (   2,    1     ));

pri_sta_table =
pri_sta_t_type (
             (*                            uo,  reset,  ack,  timo  *)
             (*discon  *) pri_sta_row (discon,   idle, idle, discon  ),
             (* idle   *) pri_sta_row (w_r_data, idle, idle,   idle  ),
             (*w_r_data*) pri_sta_row (w_r_data,w_r_data,w_r_data,w_r_enq),
             (*w_r_enq *) pri_sta_row (w_r_enq, w_r_data,w_r_data,w_r_enq));

var
pri_action,
sec_action : actiontype;

pri_state,
sec_state : statetype;

event : eventtype;

pri_data_no : integer;
sec_last_rec: integer;

trans_retry : integer;
\f

 
var
(*-----  pools and references  ------*)

mypool:     pool (no_of_mybuf) of logtype;   (* messagetype *)
lampool:    pool (no_of_lamout+no_of_lamlis) of lambuftype;

updatepool: pool 1 of updates;             (* updates *)
timerpool:  pool 1 of timers;           (*  for timeout         *)
 
uo_act_ref,
myref,
lamref,
tmomes,
msg: reference;
 
z: zone;
 
(*-----  statistics and test variables  -----*)

checklamlisten, (* how many listenbuffers to be checked after
recreation of lamchannel caused by output or input status error *)
i,
sendcnt,  retrcnt,         (*  statistics counters      *)
givupcnt, reccnt,
nakcnt,   formcnt,
lamoutcnt, lamincnt,

trans_retry,            (*  transmission error count pr message  *)
total_errs : integer := 0;  (*  transmis. error count  *)

testlevel : integer:= 0;       (*  controls testoutput     *)
trans_retrymax : integer:= 7;          (*  max errors pr message   *)
 
(*booleans*)
testboo : boolean;

act_result,
reccode            (*  opc in received block   *)
       : byte;
\f

 
procedure testwrite (level: integer; a:alfa; i:integer);
begin
if ( testlevel mod ( 2*level)) >= level then
testout(z,a,i)
end;


procedure tswait ( var msg: reference;  var sp: sempointer );
begin

wait ( msg, sp^);

while msg^.u3 = dummy_route do
begin
return ( msg);
wait ( msg, sp^)
end;
end;


procedure book ( time: integer);
begin
  timerbook ( tmomes, msg, time, netc_mic_addr,
     timeoutsem^, timeoutanswer.w^)
end;


procedure moretime ( time: integer);
begin
  timerupdate ( tmomes, time, timeoutsem^, timeoutanswer.w^)
end;


procedure sendlam;
begin
msg^.u2 := lam_port_no;
signal( msg, lamsem^);
end;

\f


procedure creatotal_errshn (timeoutper: integer);
(*-------------------------------------------------
.  creates lamchannel
---------------------------------------------------*)

begin

alloc ( lamref, lampool, lamoutsem.s^);

repeat
lamref^.u1:= create_it_ch;
lamref^.u2:= lam_port_no;
lamref^.u3:= lam_route;

lock lamref as crbuf: creatotal_errshtype do
begin
crbuf.controlinfo:= ts_control;
crbuf.timeout:= timeoutper;
end;
 
signal (lamref, lamsem^);
tswait (lamref, lamoutsem.w);

if lamref^.u2 <> 0
then (* error *)
begin
count ( lamoutcnt);
testwrite ( 1, "creatotal_errsh u2:", lamref^.u2);
end;

until lamref^.u2= 0;

release ( lamref);
 
end; (* creatotal_errshn *)
\f

 

function line_receive : eventtype;
(*-----------------------------------------------------
.  gets buffer from mainsem and decodes it to an event
-------------------------------------------------------*)

begin

repeat
tswait ( msg, mainsem.w);

case msg^.u3 of
 
tim_route: (* buffer from timeout *)
line_receive:= timo;

\f


lam_route: (* buffer from lam_driver *)
case msg^.u2 of

0:
 lock msg as lambuf: lambuftype do 
with lambuf do
begin
reccode:= opc;
if (bll < 4) or (bll > lambufsize) then
begin
reccode:= ord(sub);
count ( formcnt);
testwrite ( 4, "blocklength ", bll);
end  else
if text(bll-3) <> ord(etx) then
begin
reccode:= ord(sub);
count ( formcnt);
testwrite ( 4, "format error", bll-3);
end;
case reccode of
data_0,
data_1 : line_receive:= data;
ack_0,
ack_1  : line_receive:= ack;
reset_opc : line_receive := reset;
enq_opc : line_receive:= enq;
otherwise line_receive:= nons
end (* case lambuf.opc *);
end;
 
5: (* input timeout *)
line_receive:= timo;

otherwise   (*  error  *)
begin
count ( lamincnt);
testwrite ( 2, "lamresultu2:", msg^.u2);
line_receive:= nons;
end
end (* case lammsg^.u2 *);
\f

 
otherwise           (*  from user    *)
begin               (*  ts message        *)

(*
if msg^.u4 = updatevar then               
 lock msg as buf: note do
 with buf do
 begin
testlevel:= data(1);
mytick:= data(2);
trans_retrymax:= data(3);
head.result:= accepted;
head.rec:= head.send;
head.send:= here;
msg^.u4:= updatevar+1
end
else
if msg^.u4 = reading then           
lock msg as buf: note do
with buf do
begin
data(1):= sendcnt;     sendcnt:= 0;
data(2):= retrcnt;     retrcnt:= 0;
data(3):= givupcnt;    givupcnt:= 0;
data(4):= reccnt;      reccnt:= 0;
data(5):= nakcnt;      nakcnt:= 0;
data(6):= formcnt;     formcnt:= 0;
data(7):= lamoutcnt;   lamoutcnt:= 0;
data(8):= lamincnt;    lamincnt:= 0;
head.result:= accepted;
head.rec:= head.send;
head.send:= here;
msg^.u4:= reading+1;
end;
*)
line_receive:= out
end   (*  ts message  *)
end
until  not nil (msg)

end;   (*  of line_receive  *)
\f

 
function local_receive: eventtype;
(*-----------------------------------------------------
.  gets the next buffer to handle. The buffer is taken from either
.  mainsem or outsem deuo_act_ref on the state and the semaphores 
------------------------------------------------------*)
var statuserror: boolean;

begin
 

repeat
statuserror:= false;

if (pri_state= idle) and open (outsem.w^) then
begin
tswait (msg, outsem.w);
local_receive:= uo
end
else
local_receive:= line_receive;
 
if msg^.u3= lam_route then
begin (* listenbuffer with answer from lam_driver *)

if (checklamlisten>0) then
(* lamchannel recreated caused by outputbuffer or listenbuffer -
listenbuffers are to be checked while outputbuffer has been 
checked already *)
begin
checklamlisten:= checklamlisten-1;
if (msg^.u2=1) or (msg^.u2=3) then
begin (* listenbuffer returned by creatotal_errshannel *)
statuserror:= true;
sendlam;
end
end (* checklamlisten *)
\f


else
if (msg^.u2<> 0) and (msg^.u2<> 5) then
(* status error in lamlistenbuffer *)
begin

count ( lamincnt);
testwrite( 2, "lam status: ",msg^.u2);
statuserror:= true;
(* lamchannel recreated caused by listenbuffer -
(* try again: *)
sendlam;
end (* status error in lamlistenbuffer *)

end (* listenbuffer from lamdriver *)
 
until not statuserror;
 
end (* local_receive *);
\f

 
procedure line_transmit(transcode: byte);
(*----------------------------------------------------
. gets and fills in lamoutputbuffer, sends it to lamdriver 
------------------------------------------------------*)

var   errors: integer:= 0;

begin

tswait (lamref, lamoutsem.w);
 
while (errors < 10) and ( lamref^.u2> 0) (* status error *) do
begin
case lamref^.u2 of
1,3: (* channel recreated by driver *)
begin
testwrite ( 1, "lamch create", lamref^.u2);
checklamlisten:= no_of_lamlis;
(* listenbuffers might have been returned upon recreation *)
end;
 
4,5: testwrite ( 1, "lamresult:  ",lamref^.u2)

otherwise
begin
if lamoutcnt mod 10 = 0 then
testwrite ( 1, "lamerrorout:", lamoutcnt);
end;
end (* case lamref^.u2 *);
 
count ( lamoutcnt);
(* try last output again: *)
errors:= errors+1;
lamref^.u2:= tsc_port;
signal (lamref, lamsem^);
tswait (lamref, lamoutsem.w)
end (* while status error *);
\f

 
(* now compose lambuffer *)
if ( transcode = data_0 ) or ( transcode = data_1 ) 
then
(* copy message onto lambuffer *)
lock lamref as lambuf: lambuftype do

 (*  ts message  *)
lock uo_act_ref as mess: tsbuftype do
with lambuf do
begin
if (mess.bytes < label_size) or (mess.bytes > tsbufleng) then
begin
testout(z,"no_of_bytes:",mess.bytes);
testout(z,"u3:         ",uo_act_ref^.u3);
for i:= 1 to 10 do
testout(z,"   text     ",mess.data(i));
end;
 
if (mess.bytes < label_size) or (mess.bytes > tsbufleng ) then
  mess.bytes:= tsbufleng;
bll:= mess.bytes + 4;
opc:= transcode;
for i:= 1 to (bll-4) do
text(i):= mess.data(i);
if text(opco) <> uo_act_ref^.u4 then testout( z,"opcode      ", text(opco));
text(bll-3):= ord(etx);
end (* opcode=dataop *)
 
else
lock lamref as lambuf: lambuftype do
with lambuf do
begin
bll:= 4;
opc:= transcode;
text(1):= ord(etx);
end;
\f


(* now send lambuffer *)
lamref^.u2:= tsc_port;
(*
if testlevel > 48 then writeblock ( lamref);
*)
signal (lamref, lamsem^);

if not nil (msg) then
case msg^.u3 of
tim_route:  ;

lam_route:  sendlam;

otherwise return (msg);
end;
end;
\f

 
procedure accept_data;
(*-------------------------------------------------------
. copies listenbuffer from lamdriver onto ts-buffer
. and signals it to dc or supervisor 
---------------------------------------------------------*)

var  reply: byte;

begin

(* copy lambuffer onto ts buffer *)
lock msg as lambuf: lambuftype do
 
begin
sensesem ( myref, listensem^);
if nil ( myref) then sensesem ( myref, myfree.w^);
if not nil ( myref) then
lock myref as mess: tsbuftype do
with lambuf do
begin
bll:= bll - extra;
if bll < label_size then bll:= label_size  else
if bll > tsbufleng then bll:= tsbufleng;
mess.bytes:= bll;
for i:= 1 to bll do
mess.data(i):= text(i);
myref^.u4:= text(opco) (*op_code*);
end
end;

if nil ( myref) then     (*  no free buffer for the received data  *)
begin
count ( nakcnt);
reply:= nakop
end
else
begin   (*  data is in myref,  send to dc, nc, or sup   *)
reply:= reccode+2;
sec_last_rec:= reply;
myref^.u3:= netc_route;
route_local ( myref);
count ( reccnt);
end;

line_transmit( reply)

end;  (*  of accept message  *)

\f



procedure block_ok;
begin
 return ( uo_act_ref);
 moretime ( -1);
 total_errs:= total_errs + trans_retry;
end;





procedure reline_transmit;
begin
 line_transmit( pri_data_no);
 moretime ( mytick);
 trans_retry:= trans_retry+1;
 count ( retrcnt);
end;

\f



procedure give_up ( var msg: reference);
(*---------------------------------------------------
.   sends userbuffer to user
-----------------------------------------------------*)
var   code : byte;

begin

count ( givupcnt);
lock msg as head : alarmlabel do
 code:= head.op_code;
if ( code = nb_code) or ( code = refuse_code ) then
 return ( msg)
else
begin
 lock msg as buf : flawshape do
 with buf do
 begin
  data:= head;
  with head do
  begin
   no_of_by:= 2*label_size;
   rec:= send;
   send:= here;
   result:= no_connection
  end
 end;
msg^.u3:= netc_route;
msg^.u4:= refuse_code;               (*  1.2    *)
route_local ( msg)
end
end;



\f


(****************************
*                           *
*       main program        *
*                           *
****************************)

 
begin
testopen (z, own.incname, opsem);
testout(z,version,al_env_version);
 
 
(* creatotal_errshannel *)
creatotal_errshn (con_lam_time);

 
(* initialise lamlistenbuffers *)

for i:= 1 to no_of_lamlis do
begin
alloc (lamref, lampool, mainsem.s^);
lamref^.u1:= read_it; (* input *)
lamref^.u2:= tsc_port;
lamref^.u3:= lam_route;
signal (lamref, lamsem^);
end;
 
(* initialise lamoutputbuffer *)

for i:= 1 to 1 do
begin
alloc (lamref, lampool, lamoutsem.s^);
lamref^.u1:= write_it; (* output *)
lamref^.u2:= 0;
lamref^.u3:= lam_route;
lock lamref as lambuf: lambuftype do
lambuf.stxt:= ord(stx);
return (lamref);
end;
 
\f


(*----  initialize primary station  ----*)

pri_state := discon;
pri_data_no := data_1;


(*----  initialize secondary station  ----*)

sec_state := idle;
sec_last_rec := reset_opc;

\f



(*--------------------- main loop -----------------------------------*)

 
repeat

event:= local_receive;

if event in pri_events then
begin
(*------------  primary station  ------------*)

pri_action := pri_act_table( pri_state, event);
 
(*--                                                 ----------
case pri_state of
discon: testwrite ( 16, "discon      ", pri_action);
idle: testwrite ( 16, "idle        ", pri_action);
w_r_data: testwrite ( 16, "w_r_data    ", pri_action);
w_r_enq: testwrite ( 16,"w_r_enq      ", pri_action)
end;
  --                                                 ----------*)
case input of
data: testwrite ( 16, "  data      ", ord(pri_state));
uo : testwrite ( 16, "uo          ", ord(pri_state));
ack: testwrite (  8, "ack         ", ord(pri_state));
reset: testwrite (  8, "reset       ", ord(pri_state));
enq: testwrite (  8, "  enq       ", ord(pri_state));
timo : testwrite (  8, " timo       ", ord(pri_state));
end;

if testlevel >= 4 then
if event = nons then writeblock ( msg);
..
  ----------*)

pri_state := pri_sta_table (pri_state, event);
\f

 
case pri_action of 

0: (*no action *)
sendlam;

1: (*  send data block  *)
begin
pri_data_no:= data1 + data2 - pri_data_no;
uo_act_ref :=: msg;
line_transmit( pri_data_no);
moretime ( mytick);
trans_retry:= 0;      (*  1st try  *)
count ( sendcnt);
state:= wack
end;

2: (*  put block into queue  *)
signal ( msg, outsem.s^);
4: (*  ack x  received  *)
begin
if reccode-2 = pri_data_no then block_ok;
sendlam
end;

5: (*  repeated ack received  *)
begin
if reccode - 2 = pri_data_no then     (*  ok  *)
begin
block_ok;
sendlam;
end  else
reline_transmit;
end;

6: (*  reline_transmit data  *)
reline_transmit;
8: (*  try enq again  *)
begin
line_transmit( enqop);
moretime ( mytick);
 testwrite ( 8, "enq again   ", trans_retry);
trans_retry:= trans_retry+1;
state:= wrep;
end;

9: (*  timeout for ack for a block  *)
begin
book ( mytick);
line_transmit( enqop);
 testwrite ( 8, "enq send    ", trans_retry);
 trans_retry:= trans_retry+1;
state:= wrep;
end;

 
10: (*  timeout for enq  *)
begin
book ( mytick);
line_transmit( enqop);
trans_retry:= trans_retry+1;
testwrite ( 8, "enq timeout ", trans_retry);
end;
 
11: (*  a late timeout   *)
book ( -1);

12:  (*  bell received  *)
  line_transmit( nakop)

 
end (* case *);
\f


if trans_retry > trans_retrymax then                    (*  give up   *)
begin
give_up ( uo_act_ref);
total_errs:= total_errs+trans_retry;
trans_retry:= 0;
state:= idle;
end;
 
if total_errs >= 30000 then total_errs:= 100;

if total_errs mod 100 = 10 then
begin
testout ( z, "transm error",total_errs);
total_errs:= total_errs+1;
end;

end (* primary station *)
else
if event in sec_events then
begin
(*--------  secondary station  --------*)

sec_action := sec_act_table( sec_state, event);

case sec_action of

1: (* line_transmit last receipt *)

line_transmit ( sec_last_rec);

2: (* user input to user *)
   (* line_transmit ack       *)

accept_data;
end;

end
else
begin
(*-----  nonsens  -----*)

end;

until false;
end.
«eof»
DataMuseum.dk

RC3500

⟦bbbf2abfb⟧ TextFileVerbose

Derivation

TextFileVerbose
