DataMuseum.dk

top - metrics - download

    Length: 26880 (0x6900)
    Types: TextFile
    Names: »phoenix«

└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system
    └─⟦72244f0ef⟧ 
        └─⟦this⟧ »phoenix« 

TextFile

job wib 1 200,
time 10 0,
output 400000,
size 20000,
buf 7,
perm disc1 600 10
message start compile phoenix
phoenixbin= set 400 disc1
if ok.no
finis
scope user phoenixbin
if ok.no
finis
phoenixbin= algol list.no xref.no
\f

 
begin

<*
the program structure of phoenix is:

begin
_  declaration of installation parameters
_
_  procedure program;
_  begin
_     declarations;
_     procedures in alphabetical order
_     monitor procedures (signal and wait)
_     coroutine procedures
_
_     initialisations
_
_     central logic
_  end;
_
_  initialisation of installation parameters
_
_  repeat
_     program;
_  until phoenix_finished;
_
end;
*>

\f


<****  external procedures  ****
*>

\f


<********** declaration of installation parameters *********>

integer
<*****>

buf_array_length,          <* the length of the array 'buf' *>
last_restart_time,
max_block_no,
max_mess_lgh,
max_task_inc_no,
no_of_mhs,
no_of_sems,
no_of_restarts,
segm_pr_block,
start_up_time,
version,
warning_block_no;



boolean
<*****>

phoenix_finished,
test,
test_on_bs,               <* true if output is sent to a bs_area *>
test_cl;                  <* true if test on central logic *>
 
<* algol copy.subnames; *>

\f


procedure program;
begin

integer
<*****>

a,                        <* auxiliary *>
buf_base,                 <* used when initialising the buffers *>
buffer_addr,              <* used by the central logic *>
buffer_head_length,
cause,                    <* used in central logic *>
c_corout_no,              <* the no of the current coroutine *>
current_block,            <* used by log *>
current_log_file,         <* used by log *>
first_free_task_inc_no,
halfwords_available,      <* used by log *>
last_free_task_inc_no,
i,                        <* auxiliary variabel *>
incarnation,              <* used during start of the coroutines *>
mask,                     <* used by testout *>
stdnetdelay,              <* timer delay *>
stdoptdelay,              <* timer delay *>

<*** streamer constants ***>
stream_log,
stream_amh,
stream_alopt,


<*** database constants ***>
db_key_lg,
db_data_lg,
dc_number,

<*****************************>
<***** alarm environment *****>

<*** update field ***>
read_code,
insert_code,
modify_code,
remove_code,
start_code,
stop_code,
service_code,

<*** micro addresses ***>
tss_mic_addr,
ath_mic_addr,
vch_mic_addr,
netc_mic_addr;
<*** end alarm environment ***>
 
 
long
<**>

min_for_this_block;       <* used by log *>
  
 
 
integer array field
<*****************>

c_corout,                 <* used in coroutine descriptions *>
data,                     <* used in buffers *>
lab_data,                 <* used in alarm-messages *>
ready_q_first,
ready_q_last,
iaf,                      <* used in zones *>

<* array fields used in task descriptors *>
td_db_ref,
td_info;



boolean
<*****>

log_change_forced,        <* used by log *>
request_to_restart;


integer field
<***********>

<***** fields used in buffer headers *****>
next,                     <* also used in coroutine descriptions *>
home_pool,
length,
operation,

<***** fields used in task descriptor *****>
td_type,
td_state,

<***** fields used in coroutine descriptions *****>
corout_no,
incarn,
bf,

 
<***** fields used in alarm_messages *****>
lab_no_of_by,
lab_rec_macro,
lab_rec_micro,
lab_send_macro,
lab_send_micro,
lab_opc_upd,
lab_hour,
lab_min_sec;



<***** global semaphores *****>

integer
<*****>

log_key_sem_no,
tick_sem_no,
timeout_handler_sem_no,
timeout_pool_no,
timer_sem_no;

