⟦308c97c02⟧

TextFile

 
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,
no_of_mhs,
no_of_sems,
no_of_restarts,
start_up_time,
version;



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 *>
i,                        <* auxiliary variabel *>
incarnation,              <* used during start of the coroutines *>
mask;                     <* used by testout *>
  
 
 
integer array field
<*****************>

c_corout,                 <* used in coroutine descriptions *>
data,                     <* used in buffers *>
ready_q_first,
ready_q_last,
iaf;                      <* used in zones *>



boolean
<*****>

request_to_restart;


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

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


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



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

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


integer field
<***********>
timer_sem;



integer array
<***********>
 
buf(1:buf_array_length),
corout(1:(no_of_mhs + 2<*timer*>) * 4<*coroutsize*> + 1),
sem(1:no_of_sems),
table(0:255);             <* used for input conversion *>
 
 
\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


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 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


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 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


<********** 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 **********>
 
procedure message_handler;
begin
 
integer no_of_hwords, streamno, 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);
 
integer procedure read_ch (ch_no);
value ch_no; integer ch_no;
begin <* gets a character from the zone zin *>
read_ch:= zin ((ch_no+5)//6) shift (8*((ch_no-1)mod 6-5)) extract 8;
end read ch;
 
integer procedure read_int (start_no);
integer start_no;
begin
read_int:= (read_ch(start_no) * 256) + read_ch(start_no+1)
end read int;
 
procedure unpack_label;
begin
no_of_by:= read_int (1);
rec_macro:= read_int (3);
task_incarn:= (read_int (5)) shift (-8);
rec_micro:= read_int (5) extract 8;;
send_macro:= read_int (7);
send_micro:= read_int (9);
upd_res:= read_ch (12);
hour:= read_int (13);
min_sec:= read_int (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(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 *>
algol copy.grp15;
 
 
<**  message handler  **>

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

repeat
 
sendbuffer (zin, 80);
no_of_hwords:= getbuffer (zin);
else
if no_of_hwords < 1 then
if no_of_chars= 0 then
else
 
begin
op_code:= read_ch (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
 
until false
 
end message handler;
\f


<* procedure al_opt; *>
algol copy.al_opt;
\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(buf.previous_buffer.data(3),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);
buf.timer_buf.operation:=buf.timer_buf.data(2);
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;
end case;
until false;
end timer;

\f


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

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

iaf:=0;
buffer_head_length:=4;


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

corout_no:=4;
incarn:=6;
bf:=8;
data:=2*buffer_head_length;
\f

 
<********** initialise variables **********>
  
phoenix_finished:=false;
ready_q_first:=0;
bufbase:=2;
buffer_addr:=0;
request_to_restart:=false;

\f


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


\f


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

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

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

a:= a+1;
incarnation:=0;
init_corout_descr(a,0);
<*new_activity(a,0,timer);*>
 
 
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_sems:= 1;
no_of_mhs:= 1;
test:=true;
test_cl:=true;
test_on_bs:=false;

buf_array_length:= 100;


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◀
DataMuseum.dk

RC4000/8000/9000

⟦308c97c02⟧ TextFile

Derivation

TextFile
