|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 108288 (0x1a700)
Types: TextFile
Names: »sncp«
└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system
└─⟦72244f0ef⟧
└─⟦this⟧ »sncp«
process ncp(
var sys_vector: system_vector; (* pointers to input semaphores of system processes *)
var ncp_sem: ! tap_pointer; (* ncp input semaphores *)
var sc_sem: ! tap_pointer; (* sc input semaphore *)
var timeout_sem: ! tap_pointer;(* timeout input semaphore *)
ncp_ident: ! integer); (* ident of the ncp in supervsor message *)
(*******************************************************************)
(* *)
(* ncp *)
(* *)
(* description: *)
(* the ncp (network control probe) performs the routing of *)
(* supervisor messages from the ncc (network control center) to *)
(* the lcp (local control probe). *)
(* *)
(* date init changes *)
(* ------------------------------------------------------------- *)
(* 810218 chh first released version *)
(* 810302 chh sp_head_lgt = 17 *)
(* 810423 chh lcp function: set time inserted. *)
(* timeout's date and time used. *)
(* 810602 chh changes according to the sc interface. *)
(* *)
(*******************************************************************)
const
(**********************************)
(**** configuration values ****)
(**********************************)
version = "vers.810602/";
ncc_port = 1; (* sc port number for ncc *)
ncp_port = 2; (* sc port number for ncp *)
max_lcp = 15; (* max. no. of connected lcp's *)
max_repeat = 4; (* max. no. of repeatable functions *)
nr_event_buf = 3; (* no. of event buffers *)
nr_sup_buf = 5; (* no of supervisor message buffers *)
sc_buf_size = 100; (* no of bytes in a sc buffer *)
rep_buf_size = 100; (* no of bytes in a repeat buffer *)
sc_multi_buf = 2; (* max no of input buffers hanging in sc *)
(****************************)
(**** default values ****)
(****************************)
(***************************)
(**** common values ****)
(***************************)
no_wait = 0;
wait_forever = -1;
first_index = 6 + alfalength;
last_index = first_index + (80 - 1);
(***********************)
(**** u1 values ****)
(***********************)
sc_in = 8 + 1; (* input buffer to sc *)
sc_out = 8 + 2; (* output buffer to sc *)
get_date_time = 8 + 1; (* get date and time from timeout *)
set_date_time = 8 + 2; (* set date and time in timeout *)
(***********************)
(**** u2 values ****)
(***********************)
timeout_ok = 1;
(*********************************)
(**** u4 values (streams) ****)
(*********************************)
event_str = 1; (* event message stream *)
lcp_msg_str = 2; (* lcp message stream *)
sc_input_str = 3; (* sc input stream *)
sc_output_str = 4; (* sc output stream *)
sc_ev_out_str = 5; (* sc output stream for events *)
time_out_str = 6; (* time out stream *)
int_lcp_str = 7; (* internal lcp stream *)
(***********************)
(**** sc values ****)
(***********************)
sc_stack = 1; (* sc stack depth *)
nuid_lgt = 15; (* max. length of nuid *)
ack_req_fac = 1; (* ack req facility *)
sc_type_lgt = 4 + nuid_lgt; (* length of sc_type *)
sc_in_last = 7; (* last in sc input *)
sc_out_last = sc_in_last + sc_type_lgt; (* last in sc output *)
(***************************************)
(**** supervisor message values ****)
(***************************************)
sp_data_size = sup_buf_size - sp_head_lgt - 6; (* max length of supervisor data *)
rep_data_size = rep_buf_size - sp_head_lgt - 6; (* max length of repeat data *)
ind_addr_size = 6; (* length of indirect address field - sc_id_lgt *)
rep_time_lgt = 8; (* no. of significant digits in repeat start time *)
rep_data_lgt = rep_time_lgt div 2 + 2; (* length of repeat data field *)
rep_func_lgt = 4; (* length of repeatable function record *)
(**************************)
(**** event values ****)
(**************************)
ev_connect = 20 + 3; (* event type = lcp connected *)
ev_conn_lgt = 2; (* record length for lcp connected *)
ev_disconnect = 24 + 3; (* event type = lcp disconnected *)
ev_disc_lgt = 4; (* record length for lcp disconnected *)
ev_disc_cause = 1; (* disconnect cause = lcp disconnect message *)
ev_collision = 44 + 3; (* event type = lcp connection collision *)
ev_coll_lgt = 2; (* record length for lcp connection collision *)
ev_lack_res = 8 + 3; (* event type = lack of resources *)
ev_lack_lgt = 2; (* record length for lack of resources *)
ev_lost = 252 + 3; (* event type = events lost *)
ev_lost_lgt = 2; (* record length for events lost *)
(******************************)
(**** lcp table values ****)
(******************************)
free_entry = -1; (* specifies that an entry in lcp table is free *)
ncp_index = 0; (* ncp index in lcp table *)
entry_not_found = -1; (* return parameter from the procedure search_table *)
(**********************************)
(**** lcp operation values ****)
(**********************************)
(* modification in lcp_oper, control *)
set_event_mask = 1; (* set event mask for the ncp *)
set_time = 61; (* set date and time *)
set_event_addr = 62; (* set event address for a specified lcp *)
set_except_addr = 63; (* set exception return address for all supervisor messages *)
(* modification in lcp_oper, sense *)
get_event_mask = 1; (* get event mask for the ncp *)
get_conn_lcp = 2; (* get all connected lcp's *)
get_event_addr = 62; (* get event address for a specified lcp *)
get_except_addr = 63; (* get exception return address for all supervisor messages *)
get_rep_func = 5; (* get repeatable functions *)
(* modification in lcp_oper, get statistics *)
get_lcp_stat = 1; (* get lcp statistics for specified lcp's *)
(* other values *)
reclgt_ev_addr = 4 + sc_type_lgt; (* length of event address record *)
lcp_stat_lgt = 14; (* length of an lcp statistical record *)
ncp_stat_lgt = 12; (* length of an ncp statistical record *)
type
(***************************)
(**** general types ****)
(***************************)
alfa20 = array(1..20) of char;
(************************************)
(**** sc communication types ****)
(************************************)
nuid_type = packed array(1..nuid_lgt) of byte;
sc_comm_type = record
port_no: integer;
ack_req: boolean;
nuid_signf: byte;
nuid: nuid_type;
end;
sc_in_type = record
first, last, next: integer;
local_port: integer;
sen_sc: sc_comm_type;
end;
sc_out_type = record
first, last, next: integer;
local_port: integer;
rec_sc: sc_comm_type;
end;
(**************************************)
(**** supervisor message types ****)
(**************************************)
sup_mess_type = packed record
first, last, next: integer;
sp_head: sp_head_type;
end;
(***********************************)
(**** supervisor data types ****)
(***********************************)
sc_data_type = packed record
port_no: integer;
facility: byte;
nuid_signf: byte;
nuid: nuid_type;
end;
ind_addr_data = packed record
head: sup_mess_type;
sc_addr: sc_data_type;
lcp_ident: lcp_ident_type;
end;
rep_time_type = packed array(1..rep_time_lgt) of time_digit;
rep_data_type = packed array(1..rep_data_size) of byte;
repeat_data = packed record
head: sup_mess_type;
ticks: integer;
start_time: rep_time_type;
sp_data: rep_data_type;
end;
sup_data = packed record
head: sup_mess_type;
sp_data: packed array(1..sp_data_size) of byte;
end;
rep_sup_data = packed record
head: sup_mess_type;
sp_data: rep_data_type;
end;
ev_common_data = packed record
head: sup_mess_type;
ev_type: byte;
bytecount: byte;
end;
ev_conn_data = packed record
common: ev_common_data;
lcp_ident: lcp_ident_type;
end;
ev_lack_data = ev_conn_data;
ev_coll_data = ev_conn_data;
ev_disc_data = packed record
common: ev_common_data;
lcp_ident: lcp_ident_type;
cause: integer;
end;
event_data_type = array(1..5) of integer;
ev_lost_data = packed record
common: ev_common_data;
lost_events: integer;
ev_type: byte;
bytecount: byte;
event_data: event_data_type;
end;
(*************************)
(**** event types ****)
(*************************)
ev_bit_mask = (prod_stat,
?, ?, ?, ?, ?,
lack_of_res, ?, ?, ?, ?,
connection,
disconnection,
collision, ?, ?);
state_type = (unused, used);
wait_ev_type = record
state: state_type;
lost_events: integer;
ev_type: byte;
bytecount: byte;
event_data: event_data_type;
end;
(*****************************)
(**** lcp table types ****)
(*****************************)
ext_sc_type = record
sc_addr: sc_comm_type;
rec_ident: integer;
end;
connect_type = (disconn, conn);
msg_pend_type = (pending, not_pending);
lcp_state = packed record
connect: connect_type;
msg_pending: msg_pend_type;
end;
lcp_stat_type = record
messages: integer;
events: integer;
pending_msg: integer;
lost_msg: integer;
end;
rep_stat_type = record
repeat_opers: integer;
lost_repeat: integer;
end;
lcp_table_elem = record
lcp_ident: integer;
wait_msg_sem: semaphore;
pending_sem: semaphore;
event_sc_addr: ext_sc_type;
state: lcp_state;
lcp_stat: lcp_stat_type;
repeat_stat: rep_stat_type;
end;
lcp_table_type = array(0..max_lcp) of lcp_table_elem;
lcp_index_elem = record
key: integer;
index: integer;
end;
lcp_index_type = array(0..max_lcp) of lcp_index_elem;
(********************************)
(**** repeat table types ****)
(********************************)
repeat_elem = record
state: state_type;
msg: reference;
timeout_ref: reference;
ticks: integer;
end;
rep_table_type = array(1..max_repeat) of repeat_elem;
(*********************************)
(**** lcp operation types ****)
(*********************************)
ext_sc_data_type = packed record
sc_addr: sc_data_type;
rec_ident: lcp_ident_type;
end;
ev_mask_data = packed record
head: sup_mess_type;
update_mask: set of ev_bit_mask;
ev_mask: set of ev_bit_mask;
end;
ev_addr_record = packed record
lcp_ident: lcp_ident_type;
ev_sc_addr: ext_sc_data_type;
end;
exc_addr_data = packed record
head: sup_mess_type;
exc_sc_addr: ext_sc_data_type;
end;
conn_lcp_data = packed record
head: sup_mess_type;
lcp_ident: array(0..max_lcp) of integer;
end;
rep_func_elem = packed record
lcp_ident: integer;
seq_no: byte;
lcp_oper: lcp_oper_type;
end;
rep_func_data = packed record
head: sup_mess_type;
rep_data: array(1..max_repeat) of rep_func_elem;
end;
lcp_stat_data = conn_lcp_data;
ncp_stat_type = packed record
lcp_stat: lcp_stat_type;
repeat_stat: rep_stat_type;
end;
lcp_stat_elem = packed record
lcp_ident: integer;
lcp_stat: lcp_stat_type;
repeat_stat: rep_stat_type;
end;
stat_data = packed record
head: sup_mess_type;
ncp_stat: ncp_stat_type;
lcp_statis: array(0..max_lcp) of lcp_stat_elem;
end;
(*************************)
(**** other types ****)
(*************************)
oper_type = record
first, last, next: integer;
name: alfa;
data: array(first_index..last_index) of char;
end;
timeout_type = record
index,
count,
object: integer;
end;
object_type = record
object: integer;
end;
date_time_type = record
first, last, next: integer;
year: array(1..2) of byte;
dummy1: byte;
month: array(1..2) of byte;
dummy2: byte;
day: array(1..2) of byte;
dummy3: array(1..2) of byte;
hour: array(1..2) of byte;
dummy4: byte;
minute: array(1..2) of byte;
dummy5: byte;
second: array(1..2) of byte;
end;
const
(****************************)
(**** default values ****)
(****************************)
event_addr = ext_sc_type(
sc_comm_type(
ncc_port, (* event port number *)
true, (* event facilities *)
15, (* event nuid length *)
nuid_type(
15 *** 0)), (* event nuid *)
0); (* event receiver_id *)
exception_addr = event_addr;
(**************************)
(**** other values ****)
(**************************)
time_0 = rep_time_type(rep_time_lgt *** 0);
sp_type_0 = sp_type_type(req, mess, no_ncp_cntr, start_rep, no_reject, no_reset_stat, ?, ?);
var
(************************)
(**** semaphores ****)
(************************)
wait_ev_buf_sem: semaphore;
oper_sem: semaphore;
help_sem: semaphore;
(************************)
(**** references ****)
(************************)
msg: reference;
event_ref: reference;
msg_ref: reference;
sc_msg: reference;
oper_ref: reference;
work_ref: reference;
(*******************)
(**** pools ****)
(*******************)
event_buf_pool: pool nr_event_buf of packed array(1..event_buf_size) of byte;
sup_mess_pool: pool nr_sup_buf of sup_data;
sc_mess_pool: pool nr_sup_buf + nr_event_buf + max_repeat of packed array(1..sc_buf_size) of byte;
repeat_pool: pool max_repeat of packed array(1..rep_buf_size) of byte;
timeout_pool: pool 2 * max_repeat + 1 of timeout_type;
oper_pool: pool 1 of oper_type;
work_pool: pool 1 of sup_data;
(****************************)
(**** pool variables ****)
(****************************)
act_nr_event_buf: integer:= nr_event_buf;
act_nr_sup_buf: integer:= nr_sup_buf;
(****************************************)
(**** sc communication variables ****)
(****************************************)
act_sc_input: integer:= 0; (* actual no of input buffers in sc *)
except_addr: ext_sc_type:= exception_addr;
(******************************************)
(**** supervisor message variables ****)
(******************************************)
act_seq_no: integer:= 0;
ncp_contr: ncp_cntr_type;
repeat_func: rep_func_type;
stat_control: stat_cntr_type;
basic_oper: basic_type;
modif_oper: integer;
sup_status: set of sp_status_bit;
sc_data_var: sc_data_type;
ind_addr_lgt: integer;
ind_rec: boolean;
ind_sen: boolean;
(*****************************)
(**** event variables ****)
(*****************************)
waiting_event: wait_ev_type:= wait_ev_type(unused, 0, 0, 0, event_data_type(5 *** 0));
event_mask: set of ev_bit_mask:= (.prod_stat, lack_of_res, connection, disconnection, collision.);
full_mask: set of ev_bit_mask:= (.prod_stat, lack_of_res, connection, disconnection, collision.);
(*********************************)
(**** lcp table variables ****)
(*********************************)
lcp_table: lcp_table_type:=
lcp_table_type(
lcp_table_elem(
?, (* ident of the lcp in the ncp *)
?, (* semaphore for wait message *)
?, (* semaphore for pending messages *)
event_addr, (* address of event reporting *)
lcp_state( (* actual state of the lcp *)
conn, (* ncp connected *)
not_pending), (* no message pending *)
lcp_stat_type( (* lcp statistics *)
0, (* messages *)
0, (* events *)
0, (* pending messages *)
0), (* lost messages *)
rep_stat_type( (* repeat statistics *)
0, (* repeat operations *)
0)), (* lost repeat operations *)
max_lcp *** (* initialize rest of lcp table *)
lcp_table_elem(
free_entry, (* specifies that the entry is free *)
?, (* semaphore for wait message *)
?, (* semaphore for pending messages *)
event_addr, (* address of event reporting *)
lcp_state( (* actual state of the lcp *)
disconn, (* disconnected *)
not_pending), (* no message pending *)
lcp_stat_type( (* lcp statistics *)
0, (* messages *)
0, (* events *)
0, (* pending messages *)
0), (* lost messages *)
rep_stat_type( (* repeat statistics *)
0, (* repeat operations *)
0))); (* lost repeat operations *)
lcp_index_table: lcp_index_type:=
lcp_index_type(
lcp_index_elem(
?,0), (* first entry is ncp *)
max_lcp *** (* initialize rest of table *)
lcp_index_elem(
free_entry, ?)); (* free entries *)
index: integer; (* actual index in lcp_table *)
act_lcp_ident: integer; (* actual lcp ident *)
first_free: integer:= 1; (* points to the first free entry in lcp_table *)
act_nr_lcp: integer:= 0; (* actual number of connected lcp's *)
(************************************)
(**** repeat table variables ****)
(************************************)
repeat_table: rep_table_type:=
rep_table_type(max_repeat *** repeat_elem(unused, ?, ?, ?));
rep_index: integer;
first_free_rep: integer:= 1;
(*****************************)
(**** other variables ****)
(*****************************)
name: alfa;
z: zone;
continue: boolean;
count: integer;
index_to, index_from: integer;
help_int: integer;
ncp_stat: ncp_stat_type:= ncp_stat_type(
lcp_stat_type(0, 0, 0, 0),
rep_stat_type(0, 0));
(**********************)
(* *)
(* procedures *)
(* *)
(**********************)
procedure timerbook(var local_msg: reference;
var local_timer_msg: reference;
local_ticks: ! integer;
local_obj: ! integer;
var local_timeout_sem: semaphore;
var local_answer: semaphore);
external;
procedure timerupdate(var local_msg: reference;
local_ticks: ! integer;
var local_timeout_sem: semaphore;
var local_answer: semaphore);
external;
procedure outchar(ch: char);
(*********************************************************************)
(* *)
(* outchar *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* ch: the character that is to be put into the operator output *)
(* buffer (call parameter). *)
(* call of other procedures: none. *)
(* use of global variables: oper_ref *)
(* waiting points: none. *)
(* function: the procedure puts the character in ch into the *)
(* operator output buffer. *)
(* *)
(*********************************************************************)
begin
lock oper_ref as opdata: oper_type do
with opdata do
begin
last:= last + 1;
data(last):= ch;
end; (* with opdata and lock oper_ref *)
end; (* outchar *)
procedure outstring20(local_text: alfa20; local_lgt: ! integer);
(*******************************************************************)
(* *)
(* outstring20 *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* local_text: contains the text string that is to be put into *)
(* the operator output buffer (call parameter). *)
(* local_lgt: the number of characters that is put into the *)
(* operator output buffer (call parameter). *)
(* call of other procedures: outchar. *)
(* use of global variables: none. *)
(* waiting points: none. *)
(* function: the procedure puts the specified number of characters *)
(* into the operator output buffer. *)
(* *)
(*******************************************************************)
var
i: integer;
begin
for i:= 1 to local_lgt do
outchar(local_text(i));
end; (* outstring20 *)
procedure outinteger(int: integer);
(*******************************************************************)
(* *)
(* outinteger *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* int: an integer that is converted to a decimal ascii string. *)
(* at return it is undefined (call parameter). *)
(* call of other procedures: outchar. *)
(* use of global variables: none. *)
(* waiting points: none. *)
(* function: the procedure converts an integer to a decimal ascii *)
(* string of length 6. *)
(* *)
(*******************************************************************)
const
maxpos = 6;
var
i: integer;
digits: array(1..maxpos) of char;
begin
for i:= 1 to maxpos do
digits(i):= sp;
i:= maxpos;
repeat
digits(i):= chr(abs(int mod 10) + ord("0"));
int:= int div 10;
i:= i - 1;
until (i = 1) or (int = 0);
for i:= 1 to maxpos do
outchar(digits(i));
end; (* outinteger *)
procedure ncp_error(local_index, local_error: integer);
(********************************************************************)
(* *)
(* ncp_error *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* local_index: index in the lcp_table (call parameter). *)
(* local_error: an error number that indicates, where in the ncp *)
(* module the error has occured (call parameter). *)
(* call of other procedures: outchar, outinteger, outstring20. *)
(* use of global variables: oper_ref, oper_sem. *)
(* waiting points: yes. *)
(* function: the procedure writes a short error message on the *)
(* operator console. *)
(* *)
(********************************************************************)
const
text1 = "*** ncp error lcp =";
textlgt1 = 20;
text2 = " none ";
textlgt2 = 6;
text3 = " error no. = ";
textlgt3 = 16;
text4 = " ncp ";
textlgt4 = 6;
ncp_name = "ncp ";
var
i: integer;
text: alfa20;
begin
wait(oper_ref, oper_sem);
oper_ref^.u1:= 2;
oper_ref^.u2:= 7;
lock oper_ref as opdata: oper_type do
with opdata do
begin
first:= first_index;
name:= ncp_name;
last:= first_index - 1;
end; (* with opdata and lock oper_ref *)
outstring20(text1, textlgt1);
case local_index of
ncp_index:
outstring20(text4, textlgt4);
entry_not_found:
outstring20(text2, textlgt2);
otherwise (* not ncp_index or entry_not_found *)
if local_index <= max_lcp then
outinteger(lcp_table(local_index).lcp_ident)
else (* local_index > max_lcp *)
outstring20(text2, textlgt2);
end; (* case local_index *)
outstring20(text3, textlgt3);
outinteger(local_error);
outchar(nl);
signal(oper_ref, sys_vector(operatorsem)^);
end; (* ncp_error *)
procedure get_event_buf(rec_ident, waittime: integer;
var event_buf: reference);
(*******************************************************************)
(* *)
(* get_event_buf *)
(* *)
(* internal ncp procedure *)
(* parameters: *)
(* rec_ident: will be placed in the receiver_id field in the *)
(* supervisor head in the event buffer (call parameter). *)
(* waittime: specifies if a buffer should be waited for or not *)
(* if there are no free buffers (call parameter). *)
(* event_buf: if there is a free event buffer, then this *)
(* parameter will contain the reference to the buffer (return *)
(* parameter). *)
(* call of other procedures: none. *)
(* use of global variables: act_nr_event_buf, event_buf_pool, *)
(* ncp_sem, act_seq_no, msg, wait_ev_buf_sem. *)
(* waiting points: none. *)
(* function: if there are any free event buffers, then event_buf *)
(* will point to this buffer. the event buffer, including the *)
(* u-fields, are fully initialized. *)
(* if there are no free buffers then the action depends on *)
(* waittime. *)
(* if waittime = no_wait then the procedure returns with *)
(* event_buf = nil. *)
(* if waittime = wait_forever then msg will be signalled to *)
(* the semaphore: wait_ev_buf_sem, and the procedure returns *)
(* with event_buf = nil. *)
(* *)
(*******************************************************************)
begin
if act_nr_event_buf > 0 then
(*---------------------------*)
(* free event buffer *)
(*---------------------------*)
begin
act_nr_event_buf:= act_nr_event_buf - 1;
alloc(event_buf, event_buf_pool, ncp_sem.s^);
lock event_buf as data: sup_mess_type do
with data do
begin (* initialize the event buffer *)
first:= 6;
last:= event_buf_size - 1;
next:= 6;
with sp_head do
begin
receiver_id.i:= 0;
receiver_id.id:= rec_ident;
sender_id.i:= 0;
seq_no:= act_seq_no;
act_seq_no:= (act_seq_no + 1) mod 256;
sp_type:= sp_type_0;
sp_type.mess_ev:= event;
lcp_oper.modif:= 0;
lcp_oper.basic:= lcp_event;
status:= (..);
bytecount:= 0;
end; (* with sp_head *)
end; (* with data and lock *)
event_buf^.u4:= event_str;
if rec_ident = ncp_ident then
begin
event_buf^.u1:= req_event_buf + 3;
event_buf^.u2:= ok;
event_buf^.u3:= ncp_index;
end (* if rec_ident = ncp_ident *)
else (* rec_ident <> ncp_ident *)
begin
event_buf^.u1:= msg^.u1 + 3;
event_buf^.u2:= message;
event_buf^.u3:= msg^.u3;
end; (* else rec_ident <> ncp_ident *)
end (* if act_nr_event_buf *)
else (* act_nr_event_buf <= 0 *)
(*------------------------------*)
(* no free event buffer *)
(*------------------------------*)
begin
case waittime of
no_wait: (* do not wait for a free buffer *)
if rec_ident <> ncp_ident then
begin
msg^.u2:= busy;
return(msg);
end; (* if rec_ident <> ncp_ident *)
wait_forever: (* wait for a free buffer *)
if rec_ident <> ncp_ident then
signal(msg, wait_ev_buf_sem);
otherwise
end; (* case waittime *)
end; (* else act_nr_event_buf *)
end; (* get_event_buf *)
procedure send_event( event_type: integer);
(**********************************************************************)
(* *)
(* send_event *)
(* *)
(* internal ncp procedure *)
(* parameters: *)
(* event_type: specifies the event type and thereby the record *)
(* format (call parameter). *)
(* call of other procedures: get_event_buf. *)
(* use of global variables: event_ref, msg, waiting_event, *)
(* act_lcp_ident. *)
(* waiting points: none. *)
(* function: if there are any free event buffers, then this procedure *)
(* will create an event report and signal this to the ncp_sem *)
(* if there are no free event buffers, then it will either save the *)
(* event report in the variable: waiting_event or, if there is *)
(* already one saved, then it will increase the variable: *)
(* waiting_event.lost_events. *)
(* *)
(**********************************************************************)
begin
get_event_buf(ncp_ident, no_wait, event_ref);
if not nil(event_ref) then
(*---------------------------*)
(* free event buffer *)
(*---------------------------*)
begin
case event_type of
ev_lack_res, ev_connect, ev_collision:
lock event_ref as data: ev_conn_data do
with data do
begin
common.head.sp_head.bytecount:= 2 + ev_conn_lgt;
common.bytecount:= ev_conn_lgt;
lcp_ident.i:= 0;
lcp_ident.id:= act_lcp_ident;
end; (* with data and lock event_ref *)
ev_disconnect:
lock event_ref as data: ev_disc_data do
with data do
begin
common.head.sp_head.bytecount:= 2 + ev_disc_lgt;
common.bytecount:= ev_disc_lgt;
lcp_ident.i:= 0;
lcp_ident.id:= act_lcp_ident;
cause:= ev_disc_cause;
end; (* with data and lock event_ref *)
ev_lost:
begin
lock event_ref as data: ev_lost_data do
with data do
begin
common.bytecount:= ev_lost_lgt;
lost_events:= waiting_event.lost_events;
ev_type:= waiting_event.ev_type;
bytecount:= waiting_event.bytecount;
event_data:= waiting_event.event_data;
common.head.sp_head.bytecount:= 4 + common.bytecount + bytecount;
end; (* with data and lock event_ref *)
waiting_event.state:= unused;
end; (* ev_lost *)
otherwise
end; (* case event_type *)
lock event_ref as data: ev_common_data do
with data do
begin
head.last:= 5 + sp_head_lgt + head.sp_head.bytecount;
ev_type:= event_type;
end; (* with data and lock event_ref *)
return(event_ref);
end (* if not nil(event_ref) *)
else (* nil(event_ref) *)
(*------------------------------*)
(* no free event buffer *)
(*------------------------------*)
begin
case waiting_event.state of
unused:
with waiting_event do
begin
state:= used;
lost_events:= 0;
ev_type:= event_type;
case event_type of
ev_lack_res, ev_connect, ev_collision:
begin
bytecount:= ev_conn_lgt;
event_data(1):= act_lcp_ident;
end; (* ev_connect, ev_regret *)
ev_disconnect:
begin
bytecount:= ev_disc_lgt;
event_data(1):= act_lcp_ident;
event_data(2):= ev_disc_cause;
end; (* ev_disconnect *)
otherwise
end; (* case event_type *)
end; (* with waiting_event *)
used:
waiting_event.lost_events:=waiting_event.lost_events + 1;
end; (* case waiting_event.state *)
end; (* else nil(event_ref) *)
end; (* send_event *)
function check_index(local_index: ! integer): boolean;
(**********************************************************************)
(* *)
(* check_index *)
(* *)
(* internal ncp function. *)
(* parameters: *)
(* local_index: index in the lcp_table (call parameter). *)
(* call of other procedures: none. *)
(* use of global variables: lcp_table. *)
(* waiting points: none. *)
(* function: the procedure checks if the index is legal. i.e. that *)
(* the index is within the limits of the table and that the index *)
(* points to an element that is in use (the lcp is connected). *)
(* *)
(**********************************************************************)
begin
if local_index <= max_lcp then
if lcp_table(local_index).state.connect = conn then
check_index:= true
else
check_index:= false
else (* local_index > max_lcp *)
check_index:= false;
end; (* check_index *)
procedure update_sp_head(var local_msg: ! reference);
(***********************************************************************)
(* *)
(* update_sp_head *)
(* *)
(* internal ncp procedure *)
(* parameters: *)
(* local_msg: reference to the supervisor message that should be *)
(* updated (call parameter). *)
(* call of other procedures: none. *)
(* use of global variables: help_sem, work_ref. *)
(* waiting points: yes, one *)
(* function: the procedure swappes sender_id and receiver_id, sets the *)
(* time in the supervisor head, and updates last. *)
(* *)
(***********************************************************************)
var
local_ident: lcp_ident_type;
begin
lock local_msg as data: sup_mess_type do
begin
data.last:= 5 + sp_head_lgt + data.sp_head.bytecount;
with data.sp_head do
begin
(* swap sender_id and receiver_id *)
local_ident:= receiver_id;
receiver_id:= sender_id;
sender_id:= local_ident;
sp_type.req_ans:= ans;
lock work_ref as workdata: sup_data do
with workdata.head do
begin
first:= 6;
last:= first + 17;
next:= last + 1;
end; (* with workdata.head and lock work_ref *)
work_ref^.u1:= get_date_time;
work_ref^.u2:= message;
signal(work_ref, timeout_sem.s^);
wait(work_ref, help_sem);
lock work_ref as workdata: date_time_type do
with workdata do
begin
time(1):= second(1) mod 16;
time(2):= second(2) mod 16;
time(3):= minute(1) mod 16;
time(4):= minute(2) mod 16;
time(5):= hour(1) mod 16;
time(6):= hour(2) mod 16;
time(7):= day(1) mod 16;
time(8):= day(2) mod 16;
time(9):= month(1) mod 16;
time(10):= month(2) mod 16;
time(11):= year(1) mod 16;
time(12):= year(2) mod 16;
end; (* with workdata and lock work_ref *)
end; (* with data.sp_head *)
end; (* lock local_msg *)
end; (* update_sp_head *)
procedure exchange_stack(var local_msg: reference);
(************************************************************************)
(* *)
(* exchange_stack *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* local_msg: reference to top message of a stack. at return it is a *)
(* reference to the new top message or nil if not a stack (call *)
(* and return parameter). *)
(* call of other procedures: none. *)
(* call of global variables: none. *)
(* waiting points: none. *)
(* function: the procedure exchanges the first (top message) and the *)
(* second messages in the stack. if no second stack element exist, *)
(* then the top message is released, and local_msg is nil at return. *)
(* *)
(************************************************************************)
var
local_ref: reference;
begin
pop(local_ref, local_msg);
if not nil(local_msg) then
push(local_msg, local_ref)
else
release(local_ref);
local_msg:=: local_ref;
end; (* exchange_stack *)
procedure release_event(var local_msg: reference;
local_index: ! integer);
(********************************************************************)
(* *)
(* release_event *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* local_msg: reference to an event buffer that is released. *)
(* (call parameter). *)
(* local_index: index in the lcp_table (call parameter). *)
(* call of other procedures: get_event_buf. *)
(* use of global variables: act_nr_event_buf. *)
(* waiting points: none. *)
(* function: releases an event buffer. if any 'request event *)
(* buffer' messages, then the first of these is answered. *)
(* act_nr_event_buf is updated. *)
(* *)
(********************************************************************)
var
local_event_ref: reference;
local_inx: integer;
local_lcp_ident: integer;
begin
if not ownertest(event_buf_pool, local_msg) then
ncp_error(local_index, 1101); (**** error 1101 ****)
release(local_msg);
act_nr_event_buf:= act_nr_event_buf + 1;
sensesem(local_msg, wait_ev_buf_sem);
if not nil(local_msg) then
begin (* a 'request event buf' message is hanging *)
local_inx:= local_msg^.u3;
local_lcp_ident:= lcp_table(local_inx).lcp_ident;
get_event_buf(local_lcp_ident, wait_forever, local_event_ref);
if not nil(local_event_ref) then
begin (* a free buffer is available *)
push(local_msg, local_event_ref);
local_event_ref^.u2:= ok;
return(local_event_ref);
end; (* if not nil(local_event_ref) *)
end (* if not nil(local_msg) *)
else (* not nil(local_msg) *)
if waiting_event.state = used then
if lack_of_res in event_mask then
send_event(ev_lost)
else (* not(lack_of_res in event_mask) *)
waiting_event.state:= unused;
end; (* release_event *)
procedure send_sc(var local_msg: reference;
local_event: ! boolean);
(*********************************************************************)
(* *)
(* send_sc *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* local_msg: reference to a message that is signalled to sc. *)
(* nil at return (call parameter). *)
(* local_event: specifies if the buffer is an event buffer (true) *)
(* or a supervisor buffer (false) (call parameter). *)
(* call of other procedures: none. *)
(* use of global variables: sc_sem. *)
(* waiting points: none. *)
(* function: the u-fields in the message are updated, and the *)
(* message is signalled to sc. *)
(* *)
(*********************************************************************)
begin
with local_msg^ do
begin
u1:= sc_out;
u2:= message;
u3:= sc_stack;
if local_event then
u4:= sc_ev_out_str
else
u4:= sc_output_str;
end; (* with local_msg *)
signal(local_msg, sc_sem.s^);
end; (* send_sc *)
procedure receive_sc;
(*********************************************************************)
(* *)
(* receive_sc *)
(* *)
(* internal ncp procedure. *)
(* parameters: none *)
(* call of other procedures: none. *)
(* use of global variables: act_nr_sup_buf, act_sc_input. *)
(* waiting points: none. *)
(* function: sends as many input buffers to sc as allowed. updates *)
(* act_nr_sup_buf and act_sc_input. *)
(* *)
(*********************************************************************)
var
local_msg: reference;
local_sc_msg: reference;
begin
while (act_sc_input < sc_multi_buf) and (act_nr_sup_buf >= 1) do
begin
alloc(local_sc_msg, sc_mess_pool, ncp_sem.s^);
lock local_sc_msg as scdata: sc_in_type do
with scdata do
begin
first:= 6;
last:= sc_buf_size - 1;
next:= 6;
local_port:= ncp_port;
end; (* with scdata and lock local_sc_msg *)
with local_sc_msg^ do
begin
u1:= sc_in;
u2:= message;
u3:= sc_stack;
u4:= sc_input_str;
end; (* with local_sc_msg^ *)
alloc(local_msg, sup_mess_pool, ncp_sem.s^);
act_nr_sup_buf:= act_nr_sup_buf - 1;
lock local_msg as data: sup_mess_type do
with data do
begin
first:= 6;
last:= sup_buf_size - 1;
next:= 6;
end; (* with data and lock local_msg *)
push(local_sc_msg, local_msg);
signal(local_msg, sc_sem.s^);
act_sc_input:= act_sc_input + 1;
end; (* while (act_sc_input < sc_multi_buf) and .... *)
end; (* receive_sc *)
procedure release_sup(var local_msg: reference;
local_index: ! integer);
(*********************************************************************)
(* *)
(* release_sup *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* local_msg: reference to a supervisor message buffer that is *)
(* released. it is nil at return (call parameter). *)
(* local_index: index in the lcp_table (call parameter). *)
(* call of other procedures: receive_sc, ncp_error. *)
(* use of global variables: act_nr_sup_buf . *)
(* waiting points: none. *)
(* function: releases a supervisor message buffer and a sc message *)
(* buffer, if any. it updates act_nr_sup_buf and sends input *)
(* buffers to sc if allowed. *)
(* *)
(*********************************************************************)
var
local_ref: reference;
begin
pop(local_ref, local_msg);
if not nil(local_msg) then
begin
if not ownertest(sc_mess_pool, local_msg) then
ncp_error(local_index, 1131); (**** error 1131 ****)
release(local_msg); (* release sc message buffer *)
end;
if not ownertest(sup_mess_pool, local_ref) then
ncp_error(local_index, 1132); (**** error 1132 ****)
release(local_ref); (* release supervisor message buffer *)
act_nr_sup_buf:= act_nr_sup_buf + 1;
receive_sc;
end; (* release_sup *)
procedure release_sc(var local_msg: reference;
local_index: ! integer;
local_event: ! boolean);
(*********************************************************************)
(* *)
(* release_sc *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* local_msg: reference to an sc message buffer that is to be *)
(* released. it is nil at return (call parameter). *)
(* local_index: index in the lcp_table (call parameter). *)
(* local_event: specifies if the buffer is an event buffer (true) *)
(* or a supervisor buffer (false) (call parameter). *)
(* call of other procedures: release_event, release_sup, ncp_error. *)
(* use of global variables: none. *)
(* waiting points: none. *)
(* function: releases an sc message buffer and a supervisor or an *)
(* event buffer, if any. dependent on local_event, then it *)
(* calls release_event or release_sup. *)
(* *)
(*********************************************************************)
var
local_ref: reference;
begin
pop(local_ref, local_msg);
if not ownertest(sc_mess_pool, local_ref) then
ncp_error(local_index, 1141); (**** error 1141 ****)
release(local_ref); (* release sc message buffer *)
if not nil(local_msg) then
if local_event then
release_event(local_msg, local_index)
else (* not local__event *)
release_sup(local_msg, local_index);
end; (* release_sc *)
procedure release_rep(local_rep_index: ! integer;
local_index: ! integer);
(*********************************************************************)
(* *)
(* release_rep *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* local_rep_index: index in the repeat_table (call parameter). *)
(* local_index: index in the lcp_table (call parameter). *)
(* call of other procedures: timerupdate. *)
(* use of global variables: repeat_table, timeout_sem, lcp_table, *)
(* ncp_stat, help_sem. *)
(* waiting points: yes, one in timerupdate. *)
(* function: releases the messages that is used by repeatable *)
(* functions. it updates the statistical records, concerning *)
(* repeatable functions. *)
(* *)
(*********************************************************************)
var
local_ref: reference;
begin
pop(local_ref, repeat_table(local_rep_index).msg);
release(local_ref);
release(repeat_table(local_rep_index).msg);
timerupdate(repeat_table(local_rep_index).timeout_ref, 0, timeout_sem.s^, help_sem);
release(repeat_table(local_rep_index).timeout_ref);
lcp_table(local_index).repeat_stat.repeat_opers:=
lcp_table(local_index).repeat_stat.repeat_opers - 1;
ncp_stat.repeat_stat.repeat_opers:=
ncp_stat.repeat_stat.repeat_opers - 1;
end; (* release_rep *)
procedure return_sup(var local_msg: reference;
local_status: ! set of sp_status_bit;
local_index: ! integer);
(**********************************************************************)
(* *)
(* return_sup *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* local_msg: reference to top message of a stack. the stack *)
(* consists of a supervisor message (top) and an sc message. it *)
(* is nil at return (call and return parameter). *)
(* local_status: the status mask that is to be inserted into the *)
(* status field of the supervisor head (call parameter). *)
(* local_index: index in the lcp_table (call parameter). *)
(* call of other procedures: update_sp_head, exchange_stack, send_sc, *)
(* release_sup. *)
(* use of global variables: none. *)
(* waiting points: none. *)
(* function: the procedure inserts local_status into the status field *)
(* of the supervisor head. dependent on the reject parameter in the *)
(* type field of the supervisor head the procedure sends the *)
(* supervisor message to the sc or the buffers are released. *)
(* *)
(**********************************************************************)
var
local_rej_func: rej_func_type;
begin
lock local_msg as data: sup_mess_type do
begin
data.sp_head.status:= data.sp_head.status + local_status;
local_rej_func:= data.sp_head.sp_type.rej_func;
end; (* lock local_msg *)
case local_rej_func of
no_reject:
begin
update_sp_head(local_msg);
exchange_stack(local_msg);
if not nil(local_msg) then
begin (* stack ok *)
lock local_msg as scdata: sc_out_type do
scdata.first:= 6;
send_sc(local_msg, false);
end (* if not nil(local_msg) *)
else (* nil(local_msg) *)
ncp_error(local_index, 1151); (**** error 1151 ****)
end; (* no_reject *)
reject:
release_sup(local_msg, local_index);
end; (* case local_rej_func *)
end; (* return_sup *)
procedure send_lcp_sup(var local_lcp_msg: reference;
var local_msg: reference;
local_index: ! integer);
(**********************************************************************)
(* *)
(* send_lcp_sup *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* local_lcp_msg: reference to a 'wait message' message from the *)
(* lcp. it is nil at return (call parameter). *)
(* local_msg: reference to a supervisor message buffer that is *)
(* updated. it is nil at return (call parameter). *)
(* local_index: index in the lcp_table (call parameter). *)
(* call of other procedures: none. *)
(* use of global variables: lcp_table. *)
(* waiting points: none. *)
(* function: updates the u-fields in the messages referred by *)
(* local_msg and local_lcp_msg. stacks these messages and returns *)
(* the resulting message to lcp. both references are nil at return. *)
(* it updates lcp statistics. *)
(* *)
(**********************************************************************)
begin
with local_msg^ do
begin
u1:= sup_mess_buf;
u2:= message;
u3:= local_index;
u4:= lcp_msg_str;
end; (* with local_msg *)
local_lcp_msg^.u2:= ok;
push(local_lcp_msg, local_msg);
return(local_msg);
if prod_stat in event_mask then
begin
inc15(lcp_table(local_index).lcp_stat.messages);
inc15(ncp_stat.lcp_stat.messages);
end; (* if prod_stat in event_mask *)
end; (* send_lcp_sup *)
procedure send_int_lcp(var local_msg: reference);
(*********************************************************************)
(* *)
(* send_int_lcp *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* local_msg: reference to a supervisor message that is sent to *)
(* the internal lcp in ncp. it is nil at return (call parameter).*)
(* call of other procedures: inc15. *)
(* use of global variables: lcp_table. *)
(* waiting points: none. *)
(* function: the procedure updates the u-fields in the message, *)
(* referred by local_msg and returns the message. *)
(* it updates ncp statistics. *)
(* *)
(*********************************************************************)
begin
with local_msg^ do
begin
u2:= ok;
u3:= ncp_index;
u4:= int_lcp_str;
end; (* with local_msg^ *)
return(local_msg);
if prod_stat in event_mask then
begin
inc15(lcp_table(ncp_index).lcp_stat.messages);
inc15(ncp_stat.lcp_stat.messages);
end; (* if prod_stat in event_mask *)
end; (* send_int_lcp *)
function search_table(local_key: ! integer;
var local_index: integer;
local_top: ! integer;
local_bottom: ! integer;
var local_table: lcp_index_type): boolean;
(***********************************************************************)
(* *)
(* search_table *)
(* *)
(* internal ncp function . *)
(* parameters: *)
(* local_key: the key that is searched for (call parameter). *)
(* local_index: the index in the local_table, where local_key *)
(* is found. it is unchanged, if local_key is not found (return *)
(* parameter). *)
(* local_top: first element in local_table (call parameter). *)
(* local_bottom: last element in local_table (call parameter). *)
(* local_table: specifies the actual index table that is used (call *)
(* parameter). *)
(* call of other procedures: none. *)
(* use of global variables: none. *)
(* waiting points: none. *)
(* function: search the local_table for an element with *)
(* local_key as key. local_index returns with the index in *)
(* local_table, if the element is found, else it is unchanged. *)
(* search_table is true if the element is found else false. *)
(* *)
(***********************************************************************)
var
top, bottom, middle: integer;
begin
if local_bottom >= local_top then
begin (* local_table is not empty *)
top:= local_top;
bottom:= local_bottom;
repeat
middle:= (top + bottom) div 2;
if local_key > local_table(middle).key then
top:= middle + 1
else
bottom:= middle - 1;
until (local_key = local_table(middle).key) or (top > bottom);
if local_key = local_table(middle).key then
begin
local_index:= middle;
search_table:= true;
end (* if local_key = local_table(middle).key *)
else (* local_key <> local_table(middle).key *)
search_table:= false;
end (* if local_bottom >= local_top *)
else (* local_bottom < local_top *)
search_table:= false;
end; (* search_table *)
function insert_table(local_key: ! integer;
var local_index: integer;
local_top: ! integer;
var local_bottom: integer;
var local_table: lcp_index_type): boolean;
(*********************************************************************)
(* *)
(* insert_table *)
(* *)
(* internal ncp function. *)
(* parameters: *)
(* local_key: the key of the element that is to be inserted in *)
(* the ordered local_table (call parameter). *)
(* local_index: second part of the element that is to be inserted *)
(* in the local_table. if the element is inserted, then *)
(* local_index is unchanged at return. if the element is not *)
(* inserted, then local_index returns with the index in the *)
(* local_table, where the element already exist (call and return *)
(* parameter). *)
(* local_top: first element in local_table (call parameter). *)
(* local_bottom: last element in local_table. if element is *)
(* inserted, then local_bottom is incremented (call and return *)
(* parameter). *)
(* local_table: specifies the actual index table that is used *)
(* (call and return parameter). *)
(* call of other procedures: search_table. *)
(* use of global variables: none. *)
(* waiting points: none. *)
(* function: the function inserts the element that consists of *)
(* local_key and local_index in the ordered local_table. *)
(* local_key is the key. if the element is not already present *)
(* in the table then insert_table is true, else it is false, and *)
(* the element is not inserted. *)
(* *)
(*********************************************************************)
var
destination, source: integer;
local_inx: integer;
local_cont: boolean:= true;
begin
if not search_table(local_key, local_inx, local_top, local_bottom, local_table) then
begin (* element is not already in the table *)
source:= local_bottom;
local_bottom:= local_bottom + 1;
destination:= local_bottom;
if local_bottom > local_top then
while local_cont do
if source < local_top then
local_cont:= false
else (* source >= local_top *)
if local_table(source).key > local_key then
begin
local_table(destination):=local_table(source);
destination:= destination - 1;
source:= source - 1;
end (* if local_table(source).key > local_key *)
else (* local_table(source).key <= local_key *)
local_cont:= false;
local_table(destination).key:= local_key;
local_table(destination).index:= local_index;
insert_table:= true;
end (* if not search_table(local_key, .... ) *)
else (* search_table(local_key, .... ) *)
begin (* element is already in the table *)
local_index:= local_inx;
insert_table:= false;
end; (* else search_table(local_key, .... ) *)
end; (* insert_table *)
function remove_table(local_key: ! integer;
var local_index: integer;
local_top: ! integer;
var local_bottom: integer;
var local_table: lcp_index_type): boolean;
(********************************************************************)
(* *)
(* remove_table *)
(* *)
(* internal ncp function. *)
(* parameters: *)
(* local_key: the key of the element that is to be removed from *)
(* the ordered local_table (call parameter). *)
(* local_index: second part of the element that is removed from *)
(* local_table. it is unchanged, if the element is not found *)
(* (return parameter). *)
(* local_top: first element in local_table (call parameter). *)
(* local_bottom: last element in local_table. if the specified *)
(* element is removed, then local_bottom is decremented (call *)
(* and return parameter). *)
(* local_table: specifies the actual index table that is used *)
(* (call and return parameter). *)
(* call of other procedures: search_table. *)
(* use of global variables: none. *)
(* waiting points: none. *)
(* function: the function removes the element pointed out by *)
(* local_key from the local_table. if the element is found *)
(* then remove_table is true else remove_table is false at *)
(* return. *)
(* *)
(********************************************************************)
var
destination, source: integer;
begin
if search_table(local_key, destination, local_top, local_bottom, local_table) then
begin (* element is in the table *)
local_index:= local_table(destination).index;
source:= destination + 1;
while source <= local_bottom do
begin
local_table(destination):= local_table(source);
destination:= destination + 1;
source:= source + 1;
end; (* while source <= local_bottom *)
local_bottom:= local_bottom - 1;
remove_table:= true;
end (* if search_table(local_key, .... ) *)
else (* not search_table(local_key, .... ) *)
remove_table:= false;
end; (* remove_table *)
procedure sc_data_to_comm(var local_from: ! sc_data_type;
var local_to: sc_comm_type);
(*********************************************************************)
(* *)
(* sc_data_to_comm *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* local_from: specifies the data that is to be copied (call *)
(* parameter). *)
(* local_to: specifies the data area that data is copied into *)
(* (return parameter). *)
(* call of other procedures: none. *)
(* use of global variables: none. *)
(* waiting points: none. *)
(* function: converts the sc address (in supervisor data) specified *)
(* by local_from into the sc address (in sc communication format) *)
(* specified by local_to. *)
(* *)
(*********************************************************************)
begin
local_to.port_no:= local_from.port_no;
if (local_from.facility mod 2) = ack_req_fac then
local_to.ack_req:= true
else
local_to.ack_req:= false;
local_to.nuid_signf:= local_from.nuid_signf;
local_to.nuid:= local_from.nuid;
end; (* sc_data_to_comm *)
procedure sc_comm_to_data(var local_from: ! sc_comm_type;
var local_to: sc_data_type);
(**********************************************************************)
(* *)
(* sc_comm_to_data *)
(* *)
(* internal ncp procedure. *)
(* parameters: *)
(* local_from: specifies the data that is to be copied (call *)
(* parameter). *)
(* local_to: specifies the data area that data is copied into *)
(* (return parameter). *)
(* call of other procedures: none. *)
(* use of global variables: none. *)
(* waiting points: none. *)
(* function: converts the sc address (sc communication format), *)
(* specified by local_from into the sc address (supervisor data), *)
(* specified by local_to. *)
(* *)
(**********************************************************************)
begin
local_to.port_no:= local_from.port_no;
if local_from.ack_req then
local_to.facility:= ack_req_fac
else
local_to.facility:= 0;;
local_to.nuid_signf:= local_from.nuid_signf;
local_to.nuid:= local_from.nuid;
end; (* sc_comm_to_data *)
function set_ev_ans(var local_msg: reference;
local_rec_no: ! integer): boolean;
(**********************************************************************)
(* *)
(* set_ev_ans *)
(* *)
(* internal ncp function. *)
(* parameters: *)
(* local_msg: reference to a supervisor message that contains the *)
(* relevant record (call parameter). *)
(* local_rec_no: number of the record that is to be accesssed *)
(* (call parameter). *)
(* call of other procedures: search_table, sc_data_to_comm. *)
(* use of global variables: lcp_table. *)
(* waiting points: none. *)
(* function: the function updates the event address of the specified *)
(* lcp according to the accessed record in the supervisor message. *)
(* if the lcp is not connected then set_ev_ans is false else true. *)
(* *)
(**********************************************************************)
type
local_sup_data = packed record
dummy: array(1..6 + sp_head_lgt + (local_rec_no - 1) * reclgt_ev_addr) of byte;
rec_data: ev_addr_record;
end;
var
local_index: integer;
local_sc_data: sc_data_type;
begin
lock local_msg as data: local_sup_data do
begin
if search_table(data.rec_data.lcp_ident.id, local_index,
ncp_index, act_nr_lcp, lcp_index_table) then
begin (* the lcp is connected *)
local_index:= lcp_index_table(local_index).index;
local_sc_data:= data.rec_data.ev_sc_addr.sc_addr;
sc_data_to_comm(local_sc_data, lcp_table(local_index).event_sc_addr.sc_addr);
lcp_table(local_index).event_sc_addr.rec_ident:=
data.rec_data.ev_sc_addr.rec_ident.id;
set_ev_ans:= true;
end (* if search_table(data.rec_data.lcp_ident.id, .... ) *)
else (* not search_table(data.rec_data.lcp_ident.id, .... ) *)
set_ev_ans:= false; (* the lcp is not connected *)
end; (* lock local_msg *)
end; (* set_ev_ans *)
function get_ev_ans(var local_msg: reference;
local_rec_no: ! integer): boolean;
(**********************************************************************)
(* *)
(* get_ev_ans *)
(* *)
(* parameters: *)
(* local_msg: reference to the supervisor message that after call *)
(* should contain the relevant event answer record (return *)
(* parameter). *)
(* local_rec_no: no of the record that is to be accessed (call *)
(* parameter). *)
(* call of other procedures: search_table, sc_comm_to_data. *)
(* use of global variables: work_ref. *)
(* waiting points: none. *)
(* function: the function gets the event address of the specified *)
(* lcp, and puts it into the supervisor message. if the lcp is *)
(* not connected, then get_ev_ans is false, else true. *)
(* *)
(**********************************************************************)
type
local_sup_data = packed record
dummy: array(1..6 + sp_head_lgt + (local_rec_no - 1) * reclgt_ev_addr) of byte;
rec_data: ev_addr_record;
end;
local_work_data = packed record
dummy: array(1..6 + sp_head_lgt + (local_rec_no - 1) * 2) of byte;
lcp_ident: lcp_ident_type;
end;
var
local_index: integer;
local_sc_data: sc_data_type;
local_continue: boolean;
begin
lock work_ref as workdata: local_work_data do
local_continue:= search_table(workdata.lcp_ident.id, local_index,
ncp_index, act_nr_lcp, lcp_index_table);
if local_continue then
begin (* the lcp is connected *)
local_index:= lcp_index_table(local_index).index;
lock local_msg as data: local_sup_data do
with data.rec_data do
begin
lcp_ident.i:= 0;
lcp_ident.id:= lcp_table(local_index).lcp_ident;
sc_comm_to_data(lcp_table(local_index).event_sc_addr.sc_addr, local_sc_data);
ev_sc_addr.sc_addr:= local_sc_data;
ev_sc_addr.rec_ident.i:= 0;
ev_sc_addr.rec_ident.id:=
lcp_table(local_index).event_sc_addr.rec_ident;
end; (* with data.rec_data and lock local_msg *)
get_ev_ans:= true;
end (* if local_index <> entry_not_found *)
else (* local_index = entry_not_found *)
get_ev_ans:= false; (* the lcp is not connected *)
end; (* get_ev_ans *)
function check_datalgt(var local_msg: reference;
local_datalgt: ! integer): boolean;
(***********************************************************************)
(* *)
(* check_datalgt *)
(* *)
(* internal ncp function. *)
(* parameters: *)
(* local_msg: reference to the supervisor message, where data length *)
(* is to be checked (call parameter). *)
(* local_datalgt: the minimum length of data length in supervisor *)
(* message (call parameter). *)
(* call of other procedures: none. *)
(* use of global variables: sup_status, count. *)
(* waiting points: none. *)
(* function: the function checks, if the bytecount in the supervisor *)
(* head matches with the size of the data area in the buffer *)
(* (last - first), and if bytecount is greater than local_datalgt. *)
(* check_datalgt is true if ok else false. *)
(* *)
(***********************************************************************)
var
local_check: boolean:= true;
begin
lock local_msg as data: sup_mess_type do
with data do
begin
if (sp_head_lgt + sp_head.bytecount) > (last - first + 1) then
local_check:= false;
if sp_head.bytecount < local_datalgt then
local_check:= false;
if local_check = false then
begin
sup_status:= (.data_error.);
count:= sp_head.bytecount;
end; (* if local_check = false *)
end; (* with data and lock local_msg *)
check_datalgt:= local_check;
end; (* check_datalgt *)
procedure reset_lcp_stat(local_index: ! integer);
(*********************************************************************)
(* *)
(* reset_lcp_stat *)
(* *)
(* parameters: *)
(* local_index: index in the lcp_table, where the statistical *)
(* record is to be reset (call parameter). *)
(* call of other procedures: none. *)
(* use of global variables: lcp_table. *)
(* waiting points: none. *)
(* function: this procedure reset all statistic counters that *)
(* concern the specified index in the lcp_table. *)
(* *)
(*********************************************************************)
begin
with lcp_table(local_index) do
begin
with lcp_stat do
begin
messages:= 0;
events:= 0;
pending_msg:= 0;
lost_msg:= 0;
end; (* with lcp_stat *)
with repeat_stat do
begin
repeat_opers:= 0;
lost_repeat:= 0;
end; (* with repeat_stat *)
end; (* with lcp_table(local_index) *)
end; (* reset_stat *)
(*********************************************************************)
(* *)
(* ncp program start *)
(* *)
(*********************************************************************)
begin
(*----------------------*)
(* initializing *)
(*----------------------*)
name:= own.incname;
testopen(z, name, sys_vector(operatorsem));
testout(z, version, 0);
lcp_table(ncp_index).lcp_ident:= ncp_ident;
lcp_index_table(ncp_index).key:= ncp_ident;
receive_sc;
alloc(oper_ref, oper_pool, oper_sem);
return(oper_ref);
alloc(work_ref, work_pool, help_sem);
repeat
(*-------------------------------*)
(* central waiting point *)
(*-------------------------------*)
wait(msg, ncp_sem.w^);
index:= entry_not_found;
case msg^.u2 of
(*-----------------*)
(* message *)
(*-----------------*)
message:
begin
if empty(msg) then
case msg^.u1 of
(*---------------------*)
(* connect lcp *)
(*---------------------*)
connect_lcp:
begin
lock msg as data: lcp_conn_type do
act_lcp_ident:= data.lcp_ident.id;
if first_free <= max_lcp then
begin (* free entry in lcp table avaiblable *)
index:= first_free;
if insert_table(act_lcp_ident, index,
ncp_index, act_nr_lcp, lcp_index_table) then
begin (* lcp not already connected *)
repeat
first_free:= first_free + 1;
if first_free > max_lcp then
continue:= false
else (* first_free <= max_lcp *)
continue:= (lcp_table(first_free).lcp_ident <> free_entry);
until continue = false;
with lcp_table(index) do
begin (* initialize lcp_table(index) *)
lcp_ident:= act_lcp_ident;
event_sc_addr:= event_addr;
state.connect:= conn;
end; (* with lcp_table(index) *)
reset_lcp_stat(index);
msg^.u2:= ok;
msg^.u3:= index;
if connection in event_mask then
send_event(ev_connect);
end (* if insert_table(act_lcp_ident, index) *)
else (* not insert_table(act_lcp_ident, index) *)
begin (* lcp already connected *)
index:= lcp_index_table(index).index;
ncp_error(index, 1); (**** error 1 ****)
msg^.u2:= fct_not_allw;
if collision in event_mask then
send_event(ev_collision);
end; (* else not insert_table(act_lcp_ident, index) *)
end (* if first_free <= max_lcp *)
else (* first_free > max_lcp *)
begin (* no free entry avaiblable *)
ncp_error(first_free, 2); (**** error 2 ****)
msg^.u2:= busy;
if lack_of_res in event_mask then
send_event(ev_lack_res);
end; (* else first_free > max_lcp *)
return(msg);
end; (* connect_lcp *)
(*------------------------*)
(* disconnect lcp *)
(*------------------------*)
disconnect_lcp:
begin
lock msg as data: lcp_disc_type do
act_lcp_ident:= data.lcp_ident.id;
if remove_table(act_lcp_ident, index,
ncp_index, act_nr_lcp, lcp_index_table) then
begin (* lcp was connected *)
if index < first_free then
first_free:= index;
lcp_table(index).lcp_ident:= free_entry;
lcp_table(index).state.connect:= disconn;
continue:= true;
repeat (* return wait messages, if any *)
sensesem(msg_ref, lcp_table(index).wait_msg_sem);
if not nil(msg_ref) then
begin (* wait message found *)
msg_ref^.u2:= user_term;
return(msg_ref);
end (* if not nil *)
else
continue:= false;
until continue = false;
continue:= true;
repeat (* return pending supervisor messages, if any *)
sensesem(msg_ref, lcp_table(index).pending_sem);
if not nil(msg_ref) then
return_sup(msg_ref, (.lcp_unknown.), index)
else (* not nil(msg_ref) *)
continue:= false;
until continue = false;
lcp_table(index).state.msg_pending:= not_pending;
(* return hanging 'wait event buffer' messages *)
continue:= true;
while continue do
begin (* run through wait_ev_buf_sem *)
sensesem(msg_ref, wait_ev_buf_sem);
if not nil(msg_ref) then
if msg_ref^.u3 = index then
begin (* 'wait event buffer' belonging to the disconnecting lcp is found *)
msg_ref^.u2:= user_term;
return(msg_ref);
end (* if msg_ref^.u3 = index *)
else (* msg_ref^.u3 <> index *)
signal(msg_ref, help_sem)
else (* nil(msg_ref) *)
continue:= false;
end; (* while continue *)
continue:= true;
while continue do
begin
sensesem(msg_ref, help_sem);
if not nil(msg_ref) then
signal(msg_ref, wait_ev_buf_sem)
else (* nil(msg_ref) *)
continue:= false;
end; (* while continue *)
continue:= true;
rep_index:= 0;
repeat
rep_index:= rep_index + 1;
if rep_index > max_repeat then
continue:= false
else (* rep_index <= max_repeat *)
if not nil(repeat_table(rep_index).msg) then
begin (* repeatable function found *)
lock repeat_table(rep_index).msg as data: sup_mess_type do
help_int:= data.sp_head.receiver_id.id;
if help_int = act_lcp_ident then
release_rep(rep_index, index);
end; (* if not nil(repeat_table(rep_index).msg) *)
until continue = false;
msg^.u2:= ok;
if disconnection in event_mask then
send_event(ev_disconnect);
end (* if remove_table(act_lcp_ident) *)
else (* not remove_table(act_lcp_ident) *)
begin (* lcp not connected *)
ncp_error(index, 11); (**** error 11 ****)
msg^.u2:= rec_unkw;
end; (* else not remove_table(act_lcp_ident) *)
return(msg);
end; (* disconnect_lcp *)
(*------------------------------*)
(* request event buffer *)
(* wait event buffer *)
(*------------------------------*)
req_event_buf, wait_event_buf:
begin
index:= msg^.u3;
if check_index(index) then
begin (* index ok *)
act_lcp_ident:= lcp_table(index).lcp_ident;
case msg^.u1 of
req_event_buf:
get_event_buf(act_lcp_ident, no_wait, event_ref);
wait_event_buf:
get_event_buf(act_lcp_ident, wait_forever, event_ref);
end; (* case msg^.u1 of *)
if not nil(event_ref) then
begin (* free event buffer avaiblable *)
msg^.u2:= ok;
push(msg, event_ref);
return(event_ref);
end; (* if not nil(event_ref) *)
end (* if check_index *)
else (* check_index = false *)
begin (* illegal index *)
ncp_error(index, 21); (**** error 21 ****)
msg^.u2:= format_err;
return(msg);
end; (* else check_index = false *)
end; (* req_event_buf, wait_event_buf *)
(*----------------------*)
(* wait message *)
(*----------------------*)
wait_message:
begin
index:= msg^.u3;
if check_index(index) then
begin (* index ok *)
case lcp_table(index).state.msg_pending of
(*------------------------------------*)
(* supervisor message pending *)
(*------------------------------------*)
pending:
begin
sensesem(msg_ref, lcp_table(index).pending_sem);
if not nil(msg_ref) then
send_lcp_sup(msg, msg_ref, index)
else (* nil(msg_ref) *)
begin
lcp_table(index).state.msg_pending:= not_pending;
signal(msg, lcp_table(index).wait_msg_sem);
end; (* else nil(msg_ref) *)
end; (* pending *)
(*---------------------------------------*)
(* no supervisor message pending *)
(*---------------------------------------*)
not_pending:
begin
signal(msg, lcp_table(index).wait_msg_sem);
end; (* not_pending *)
end; (* case lcp_table(index).state.msg_pending *)
end (* if check_index *)
else (* check_index = false *)
begin (* illegal index *)
ncp_error(index, 31); (**** error 31 ****)
msg^.u2:= format_err;
return(msg);
end; (* else check_index = false *)
end; (* wait_message *)
(*-------------------------*)
(* illegal message *)
(*-------------------------*)
otherwise (* illegal u1 code *)
ncp_error(index, 41); (**** error 41 ****)
msg^.u2:= ill_opcode;
return(msg);
end (* case msg^.u1 *)
else (* not empty(msg) *)
begin (* message from lcp is stacked *)
ncp_error(index, 51); (**** error 51 ****)
msg^.u2:= format_err;
return(msg);
end; (* else not empty(msg) *)
end; (* message *)
(*----------------*)
(* answer *)
(*----------------*)
otherwise
case msg^.u4 of
(*---------------*)
(* event *)
(*---------------*)
event_str:
begin
index:= msg^.u3;
if check_index(index) then
begin
case msg^.u2 of
ok:
begin
lock msg as data: sup_mess_type do
data.sp_head.sender_id.id:= lcp_table(index).event_sc_addr.rec_ident;
update_sp_head(msg);
alloc(sc_msg, sc_mess_pool, ncp_sem.s^);
lock sc_msg as scdata: sc_out_type do
with scdata do
begin
first:= 6;
last:= sc_out_last;
next:= 6;
local_port:= ncp_port;
rec_sc:= lcp_table(index).event_sc_addr.sc_addr;
end; (* with scdata and lock sc_msg *)
push(sc_msg, msg);
send_sc(msg, true);
if prod_stat in event_mask then
begin
inc15(lcp_table(index).lcp_stat.events);
inc15(ncp_stat.lcp_stat.events);
end; (* if prod_stat in event_mask *)
end; (* ok *)
otherwise (* not ok *)
ncp_error(index, 101); (**** error 101 ****)
release_event(msg, index);
end; (* case msg^.u2 *)
end (* if check_index(index) *)
else (* check_index(index) = false *)
begin (* illegal index *)
ncp_error(index, 102); (**** error 102 ****)
release_event(msg, index);
end; (* else check_index(index) = false *)
end; (* event_str *)
(*---------------------*)
(* lcp message *)
(*---------------------*)
lcp_msg_str:
begin
index:= msg^.u3;
if check_index(index) then
begin
case msg^.u2 of
ok:
return_sup(msg, (..), index);
otherwise (* not ok *)
ncp_error(index, 111); (**** error 111 ****)
release_sup(msg, index);
end; (* case msg^.u2 *)
end (* if check_index(index) *)
else (* check_index(index) = false *)
begin (* illegal index *)
ncp_error(index, 112); (**** error 112 ****)
release_sup(msg, index);
end; (* else check_index(index) = false *)
end; (* lcp_msg_str *)
(*------------------*)
(* ts input *)
(*------------------*)
sc_input_str:
begin
act_sc_input:= act_sc_input - 1;
receive_sc; (* send new input buffer to sc *)
case msg^.u2 of
ok:
begin
pop(sc_msg, msg);
if not nil(msg) then
begin (* stack from sc ok *)
lock msg as data: sup_mess_type do
with data.sp_head do
begin
if receiver_id.i = 1 then
ind_rec:= true (* receiver_id is indirectly addressed *)
else (* receiver_id.i = 0 *)
ind_rec:= false; (* receiver_id directly addressed *)
if sender_id.i = 1 then
ind_sen:= true (* sender_id is indirectly addressed *)
else (* sender_id.i = 0 *)
ind_sen:= false; (* sender_id directly addressed *)
end; (* with data.sp_head and lock msg *)
if ind_rec or ind_sen then
(*-------------------------------*)
(* indirectly addressing *)
(*-------------------------------*)
begin
lock msg as data: ind_addr_data do
lock sc_msg as scdata: sc_out_type do
begin
scdata.local_port:= ncp_port;
sc_data_var:= data.sc_addr;
sc_data_to_comm(sc_data_var, scdata.rec_sc);
if ind_rec then (* indirect receiver_id highest priority *)
data.head.sp_head.receiver_id:= data.lcp_ident
else (* ind_sen *)
data.head.sp_head.sender_id:= data.lcp_ident;
<*
ind_addr_lgt:= ind_addr_size + data.sc_addr.nuid_signf;
*> ind_addr_lgt:= ind_addr_size + nuid_lgt; (******** dyn. arrays *)
end; (* lock sc_msg and lock msg *)
lock msg as data: sup_data do
begin
count:= data.head.sp_head.bytecount - ind_addr_lgt;
data.head.sp_head.bytecount:= count;
data.head.last:= 5 + sp_head_lgt + count;
index_to:= 1;
index_from:= ind_addr_lgt + 1;
while count > 0 do
begin (* remove indirect addressing field in supervisor data *)
data.sp_data(index_to):= data.sp_data(index_from);
count:= count - 1;
index_to:= index_to + 1;
index_from:= index_from + 1;
end; (* while count > 0 *)
end; (* lock msg *)
end; (* if ind_sen or ind_rec *)
if ind_rec then
(*--------------------------------*)
(* receiver_id indirectly *)
(*--------------------------------*)
begin
push(sc_msg, msg);
send_sc(msg, false);
end (* if ind_rec *)
else (* not ind_rec *)
(*------------------------------------*)
(* receiver_id not indirectly *)
(* or no indirect addressing *)
(*------------------------------------*)
begin
lock msg as data: sup_mess_type do
begin
act_lcp_ident:= data.sp_head.receiver_id.id;
ncp_contr:= data.sp_head.sp_type.ncp_control;
repeat_func:= data.sp_head.sp_type.rep_func;
count:= data.sp_head.bytecount;
end; (* lock msg *)
if search_table(act_lcp_ident, index,
ncp_index, act_nr_lcp, lcp_index_table) then
begin (* receiver_id known *)
index:= lcp_index_table(index).index;
lock sc_msg as scdata: sc_in_type do
scdata.first:= scdata.last + 1;
push(msg, sc_msg);
msg:=: sc_msg;
case ncp_contr of
no_ncp_cntr:
case index of
ncp_index:
send_int_lcp(msg);
otherwise (* not ncp_index *)
sensesem(msg_ref, lcp_table(index).wait_msg_sem);
if not nil(msg_ref) then
(* 'wait message' message hanging *)
send_lcp_sup(msg_ref, msg, index)
else (* nil(msg_ref) *)
begin (* no 'wait message' message hanging *)
lcp_table(index).state.msg_pending:= pending;
signal(msg, lcp_table(index).pending_sem);
if prod_stat in event_mask then
begin
inc15(lcp_table(index).lcp_stat.pending_msg);
inc15(ncp_stat.lcp_stat.pending_msg);
end; (* if prod_stat in event_mask *)
end; (* else nil(msg_ref) *)
end; (* case index *)
(*------------------------*)
(* repeat message *)
(*------------------------*)
ncp_cntr:
case repeat_func of
start_rep:
if (count >= rep_data_lgt) and (count <= rep_buf_size) then
if first_free_rep <= max_repeat then
begin (* free entry in repeat_table available *)
rep_index:= first_free_rep;
repeat_table(rep_index).state:= used;
repeat
first_free_rep:= first_free_rep + 1;
if first_free_rep > max_repeat then
continue:= false
else (* first_free_rep <= max_repeat *)
continue:=
(repeat_table(first_free_rep).state = used);
until continue = false;
alloc(sc_msg, sc_mess_pool, ncp_sem.s^);
pop(msg_ref, msg);
lock msg as data: sc_out_type do
lock sc_msg as scdata: sc_out_type do
scdata:= data;
push(msg_ref, msg);
alloc(msg_ref, repeat_pool, ncp_sem.s^);
push(msg_ref, sc_msg);
msg_ref:=: sc_msg;
lock msg as data: repeat_data do
lock msg_ref as refdata: rep_sup_data do
begin
repeat_table(rep_index).ticks:= data.ticks;
refdata.head:= data.head;
refdata.head.sp_head.bytecount:=
data.head.sp_head.bytecount - rep_data_lgt;
refdata.head.last:=
refdata.head.sp_head.bytecount + sp_head_lgt + 5;
refdata.sp_data:= data.sp_data;
if data.start_time = time_0 then
count:= 0
else (* data.time <> time_0 *)
begin
(****************************)
(* *)
(* udregn resttiden *)
(* *)
(****************************)
count:= 15; (* foreløbig *)
end; (* else data.time <> time_0 *)
end; (* lock msg *)
release_sup(msg, index);
msg_ref^.u3:= index;
repeat_table(rep_index).msg:=: msg_ref;
alloc(msg, timeout_pool, help_sem);
alloc(msg_ref, timeout_pool, ncp_sem.s^);
msg_ref^.u4:= time_out_str;
timerbook(msg, msg_ref, count, rep_index,
timeout_sem.s^, help_sem);
repeat_table(rep_index).timeout_ref:=: msg;
lcp_table(index).repeat_stat.repeat_opers:=
lcp_table(index).repeat_stat.repeat_opers + 1;
ncp_stat.repeat_stat.repeat_opers:=
ncp_stat.repeat_stat.repeat_opers + 1;
end (* if first_free_rep <= max_repeat *)
else (* first_free_rep > max_repeat *)
return_sup(msg, (.rep_res_lack.), index)
else (* count < rep_data_lgt *)
return_sup(msg, (.data_error.), index);
stop_rep:
begin
rep_index:= 0;
repeat
rep_index:= rep_index + 1;
if rep_index > max_repeat then
continue:= false
else (* rep_index <= max_repeat *)
if not nil(repeat_table(rep_index).msg) then
lock repeat_table(rep_index).msg as tabdata:
sup_mess_type do
lock msg as data: sup_mess_type do
continue:= not ((data.sp_head.receiver_id.id =
tabdata.sp_head.receiver_id.id) and
(data.sp_head.lcp_oper =
tabdata.sp_head.lcp_oper))
else (* nil(repeat_table(rep_index).msg) *)
continue:= true;
until continue = false;
if rep_index <= max_repeat then
begin (* repeat function is found in repeat_table *)
release_rep(rep_index, index);
return_sup(msg, (..), index);
end (* if rep_index <= max_repeat *)
else (* rep_index > max_repeat *)
return_sup(msg, (.ill_lcp_oper.), index);
end; (* stop_rep *)
end; (* case repeat_func *)
end; (* case ncp_contr *)
end (* if search_table(act_lcp_ident, .... ) *)
else (* not search_table(act_lcp_ident, .... ) *)
begin (* receiver_id unknown *)
push(msg, sc_msg);
return_sup(sc_msg, (.lcp_unknown.), index);
end; (* else not search_table(act_lcp_ident, .... ) *)
end; (* else not ind_rec *)
end (* if not nil(msg) *)
else (* nil(msg) *)
begin (* stack from sc not ok *)
ncp_error(index, 121); (**** error 121 ****)
release(sc_msg);
end; (* else nil(msg) *)
end; (* ok *)
otherwise (* not ok *)
ncp_error(index, 122); (**** error 122 ****)
release_sc(msg, index, false);
end; (* case msg^.u2 *)
end; (* sc_input_str *)
(*-------------------------------*)
(* sc output, supervisor *)
(*-------------------------------*)
sc_output_str:
begin
case msg^.u2 of
ok: ; (* do nothing *)
otherwise (* not ok *)
ncp_error(index, 131); (**** error 131 ****)
end; (* case msg^.u2 *)
release_sc(msg, index, false);
end; (* sc_output_str *)
(*--------------------------*)
(* sc output, event *)
(*--------------------------*)
sc_ev_out_str:
begin
case msg^.u2 of
ok: ; (* do nothing *)
otherwise (* not ok *)
ncp_error(index, 141); (**** error 141 ****)
end; (* case msg^.u2 *)
release_sc(msg, index, true);
end; (* sc_ev_out_str *)
(*------------------*)
(* time out *)
(*------------------*)
time_out_str:
begin
lock msg as data: object_type do
rep_index:= data.object;
if not nil(repeat_table(rep_index).msg) then
begin (* a repeatable function is still hanging *)
index:= repeat_table(rep_index).msg^.u3;
help_int:= msg^.u2;
timerbook(repeat_table(rep_index).timeout_ref, msg,
repeat_table(rep_index).ticks, rep_index, timeout_sem.s^, help_sem);
case help_int of
timeout_ok:
if act_nr_sup_buf >= 1 then
begin (* free supervisor buffers available *)
if index <> ncp_index then
sensesem(msg_ref, lcp_table(index).wait_msg_sem);
if (index = ncp_index) or (not nil(msg_ref)) then
begin (* generate a repeat supervisor message *)
alloc(sc_msg, sc_mess_pool, ncp_sem.s^);
pop(msg, repeat_table(rep_index).msg);
lock sc_msg as scdata: sc_out_type do
lock repeat_table(rep_index).msg as tabdata: sc_out_type do
begin
scdata:= tabdata;
scdata.first:= 6;
end; (* lock sc_msg and lock repeat_table(rep_index).msg *)
push(msg, repeat_table(rep_index).msg);
alloc(msg, sup_mess_pool, ncp_sem.s^);
act_nr_sup_buf:= act_nr_sup_buf - 1;
lock msg as data: rep_sup_data do
lock repeat_table(rep_index).msg as tabdata: rep_sup_data do
data:= tabdata;
push(msg, sc_msg);
case index of
ncp_index:
send_int_lcp(sc_msg);
otherwise (* not ncp_index *)
send_lcp_sup(msg_ref, sc_msg, index);
end; (* case index *)
end (* if (index = ncp_index) or (not nil(msg_ref)) *)
else (* not ((index = ncp_index) or (not nil(msg_ref))) *)
begin
inc15(lcp_table(index).repeat_stat.lost_repeat);
inc15(ncp_stat.repeat_stat.lost_repeat);
end; (* else not ((index = ncp_index) or (not nil(msg_ref))) *)
end (* if act_nr_sup_buf >= 1 *)
else (* act_nr_sup_buf < 1 *)
begin
inc15(lcp_table(index).repeat_stat.lost_repeat);
inc15(ncp_stat.repeat_stat.lost_repeat);
end; (* else act_nr_sup_buf < 1 *)
otherwise (* not timeout_ok *)
ncp_error(index, 151); (**** error 151 ****)
end; (* case help_int *)
end (* if not nil(repeat_table(rep_index).msg) *)
else (* nil(repeat_table(rep_index).msg) *)
begin
repeat_table(rep_index).state:= unused;
if rep_index < first_free_rep then
first_free_rep:= rep_index;
release(msg);
end; (* else nil(repeat_table(rep_index).msg) *)
end; (* time_out_str *)
(*----------------------*)
(* internal lcp *)
(*----------------------*)
int_lcp_str:
begin
index:= msg^.u3;
case msg^.u2 of
ok:
begin
lock msg as data: sup_mess_type do
with data.sp_head do
begin
stat_control:= sp_type.stat_cntr;
basic_oper:= lcp_oper.basic;
modif_oper:= lcp_oper.modif;
count:= bytecount;
end; (* with data.sp_head and lock msg *)
sup_status:= (..); (* reset status in supervisor head *)
case basic_oper of
(*---------------------------*)
(* control operation *)
(*---------------------------*)
lcp_cntr:
begin
case modif_oper of
(*------------------------*)
(* set event mask *)
(*------------------------*)
set_event_mask:
if check_datalgt(msg, 4) then (* datalgt >= 4 *)
lock msg as data: ev_mask_data do
with data do
begin
event_mask:= (update_mask * ev_mask) +
((full_mask - update_mask) * event_mask);
update_mask:= event_mask;
count:= 2;
end; (* with data and lock msg and if check_datalgt(msg, 4) *)
(*---------------------------*)
(* set date and time *)
(*---------------------------*)
set_time:
if check_datalgt(msg, 12) then (* datalgt >= 12 *)
begin
lock msg as data: sup_data do
lock work_ref as workdata: date_time_type do
with data, workdata do
begin
first:= 6;
last:= first + 17;
next:= last + 1;
year(1):= sp_data(1);
year(2):= sp_data(2);
month(1):= sp_data(3);
month(2):= sp_data(4);
day(1):= sp_data(5);
day(2):= sp_data(6);
hour(1):= sp_data(7);
hour(2):= sp_data(8);
minute(1):= sp_data(9);
minute(2):= sp_data(10);
second(1):= sp_data(11);
second(2):= sp_data(12);
end; (* with data, workdata, lock work_ref, and lock msg *)
work_ref^.u1:= set_date_time;
work_ref^.u2:= message;
signal(work_ref, timeout_sem.s^);
wait(work_ref, help_sem);
if work_ref^.u2 <> timeout_ok then
sup_status:= (.data_error.);
end; (* if check_datalgt and set_time *)
(*---------------------------*)
(* set event address *)
(*---------------------------*)
set_event_addr:
begin
if (count mod reclgt_ev_addr) = 0 then
continue:= true (* bytecount ok *)
else (* (count mod reclgt_ev_addr) <> 0 *)
continue:= false; (* bytecount not ok *)
if continue then
begin
help_int:= count div reclgt_ev_addr;
while continue and (help_int > 0) do
begin (* update event address *)
continue:= set_ev_ans(msg, help_int);
help_int:= help_int - 1;
end; (* while continue and (help_int > 0) *)
if not continue or (help_int <> 0) then (* data error *)
sup_status:= (.lcp_unknown.);
end (* if continue *)
else (* not continue *)
sup_status:= (.data_error.);
end; (* set_event_addr *)
(*--------------------------------------*)
(* set exception return address *)
(*--------------------------------------*)
set_except_addr:
begin
help_int:= nuid_lgt + 4;
if check_datalgt(msg, help_int) then
lock msg as data: exc_addr_data do
begin
sc_data_var:= data.exc_sc_addr.sc_addr;
sc_data_to_comm(sc_data_var, except_addr.sc_addr);
except_addr.rec_ident:= data.exc_sc_addr.rec_ident.id;
end; (* lock msg *)
end; (* set_except_addr *)
(*-----------------------------------*)
(* illegal control operation *)
(*-----------------------------------*)
otherwise (* illegal modif_oper *)
sup_status:= (.ill_lcp_oper.);
end; (* case modif_oper *)
end; (* lcp_cntr *)
(*-------------------------*)
(* sense operation *)
(*-------------------------*)
lcp_sense:
begin
case modif_oper of
(*------------------------*)
(* get event mask *)
(*------------------------*)
get_event_mask:
if check_datalgt(msg, 0) then (* datalgt >= 0 *)
begin
lock msg as data: ev_mask_data do
data.update_mask:= event_mask;
count:= 2;
end; (* if check_datalgt(msg, 0) *)
(*---------------------------*)
(* get event address *)
(*---------------------------*)
get_event_addr:
begin
if (count mod 2) = 0 then
continue:= true (* bytecount ok *)
else (* (count mod 2) <> 0 *)
continue:= false; (* bytecount not ok *)
if continue then
begin
count:= count div 2;
help_int:= count;
lock msg as data: sup_data do
lock work_ref as workdata: sup_data do
workdata:= data;
while continue and (count > 0) do
begin
continue:= get_ev_ans(msg, count);
count:= count - 1;
end; (* while continue and (count > 0) *)
if not continue or (count <> 0) then
lock msg as data: sup_data do
lock work_ref as workdata: sup_data do
begin (* a data error has been detected *)
data:= workdata;
sup_status:= (.lcp_unknown.);
count:= data.head.sp_head.bytecount;
end (* if not continue or (count <> 0) *)
else (* continue and (count = 0) *)
count:= help_int * reclgt_ev_addr;
end (* if continue *)
else (* not continue *)
sup_status:= (.data_error.);
end; (* get_event_addr *)
(*--------------------------------------*)
(* get exception return address *)
(*--------------------------------------*)
get_except_addr:
if check_datalgt(msg, 0) then (* datalgt >= 0 *)
lock msg as data: exc_addr_data do
begin
sc_comm_to_data(except_addr.sc_addr, sc_data_var);
with data.exc_sc_addr do
begin
sc_addr:= sc_data_var;
rec_ident.i:= 0;
rec_ident.id:= except_addr.rec_ident;
count:= 6 + nuid_lgt;
end; (* with data.exc_sc_addr *)
end; (* lock msg and if check_datalgt(msg, 0) *)
(*-----------------------------*)
(* get connected lcp's *)
(*-----------------------------*)
get_conn_lcp:
if check_datalgt(msg, 0) then (* datalgt >= 0 *)
begin
lock msg as data: conn_lcp_data do
for help_int:= 0 to act_nr_lcp do
data.lcp_ident(help_int):= lcp_index_table(help_int).key;
count:= (act_nr_lcp + 1) * 2;
end; (* if check_datalgt(msg, 0) *)
(*----------------------------------*)
(* get repeatable functions *)
(*----------------------------------*)
get_rep_func:
if check_datalgt(msg, 0) then (* datalgt >= 0 *)
lock msg as data: rep_func_data do
begin
count:= 0;
for help_int:= 1 to max_repeat do
if not nil(repeat_table(help_int).msg) then
lock repeat_table(help_int).msg as tabdata: sup_mess_type do
begin
count:= count + 1;
data.rep_data(count).lcp_ident:= tabdata.sp_head.receiver_id.id;
data.rep_data(count).seq_no:= tabdata.sp_head.seq_no;
data.rep_data(count).lcp_oper:= tabdata.sp_head.lcp_oper;
end; (* lock repeat_table, if not nil and for help_int *)
count:= count * rep_func_lgt;
end; (* lock msg and if check_datalgt(msg, 0) *)
(*---------------------------------*)
(* illegal sense operation *)
(*---------------------------------*)
otherwise
sup_status:= (.ill_lcp_oper.);
end; (* case modif_oper *)
end; (* lcp_sense *)
(*----------------------------------*)
(* get statistics operation *)
(*----------------------------------*)
lcp_get_stat:
begin
case modif_oper of
(*----------------------------*)
(* get lcp statistics *)
(*----------------------------*)
get_lcp_stat:
begin
if (count mod 2) = 0 then
continue:= true (* bytecount ok *)
else (* (count mod 2) <> 0 *)
continue:= false; (* bytecount not ok *)
count:= count div 2;
if continue then
begin
help_int:= count;
lock msg as data: sup_data do
lock work_ref as workdata: sup_data do
workdata:= data;
lock msg as data: stat_data do
begin
data.ncp_stat:= ncp_stat;
lock work_ref as workdata: lcp_stat_data do
begin
index_to:= 0;
while continue and (count > 0) do
begin
continue:= search_table(workdata.lcp_ident(index_to),
index_from, ncp_index, act_nr_lcp, lcp_index_table);
if continue then (* specified lcp is connected *)
begin
index_from:= lcp_index_table(index_from).index;
data.lcp_statis(index_to).lcp_ident:=
workdata.lcp_ident(index_to);
data.lcp_statis(index_to).lcp_stat:=
lcp_table(index_from).lcp_stat;
data.lcp_statis(index_to).repeat_stat:=
lcp_table(index_from).repeat_stat;
index_to:= index_to + 1;
count:= count - 1;
end; (* if continue *)
end; (* while continue and (count > 0) *)
end; (* lock work_ref *)
end; (* lock msg *)
if not continue or (count <> 0) then
lock msg as data: sup_data do
lock work_ref as workdata: sup_data do
begin (* a data error has been detected *)
data:= workdata;
sup_status:= (.lcp_unknown.);
count:= data.head.sp_head.bytecount;
end (* if not continue or (count <> 0) *)
else (* continue and (count = 0) *)
begin
if stat_control = reset_stat then
lock work_ref as workdata: lcp_stat_data do
begin
count:= help_int;
index_to:= 0;
while count > 0 do
begin
continue:= search_table(workdata.lcp_ident(index_to),
index_from, ncp_index, act_nr_lcp, lcp_index_table);
index_from:= lcp_index_table(index_from).index;
reset_lcp_stat(index_from);
index_to:= index_to + 1;
count:= count - 1;
end; (* while count > 0 *)
end; (* if stat_control = reset_stat and lock work_ref *)
count:= ncp_stat_lgt + help_int * lcp_stat_lgt;
end; (* else continue and (count = 0) *)
end (* if continue *)
else (* not continue *)
sup_status:= (.data_error.);
end; (* get_lcp_stat *)
(*------------------------------------------*)
(* illegel get statistics operation *)
(*------------------------------------------*)
otherwise (* illegal modif_oper *)
sup_status:= (.ill_lcp_oper.);
end; (* case modif_oper *)
end; (* lcp_get_stat *)
end; (* case basic_oper *)
lock msg as data: sup_mess_type do
with data do
begin
last:= 5 + sp_head_lgt + count;
sp_head.status:= sup_status;
sp_head.bytecount:= count;
end; (* with data and lock msg *)
msg^.u4:= lcp_msg_str;
return(msg);
end; (* ok *)
otherwise (* not ok *)
ncp_error(index, 201); (**** error 201 ****)
release_sup(msg, index);
end; (* case msg^.u2 *)
end; (* int_lcp_str *)
otherwise (* unknown stream *)
ncp_error(index, 211); (**** error 211 ****)
msg^.u2:= not_mess;
return(msg);
end; (* case msg^.u4 *)
end; (* case msg^.u2 *)
until forever;
end.
(*********************************************************************)
(* *)
(* end of ncp program *)
(* *)
(*********************************************************************)
▶EOF◀