integer field
<***********>
log_key_sem,
tick_sem,
timeout_handler_sem,
timeout_pool,
timer_sem;



integer array
<***********>
 
buf(1:buf_array_length),
corout(1:(no_of_mhs + 2<*timer*>) * 4<*coroutsize*> + 1),
free_task_inc_no_list(1 : max_task_inc_no),
sem(1:no_of_sems),
table(0:255);             <* used for input conversion *>

real array
<********>

em_record(1:2);           <* used by log *>

long array
<********>

outprocname (1:2);          <* used by alopt *>


zone
<**>

z_log(128 * segm_pr_block,1,stderror),
zopt (50,1,dastderror);     <* output to opt *>

\f


procedure cancel_timeout(task_inc_no);
value task_inc_no;
integer task_inc_no;
begin
<* The procedure signals a cancel buffer to the timer module.
*>
integer array field buffer;
buffer := wait(timeout_pool);
buf.buffer.operation := 3;
buf.buffer.data(3) := task_inc_no;
signal(timer_sem,buffer);
end cancel_timeout;
\f


procedure clear_task(task_inc_no);
value task_inc_no;
integer task_inc_no;
begin
<* The procedure sends a clearing-buffer through the timeout system.
*>
integer array field buffer;
buffer := wait(timeout_pool);
buf.buffer.operation := 4;
buf.buffer.data(3) := task_inc_no;
signal(timer_sem,buffer);
end clear_task;
\f


procedure decode_message;
begin <* used by the central logic to determine what
to do when a message is received *>
end decode message;
\f

 
procedure empty (zout);
zone zout;
begin <* empties the buffer to the screen *>
outchar(zout,27);
setposition(zout,0,0);
end empty;


\f


procedure free_core;
if test then
disable
begin <* displays on primary output the no of
free segments in core *>
real array prog(1:2);
integer i;

write(out,<:free core: :>,system(2,i,prog)//512,
_    <: segments:>,"nl",1);
if -,test_on_bs then setposition(out,0,0);
end free core;
\f


integer procedure get_buf(bsize);
value bsize;
integer bsize;
begin <* gets a buffer of the wanted size. used during initialisation *>
getbuf:=bufbase;
bufbase:=bufbase + 2*bsize + 2*buffer_head_length;
end get buf;

\f


integer procedure get_task_inc_no;
begin

<* Yields a free task incarnation number from the free_task_inc_no_list.
_  If there are no numbers left, the value will be zero.
*>

integer next;

next := free_task_inc_no_list(first_free_task_inc_no);
if next < 0 then
get_task_inc_no := 0
else
begin
get_task_inc_no := first_free_task_inc_no;
free_task_inc_no_list(first_free_task_inc_no) := 0;
first_free_task_inc_no := next;
end;
end get_task_inc_no;
\f


procedure init_buffer_pool(sem_no,nb,bsize);
value nb,bsize,sem_no;
integer nb,bsize,sem_no;
begin <* the buffer_pool with no 'sem_no' is initialised with 'nb' buffers
each of length 'bsize' words *>

integer i;
integer array field j;

integer field s;

s:=2 * sem_no;
sem.s:=0;
 
for i:=1 step 1 until nb do
begin <* note that the buffers are put in first in the queue *>
j:=getbuf(bsize);
buf.j.next:=sem.s;        <* link to the next buffer *>
buf.j.home_pool:=s;       <* home semaphore *>
buf.j.length:=bsize;      <* length *>
sem.s:=j;
end;
end init buffer pool;



\f


procedure init_corout_descr(act_no,incarnation);
value act_no,incarnation;
integer act_no,incarnation;
begin <* initialises a coroutine description *>
c_corout:=8*act_no - 8+2;

corout.c_corout.next:=0;  <* chain *>
corout.c_corout.corout_no:=act_no;
corout.c_corout.incarn:=incarnation;
corout.c_corout.bf:=0;

c_corout_no:=act_no;
end init corout descr;

\f


procedure init_task_incarnations;
begin

<* The procedure initialises the task incarnation semaphores (one
_  task descriptor with type = 0 on each semaphore) and the list
_  of free task incarnation numbers.
*>

integer i;

<* initialise the task incarnation semaphores *>

<* Initialise the free_task_inc_no_list : *>

first_free_task_inc_no := 1;
last_free_task_inc_no := max_task_inc_no;
for i := 1 step 1 until last_free_task_inc_no - 1 do
free_task_inc_no_list(i) := i + 1;

free_task_inc_no_list(last_free_task_inc_no) := - 1;
end init_task_incarnations;
\f


procedure out_alarm_cause(zout);
zone zout;
begin <* prints the cause of the latest occurred alarm *>
integer cause,param;
long array text(1:4);

cause:=alarm_cause extract 24;
param:=alarm_cause shift (-24);
get_alarm(text);

if cause>=0 then write(zout,<: (:>,text,<:):>)
else
begin <* cause < 0 *>
write(zout, <: (:>, case -cause of (
_  <:stack:>,
_  <:index:>,
_  <:z.index:>,
_  <:case:>,
_  <:syntax:>,
_  <:integer:>,
_  <:real:>,
_  <:param:>,
_  <:break:>,
_  <:end:>,
_  <:giveup:>,
_  <:field:>,
_  <:trap:>),  param,<:):>);

if cause=-11 then  <* device status alarm *>
write(zout,text  <* the name of the document *>);
end cause < 0 ;


empty(zout);
end out alarm cause;



\f


procedure out_shortclock(zout,shortclock);
value shortclock;  integer shortclock;
zone zout;
begin <* prints a shortclock in the format
yy.mm.dd hh.mm

if you want 'current_time' then set
shortclock = systime(7,0,0.0)
*>
integer old_sp,old_dec_point;
real r;

old_sp:=replace_char(1 <* space in number *>,'.');
old_dec_point:=replace_char(4 <* decimal point *>,'sp');

write(zout,<<zd dd dd.dd dd>,
_     systime(6,shortclock,r)+r/1000000);

replace_char(1,old_sp);
replace_char(4,old_dec_point);
end out short clock;


\f


integer procedure read_ch (z, ch_no);
value ch_no;
zone z;
integer ch_no;
begin <* gets a character from the zone z *>
   read_ch:= z ((ch_no+5)//6) shift (8*((ch_no-1)mod 6 - 5)) extract 8;
end read ch;
\f

 
integer procedure read_int (z, start_no);
value start_no;
zone z;
integer start_no;
begin
   read_int:= (read_ch(z,start_no) shift 8) + read_ch (z,start_no+1);
end read int;
\f


procedure release_task_inc_no(no);
value no;
integer no;
begin

<* The procedure releases the given task incarnation number
_  to the free_task_inc_no_list.
*>

if free_task_inc_no_list(no) <> 0 then
<* the task_inc_no is not reserved *>
else
begin
free_task_inc_no_list(last_free_task_inc_no) := no;
free_task_inc_no_list(no) := - 1;
end;
end release_task_inc_no;
\f


procedure return_buf(bf);
integer array field bf;
<* the buffer is returned to its home_pool *>
signal(buf.bf.home_pool,bf);




\f


integer procedure sem_to_field(sem_no);
value sem_no; integer sem_no;
<* converts a semaphore number so that it can be used
as integer field pointing to the semaphore *>
sem_to_field:= 2 * sem_no;

\f


procedure send_timeout(task_inc_no,task_state,period);
value task_inc_no,period,task_state;
integer task_inc_no,period,task_state;
begin
<* The procedure signals to the timer that the given task will
_  expect a timeout after "period" seconds.
*>

integer array field buffer;

buffer := wait(timeout_pool);
buf.buffer.operation := 2;
buf.buffer.data(1) := period;
buf.buffer.data(3) := task_inc_no;
buf.buffer.data(4) := task_state;
signal(timer_sem,buffer);
end send_timeout;
\f


procedure set_table;
begin <* defines an in_table with all characters
having class = 'text' *>
integer i;

for i:=0 step 1 until 255 do
table(i):=6 shift 12 + i;

intable(table);
end set table;



\f


procedure testout(text,int);
value int; integer int;
string text;
if test or test_cl then
disable
begin <* used during debugging for test_output *>
real rctime,date,clock,millisecs;
long secs;
if (mask shift (-c_corout_no)) extract 1 = 1 or test_cl then
begin
systime(1,0,rctime);
secs:=rctime-0.5;
millisecs:=rctime-secs;
date:=systime(4,rctime,clock);
clock:=clock+millisecs;

write(out,<<dd dd dd>,date,"-",1,<<dd dd dd.ddd>,clock,
"sp",2,<<ddd>,
text,"sp",2,int,<:  (coroutine no :>,c_corout_no,<:):>,"nl",1);
if -,test_on_bs then setposition(out,0,0);
end;
end test out;


\f


procedure utility (taskincarn, timeout, mess, zout);
integer taskincarn;
boolean timeout;
real array mess;
zone zout;
begin
end utility;
\f


<********** monitor procedures **********>

procedure signal(s,b);
integer field s;
integer array field b;
begin <* the buffer 'b' is signalled on the semaphore 's' *>
integer array field i;

if test or test_cl then testout(<:before signal,sem:>,s);
if test or test_cl then testout(<:before signal,buf:>,b);
buf.b.next:=0;

buf.b.length:= buf.b.length extract 12;
if sem.s>0 then
begin <* the semaphore is open *>
i:=sem.s;

while buf.i.next > 0 do i:=buf.i.next;

buf.i.next:=b;
end open
else
if sem.s=0 then <* neutral *> sem.s:=b
else
begin <* the semaphore is closed. we will hang
the first of the waiting coroutines on the ready_q *>
i:=-sem.s;
sem.s:=-corout.i.next;
corout.i.bf:=b;
buf.b.length:=
corout.i.corout_no shift 12 + buf.b.length;
corout.i.next:=0;

if ready_q_first<>0 then
corout.ready_q_last.next:=i
else
ready_q_first:=i;

ready_q_last:=i;
end closed;

end signal;
\f


integer procedure wait(s);
integer field s;
begin <* passivates the coroutine until something arrives
on the semaphore 's' *>
integer array field i;

if test or test_cl then testout(<:before wait, sem:>,s);
if sem.s>0 then
begin <* a buffer is ready, the semaphore is open *>
corout.c_corout.bf:=sem.s;
i:=sem.s;
sem.s:=buf.i.next;
buf.i.length:=corout.c_corout.corout_no shift 12+buf.i.length extract 12;
end open
else
begin <* hang the coroutine on the semaphore *>
corout.c_corout.next:=0;

if sem.s=0 then <* neutral *> sem.s:=-c_corout
else
begin <* the semaphore is closed *>
i:=-sem.s;

while corout.i.next <> 0 do
i:=corout.i.next;

corout.i.next:=c_corout;
end closed;

passivate;
end hang;

wait:=corout.c_corout.bf;
if test or test_cl then testout(<:after wait, buf:>,corout.ccorout.bf);
end wait;

\f


<********** coroutine procedures **********>

algol list.on copy.logmodule;
 
procedure message_handler;
begin
 
integer no_of_hwords, ch_no, no_of_by, rec_macro, rec_micro,
_       task_incarn, send_macro, send_micro, upd_res,
_       op_code, hour, min_sec;
 
zone zin(20,1,dastderror), <* input from the screen *>
_    zout(30,1,dastderror); <* output to the screen *>

long array inprocname, outprocname (1:2);
 
procedure unpack_label;
begin
no_of_by:=   read_int (zin,1);
rec_macro:=  read_int (zin,3);
task_incarn:= (read_int (zin,5)) shift (-8);
rec_micro:=  read_int(zin,5) extract 8;
send_macro:= read_int (zin,7);
send_micro:= read_int (zin,9);
upd_res:=    read_ch (zin,12);
hour:=       read_int (zin,13);
min_sec:=    read_int (zin,15);
end unpack label;

procedure group_0;
begin
integer i;
 
unpack_label;

<* write a log on current output *>
write (out, <:log:>, <<  dddd>, no_of_by, rec_macro, rec_micro,
send_macro, send_micro, op_code, upd_res, hour, min_sec, "nl",1);

if no_of_by>40 then no_of_by:=40;

for i:= 17 step 1 until no_of_by do
write (out, read_ch(zin,i));
write (out, "nl", 1);
setposition (out,0,0);
 
 
end group_0;
 
procedure group_1;
begin end;
 
procedure group_2;
begin end;
 
procedure group_3;
begin end;
 
procedure group_4;
begin end;

procedure group_5;
begin end;

procedure group_6;
begin end;

procedure group_7;
begin end;

procedure group_8;
begin end;

procedure group_9;
begin end;

procedure group_10;
begin end;

procedure group_11;
begin end;

procedure group_12;
begin end;

procedure group_13;
begin end;

procedure group_14;
begin end;

procedure group_15;
begin end;
 
 
<**  message handler  **>

inprocname(1):= long <:strea:>+'m';
inprocname(2):= long (<:in:>);
 
initzone (zin, 0, inprocname, 0, 3 shift 12+stream_amh, 0);

outprocname(1):= long (<:strea:> add 'm');
outprocname(2):= long (<:out:>);

initzone (zout, 0, outprocname, 0, 5 shift 12+stream_amh, 0);
 

repeat
 
sendbuffer (zin, 80);
no_of_hwords:= getbuffer (zin);
 
if no_of_hwords < 1 then
else

task_incarn:= (read_int (zin,5)) shift (-8);

if task_incarn>0 then
begin
unpack_mess (zin);
utility (task_incarn, false, zin,zin);
end

else if task_incarn= 0 then
begin
op_code:= read_ch (zin,11);
 
case op_code shift (-4) + 1 of
begin
group_0;
group_1;
group_2;
group_3;
group_4;
group_5;
group_6;
group_7;
group_8;
group_9;
group_10;
group_11;
group_12;
group_13;
group_14;
group_15
end
end
 
else <* task_incarn<0 ! *>
 
until false
 
end message handler;
\f


<* procedure al_opt; *>
<* algol copy.alopt; *>
 
<* procedure exph; *>
<* algol copy.exph; *>

<* procedure dmh; *>
<* algol copy.dmh; *>

<* procedure dov_opt; *>
<* algol copy.dov_opt; *>
\f


procedure tick_generator;
begin

<* The tick generator communicates with the RC8000 clock driver
_  and sends a tickbuffer to the timer module every 10 secs.
*>

long current_time, next_time;
integer array clock_mess(1:12),answer(1:8);
integer array field buffer;
zone clock(1,1,stderror);

open(clock,2,<:clock:>,1 shift 9);
getshare6(clock,clock_mess,1);
clock_mess(4) := 0;

repeat
current_time := getclock // 10000;
next_time := current_time // 10 * 10 + 15;
clock_mess(5) := next_time - current_time;
setshare6(clock,clock_mess,1);
monitor(16) send message:(clock,1,answer);
monitor(18) wait answer:(clock,1,answer);
buffer := wait(tick_sem);
buf.buffer.operation := 1;
signal(timer_sem,buffer)
until false;
end tick_generator;

\f


procedure timer;
begin

integer array field timer_buf,buffer,previous_buffer,waiting_q;

real field time;

real current_time, last_time, buffer_time;

boolean found, adjust;

procedure dump_wq(text);
string text;
begin <* dumps the waiting q on current output *>
integer array field iaf1;
real r;

write(out,<:waiting queue dump from timer :>,text,"nl",1);
iaf1:=waitingq;

if waitingq=0 then write(out,<:waiting q empty:>,"nl",1)
else
while iaf1<>0 do
begin
write(out,iaf1,<<   dd dd dd>,systime(2,buf.iaf1.data.time,r),
_    r,"nl",1);
iaf1:=buf.iaf1.next;
end;
if -,test_on_bs then setposition(out,0,0);
end dump wq;


begin integer array dummy(1:100);
end;



time:=4;
waiting_q:=0;
systime(1,0,last_time);

repeat

if test then dumpwq(<:before wait on timersem:>);
timer_buf:=wait(timer_sem);

case buf.timer_buf.operation of
begin

<* 1 *>
begin <* clock pulse *>

if waiting_q<>0 then
begin <* the waiting q is not empty.
search the queue for buffers with expired waiting time *>

systime(1,0,current_time);
adjust := current_time < last_time - 10;
previous_buffer:=0;
buffer:=waiting_q;
found:=false;

repeat
if adjust  then  buf.buffer.data.time :=
   buf.buffer.data.time - last_time + current_time;

if buf.buffer.data.time<=current_time then
begin <* the waiting time for this buffer (and the rest
of the q) has expired *>
found:=true;
end
else
begin <* look at the next buffer *>
previous_buffer:=buffer;
buffer:=buf.buffer.next;
end;
until found or (buffer=0);

last_time := current_time;

if found then
begin <* signal the buffers fron 'buffer' and out
to their respective semaphores *>
<* first we remove the tail of expired buffers from
the waiting q *>

if previous_buffer=0 then
waiting_q:=0  <* remove the entire q *>
else
buf.previous_buffer.next:=0;

repeat <* signal the buffers *>
previous_buffer:=buffer;
buffer:=buf.buffer.next;
signal(timeout_handler_sem,previous_buffer);
until buffer=0;

end found;
end waiting q not empty;

returnbuf(timer_buf);
end clock pulse;

<* 2 *>
begin <* waiting_request. the buffer is inserted in the waiting q
at the proper place *>

systime(1,0,current_time);
buffer_time:=buf.timer_buf.data(1) <* waiting time in secs *>
_       + current_time;

buf.timer_buf.data.time:=buffer_time;
if test then dump_wq(<: after new buffer time= :>);

if waiting_q=0 then
begin <* the q is empty *>
waiting_q:=timer_buf;
buf.timer_buf.next:=0;
end
else
begin <* search for the 
proper place to insert it *>
previous_buffer:=0;
buffer:=waiting_q;
found:=false;

repeat
if buffer_time>buf.buffer.data.time then found:=true 
else
begin <* try the next *>
previous_buffer:=buffer;
buffer:=buf.buffer.next;
end;
until found or (buffer=0);

if previous_buffer=0 then
begin <* insert in front of the waiting q *>
buf.timer_buf.next:=waiting_q;
waiting_q:=timer_buf;
end
else
begin <* insert between previous_buffer and buffer *>
buf.timer_buf.next:=buffer;
buf.previous_buffer.next:=timer_buf;
end;
end insert;
end request waiting;

<* 3 *>
begin <* cancel timeout *>
if waiting_q <> 0 then
begin
previous_buffer := 0;
buffer := waiting_q;
found := false;
repeat
if buf.buffer.data(3) = buf.timer_buf.data(3) then
found := true
else
begin
previous_buffer := buffer;
buffer := buf.buffer.next;
end
until found or buffer = 0;

if found then
begin
if previous_buffer = 0 then
waiting_q := 0
else
buf.previous_buffer.next := buf.buffer.next;
return_buf(buffer);
end;
end;
return_buf(timer_buf);
end;

<* 4 *>

begin <* clear task *>
if waiting_q <> 0 then
begin
previous_buffer := 0;
buffer := waiting_q;
found := false;
repeat
if buf.buffer.data(3) = buf.timer_buf.data(3) then
found := true
else
begin
previous_buffer := buffer;
buffer := buf.buffer.next;
end
until found or buffer = 0;

if found then
begin
if previous_buffer = 0 then
waiting_q := 0
else
buf.previous_buffer.next := buf.buffer.next;
return_buf(buffer);
end;
end;
signal(timeout_handler_sem,timer_buf);
end;

end case;
until false;
end timer;
\f


procedure timeout_handler;
begin
<* The timeout handler receives buffers with expired delay period from
_  the timer module. The timeout is serviced using the procedure UTILITY.
_  The timeout handler also finishes the task incarnations when receiving
_  a clearing-buffer.
*>

integer array field buffer, task_descr;
real array task_state(1:1);
zone dummy(40,1,stderror);

repeat
buffer := wait(timeout_handler_sem);
case buf.buffer.operation of
begin
<* 1 *>
begin
<* not used *>
end;

<* 2 *>
begin <* timeout *>
task_state(1) := real(extend buf.buffer.data(4) shift 24);
utility(buf.buffer.data(3),true,task_state,dummy);
end;

<* 3 *>
begin
<* not used *>
end;

<* 4 *>
begin <* clear task *>
task_descr := wait(buf.buffer.data(3) * 2);
buf.task_descr.td_state := buf.task_descr.td_type := 0;
release_task_inc_no(buf.buffer.data(3));
return_buf(task_descr);
end;
end case;
return_buf(buffer)   
until false;
end timeout_handler;
\f


<********** initialise constants **********>

testout (<:phoenix started:>,0);
trap(traplab);
mask:=2**20-1;
free_core;
set_table;

stdnetdelay:=   30 <*seconds *>;
stdoptdelay:= 5*60 <*seconds *>;

iaf:=0;
buffer_head_length:=4;

em_record(1) := real(extend 8 shift 24);
em_record(2) := real(extend (-1));


<* field variables *>
 
next:=2;
homepool:=4;
length:=6;
operation:=8;

<* task descriptor *>
td_type := 10;
td_state := 12;
td_db_ref := 12;
td_info := 16;

corout_no:=4;
incarn:=6;
bf:=8;
data:=2*buffer_head_length;
 
<* alarm message label *>
lab_no_of_by:= 2;
lab_rec_macro:= lab_no_of_by+2;
lab_rec_micro:= lab_rec_macro+2;
lab_send_macro:= lab_rec_micro+2;
lab_send_micro:= lab_send_macro+2;
lab_opc_upd:= lab_send_micro+2;
lab_hour:= lab_opc_upd+2;
lab_min_sec:= lab_hour+2;
lab_data:= lab_min_sec;

 
<*semaphores and pools *>

tick_sem_no := 1 + max_task_inc_no;
timer_sem_no := 2 + max_task_inc_no;
timeout_handler_sem_no := 3 + max_task_inc_no;
timeout_pool_no := 4 + max_task_inc_no;
log_key_sem_no := 5 + max_task_inc_no;


tick_sem := sem_to_field(tick_sem_no);
timer_sem := sem_to_field(timer_sem_no);
timeout_handler_sem := sem_to_field(timeout_handler_sem_no);
timeout_pool := sem_to_field(timeout_pool_no);
log_key_sem := sem_to_field(log_key_sem_no);

<********** initialise variables **********>
  
phoenix_finished:=false;
ready_q_first:=0;
bufbase:=2;
buffer_addr:=0;
request_to_restart:=false;
current_block := 1;
current_log_file := 1;
halfwords_available := 128 * 4 * segm_pr_block;
min_for_this_block := extend (-1) shift (-1);
log_change_forced := false;
open(z_log,4,<:disclog1:>,0);
setposition(z_log,0,segm_pr_block);
\f


<*********** initialise buffer pools **********>

for i := 1 step 1 until max_task_inc_no do
init_buffer_pool(i,1,6);
init_buffer_pool(tick_sem_no,1,0);
init_buffer_pool(timer_sem_no,0,0);
init_buffer_pool(timeout_handler_sem_no,0,0);
init_buffer_pool(timeout_pool_no,max_task_inc_no+10,4);
init_buffer_pool(log_key_sem_no,1,0);

<********** initialise streamer **********>

stream_log:= 1;
stream_amh:= 2;
stream_alopt:= 3;

outprocname(1):= long (<:stream:> add 'm');
outprocname(2):= long (<:out:>);
initzone (zopt, 0, outprocname, 0, 5 shift 12 + stream_alopt, 0);
 
<********** initialise database **********>

db_key_lg:= 8;
db_data_lg:= 48;
<* dc_number:= ?; *>

<********** initialise alarm environment **********>

<*** update field ***>
read_code:= 0;
insert_code:= 1;
modify_code:= 2;
remove_code:= 3;

start_code:= 0;
stop_code:= 1;
service_code:= 2;

<*** micro addresses ***>
tss_mic_addr:= 0;
ath_mic_addr:= 1;
vch_mic_addr:= 2;
netc_mic_addr:= 3;

 
 
<********** start the coroutines **********>
 
 
 
 
activity(no_of_mhs + 4);

<* log handler *>
<***************>

a := 1;
incarnation := 0;
init_corout_descr(a,incarnation);
new_activity(a,0,log_handler);


<* message handler *>
<*******************>
 
a:= a + 1;
incarnation:= 0;
init_corout_descr(a,0);
new_activity (a,0,message_handler);

<* tick generator *>
<******************>

a := a + 1;
incarnation := 0;
init_corout_descr(a,incarnation);
new_activity(a,0,tick_generator);


<* timer *>
<*********>

a:= a+1;
incarnation:=0;
init_corout_descr(a,0);
new_activity(a,0,timer);

<* timeout handler *>
<*******************>

a := a + 1;
incarnation := 0;
init_corout_descr(a,incarnation);
new_activity(a,0,timeout_handler);

 
 
free_core;






\f


<********** central logic **********>

begin
integer array answer(1:8);
zone z1(1,1,stderror);


repeat
c_corout_no:=0;

if ready_q_first<>0 then
i:=monitor(66,z1,buffer_addr,answer) else
i:=monitor(24,z1,buffer_addr,answer);
if test then testout(<:central logic, i=:>,i);
if test then testout(<:ready_q_first=:>,ready_q_first);

if i>0 then
begin
begin <* answer to a coroutine recived *>
c_corout_no:=answer(1);
c_corout:=8*c_corout_no-8+2;
end
end
else

if i=0 then
begin <* message received *>
<* receive the message and link it on a semaphore.
alarm messages and timer_messages are copyed to internal
buffers and answered immediately.
Other messages are answered by the relevant coroutine *>
decode_message;
end message 
else

begin <* event-que empty *>
<* no external event. If there are any coroutines in the
event-que then start the first *>


if ready_q_first<>0 then
begin
<* start the first coroutine in the ready_que *>
c_corout:=ready_q_first;
c_corout_no:=corout.c_corout.corout_no;
ready_q_first:=corout.c_corout.next;
corout.c_corout.next:=0;
if ready_q_first=0 then ready_q_last:=0;
end;
end event_que empty;






if c_corout_no>0 then
begin
if test or test_cl then testout(<:start coroutine no:>,c_corout_no);

cause:=activate(c_corout_no);

if cause<1 then
begin <* restart phoenix *>
if test then testout(<:central logic, activate-value:>,cause);
request_to_restart:=true;
end;

buffer_addr:=0;
end;


until phoenix_finished or request_to_restart;
end;


traplab:
end program;

\f


<*********** installation parameters **********>

start_up_time:=systime(7,0,0.0);
version:=0 shift 8 + 4;
no_of_restarts:=0;
no_of_mhs:= 1;
test:=true;
test_cl:=true;
test_on_bs:=false;

buf_array_length:= 100;
max_task_inc_no := 20;
no_of_sems := max_task_inc_no + 5;
segm_pr_block := 2;
max_block_no := 50;
warning_block_no := max_block_no * 0.75;
max_mess_lgh := 30;

repeat
last_restart_time:=systime(7,0,0.0);
program;
no_of_restarts:=no_of_restarts+1;
until phoenix_finished;

end
if warning.yes
(message warning compilation of phoenix not ok
finis)
message compilation of phoenix ok

finis

▶EOF◀