|
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: 49152 (0xc000)
Types: TextFile
Names: »htmon «
└─⟦cde9d517b⟧ Bits:30007477 RC8000 Backup tape fra HT's bus-radio system
└─⟦6a563b143⟧
└─⟦this⟧ »htmon «
└─⟦110021343⟧ Bits:30007476 RC8000 Backup tape fra HT's bus-radio system
└─⟦a957ba283⟧
└─⟦this⟧ »htmon «
algol8 coroutine monitor. lkn 79.06.14 version 1.0
begin algol list.off;
<* variables for claiming (accumulating) basic entities *>
integer maxsem, maxsemch, maxop, maxcoru, maxmessext, maxprocext, maxnettoop;
<* fields defining current position in pools af basic entities
during initialization *>
integer array field firstsem, firstsim, firstcoru, firstop, optop;
<* variables used as pointers to 'current object' (work variables) *>
integer messext, procext, timeinterval, testbuffering;
integer array field timermessage, coru, sem, op, receiver, currevent,
baseevent, prevevent;
<* variables defining the size of basic entities (descriptors) *>
integer corusize, semsize, simsize, opheadsize;
integer array clockmess(1:2);
real array clock(1:3);
boolean eventqueueempty;
algol list.on;
<* :1: declaration of trimming variables .......................... *>
\f
algol list.off;
message coroutinemonitor - 2 ;
maxsem:= maxsemch:= maxop:= maxcoru:= maxnettoop:= 0;
maxmessext:= maxprocext:= 1;
corusize:= 20;
simsize:= 6;
semsize:= 8;
opheadsize:= 8;
testbuffering:= 1;
timeinterval:= 5;
algol list.on;
algol list.on;
<* :2: initialization of trimming variables ....................... *>
<* :3: claiming of basic elements (semaphores, corutines etc.) .... *>
\f
algol list.off;
message coroutinemonitor - 3 ;
begin
<* work variables - primarily used during initialization *>
integer array field simref, semref, coruref, opref;
integer proccount, corucount, messcount, cmi, cmj;
integer array zoneia(1:20);
<* field variables describing the format of basic entities *>
integer field
<* chain head *>
next, prev,
<* simple semaphore *>
simvalue, simcoru,
<* chained semaphore *>
semop, semcoru,
<* coroutine *>
coruop, corutimerchain, corutimer, corupriority, coruident,
<* operation head *>
opnext, opsize;
<*+1*>
<**> integer testheadsize;
<**> integer field testhead, testtime, testcoru;
<**> integer array field testdata;
<**> zone tz (128*testbuffering, testbuffering, endfileproc);
<**> boolean semtest, semchtest, ceventtest, semeventtest, schedulingtest;
<**> boolean teston;
<*-1*>
\f
message coroutinemonitor - 4 ;
boolean field
corutypeset, corutestmask, optype;
real starttime;
long corustate;
<* field variables used as queue identifiers (addresses) *>
integer array field current, readyqueue, idlequeue, timerqueue;
<* extensions (message- and process- extensions) *>
integer array messref, messcode, messop (1:maxmessext);
integer array procref, proccode, procop (1:maxprocext);
<* core array used for accessing the core using addresses as field
variables (as delivered by the monitor functions)
- descriptor array 'd' in which all basic entities are allocated
(except for extensions) *>
integer array core (1:1), d (1:(4 <* readyqueue *> +
4 <* idlequeue *> +
4 <* timerqueue *> +
maxcoru * corusize +
maxsem * simsize +
maxsemch * semsize +
maxop * opheadsize +
maxnettoop)/2);
\f
message coroutinemonitor - 5 ;
<*************** initialization procedures ***************>
procedure initchain (chainref);
value chainref;
integer array field chainref;
begin
integer array field cref;
cref:= chainref;
d.cref.next:= d.cref.prev:= cref;
end;
\f
message coroutinemonitor - 6 ;
<***** nextsem *****
this procedure allocates and initializes the next simple semaphore in the
pool of claimed semaphores.
the procedure returns the identification (the address) of the semaphore to
be used when calling 'signal', 'wait' and 'inspect'. *>
integer procedure nextsem;
begin
nextsem:= simref;
if simref >= firstsem then initerror(1, true);
initchain(simref + simcoru);
d.simref.simvalue:= 0;
simref:= simref + simsize;
end;
<***** nextsemch *****
this procedure allocates and initializes the next simple semaphore in the
pool of claimed semaphores.
the procedure returns the identification (the address) of the semaphore to
be used when calling 'signalch', 'waitch' and 'inspectch'. *>
integer procedure nextsemch;
begin
nextsemch:= semref;
if semref >= firstop-4 then initerror(2, true);
initchain(semref + semcoru);
initchain(semref + semop);
semref:= semref + semsize;
end;
\f
message coroutinemonitor - 7 ;
<***** nextcoru *****
this procedure initializes the next coroutine description in the pool of
claimed coroutine descriptions.
at initialization is defined the priority (an integer value), an identi-
fication (an integer value 0..8000) and a test pattern (a boolean). *>
integer procedure nextcoru(ident, priority, testmask);
value ident, priority, testmask;
integer ident, priority;
boolean testmask;
begin
corucount:= corucount + 1;
if corucount > maxcoru then initerror(3, true);
nextcoru:= corucount;
initchain(coruref + next);
initchain(coruref + corutimerchain);
initchain(coruref + coruop);
d.coruref.corupriority:= priority;
d.coruref.coruident:= ident * 1000 + corucount;
d.coruref.corutypeset:= false;
d.coruref.corutimer:= 0;
d.coruref.corutestmask:= testmask;
linkprio(coruref, readyqueue);
current:= coruref;
coruref:= coruref + corusize;
end;
\f
message coroutinemonitor - 8 ;
<***** nextop *****
this procedure initializes the next operation in the pool of claimed ope-
rations (heads and buffers).
the head is allocated and immediately following the head is allocated 'size'
halfwords forming the operation buffer.
the procedure returns an identification of the operation (an address) and
in case this address is held in a field variable 'op', the buffer area may
be accessed as: d.op(1), d.op(2), d.op(3) ... *>
integer procedure nextop (size);
value size;
integer size;
begin
nextop:= opref;
if opref >= optop then initerror(4, true);
initchain(opref + next);
d.opref.opsize:= size;
opref:= opref + size + opheadsize;
end;
\f
message coroutinemonitor - 9 ;
<***** nextprocext *****
this procedure initializes the next process extension in the series of
claimed process extensions.
the process description address is put into the process extension and the
state of the extension is initialized to be closed. *>
integer procedure nextprocext (processref);
value processref;
integer processref;
begin
proccount:= proccount + 1;
if proccount >= maxprocext then initerror(5, true);
nextprocext:= proccount;
procref(proccount):= processref;
proccode(proccount):= 1 shift 12;
end;
\f
message coroutinemonitor - 10 ;
<***** initerror *****
this procedure is activated in case the initialized set of resources does
not match the claimed set.
in case more resources are claimed than used, a warning is written,
in case too few resources are claimed, an error message is written and
the execution is terminated. *>
procedure initerror (resource, exceeded);
value resource, exceeded;
integer resource; boolean exceeded;
begin
write(out, false add 10, 1,
if exceeded then <:more :> else <:less :>,
case resource of (
<:simple semaphores:>,
<:chained semaphores:>,
<:coroutines:>,
<:operations:>,
<:process extensions:>),
<: initialized than claimed:>,
false add 10, 1);
if exceeded then goto dump;
end;
<***** stackclaim *****
this procedure is used by a coroutine from its first activation to it
arrives its first waiting point. the procedure is used to claim an addi-
tional amount of stack space. this must be done because the maximum
stack space for a coroutine is set to be the max amount used during its
very first activation. *>
procedure stackclaim (size);
value size; integer size;
begin
boolean array stackspace (1:size);
end;
algol list.on;
<* :4: procedures and common variables ........................... *>
\f
algol list.off;
message coroutinemonitor - 11 ;
<*************** coroutine monitor procedures ***************>
<***** delay *****
this procedure links the calling coroutine into the timerqueue and sets
the timeout value to 'timeout'. *>
procedure delay (timeout);
value timeout;
integer timeout;
begin
link(current, idlequeue);
link(current + corutimerchain, timerqueue);
d.current.corutimer:= timeout;
<*+1*>
<**> if (d.current.corutestmask and schedulingtest) extract 12 <> 0
<**> then test_val(7, timeout);
<*-1*>
passivate;
d.current.corutimer:= 0;
end;
\f
message coroutinemonitor - 12 ;
<***** pass *****
this procedure moves the calling coroutine from the head of the ready
queue down below all coroutines of lower or equal priority. *>
procedure pass;
begin
linkprio(current, readyqueue);
<*+1*>
<**> if (d.current.corutestmask and schedulingtest) extract 12 <> 0
<**> then test_0(8);
<*-1*>
passivate;
end;
<***** signal ****
this procedure increases the value af 'semaphore' by 1.
in case some coroutine is already waiting, it is linked into the ready
queue for activation. the calling coroutine continues execution. *>
procedure signal (semaphore);
value semaphore;
integer semaphore;
begin
integer array field sem;
sem:= semaphore;
if d.sem.simvalue < 0 then linkprio(d.sem.simcoru, readyqueue);
d.sem.simvalue:= d.sem.simvalue + 1;
<*+1*>
<**> if
<**> if current = 0 then true
<**> else (d.current.corutestmask and semtest) extract 12 <> 0
<**> then test_rec(1, sem+prev-2, simsize);
<*-1*>
end;
\f
message coroutinemonitor - 13 ;
<***** wait *****
this procedure decreases the value of 'semaphore' by 1.
in case the value of the semaphore is negative after the decrease, the
calling coroutine is linked into the semaphore queue waiting for a
coroutine to signal this semaphore. *>
procedure wait (semaphore);
value semaphore;
integer semaphore;
begin
integer array field sem;
sem:= semaphore;
d.sem.simvalue:= d.sem.simvalue - 1;
<*+1*>
<**> if (d.current.corutestmask and semtest) extract 12 <> 0
<**> then test_rec(2, sem+prev-2, simsize);
<*-1*>
linkprio(current, if d.sem.simvalue < 0 then sem+simcoru else readyqueue);
passivate;
end;
\f
message coroutinemonitor - 14 ;
<***** inspect *****
this procedure inspects the value of the semaphore and returns it in
'elements'.
the semaphore is left unchanged. *>
procedure inspect (semaphore, elements);
value semaphore;
integer semaphore, elements;
begin
integer array field sem;
sem:= semaphore;
elements:= d.sem.simvalue;
<*+1*>
<**> if (d.current.corutestmask and semtest) extract 12 <> 0
<**> then test_rec(5, sem+prev-2, simsize);
<*-1*>
end;
\f
message coroutinemonitor - 15 ;
<***** signalch *****
this procedure delivers an operation at 'semaphore'.
in case another coroutine is already waiting for an operation of the
kind 'operationtype' this coroutine will get the operation and it will
be put into the ready queue for activation.
in case no coroutine is waiting for the actial kind of operation it is
linked into the semaphore queue, at the end of the queue
if operation is positive and at the beginning if operation is negative.
the calling coroutine continues execution. *>
procedure signalch (semaphore, operation, operationtype);
value semaphore, operation, operationtype;
integer semaphore, operation;
boolean operationtype;
begin
integer array field firstcoru, currcoru, op,currop;
op:= abs operation;
d.op.optype:= operationtype;
firstcoru:= semaphore + semcoru;
currcoru:= d.firstcoru.next;
while currcoru <> firstcoru do
begin
if (d.currcoru.corutypeset and operationtype) extract 12 <> 0 then
begin
link(operation, 0);
d.currcoru.coruop:= operation;
linkprio(currcoru, readyqueue);
link(currcoru + corutimerchain, idlequeue);
goto exit;
end else currcoru:= d.currcoru.next;
end;
currop:=semaphore + semop;
if operation < 0 then currop:=d.currop.next;
link(op, currop);
exit:
<*+1*>
<**> if
<**> if current = 0 then true
<**> else (d.current.corutestmask and semchtest) extract 12 <> 0 then
<**> begin
<**> test_rec(3, semaphore+prev-2, semsize);
<**> test_rec(23, op+opsize-2, d.op.opsize+opheadsize);
<**> end;
<*-1*>
end;
\f
message coroutinemonitor - 16 ;
<***** waitch *****
this procedure fetches an operation from a semaphore.
in case an operation matching 'operationtypeset' is already waiting at
'semaphore' it is handed over to the calling coroutine.
in case no matching operation is waiting, the calling coroutine is
linked to the semaphore.
in any case the calling coroutine will be stopped and all corouti-
nes are rescheduled. *>
procedure waitch (semaphore, operation, operationtypeset, timeout);
value semaphore, operationtypeset, timeout;
integer semaphore, operation, timeout;
boolean operationtypeset;
begin
integer array field firstop, currop;
firstop:= semaphore + semop;
currop:= d.firstop.next;
<*+1*>
<**> if (d.current.corutestmask and semchtest) extract 12 <> 0
<**> then test_rec(4, semaphore+prev-2, semsize);
<*-1*>
while currop <> firstop do
begin
if (d.currop.optype and operationtypeset) extract 12 <> 0 then
begin
link(currop, 0);
d.current.coruop:= currop;
operation:= currop;
\f
message coroutinemonitor - 17 ;
linkprio(current, readyqueue);
passivate;
goto exit;
end else currop:= d.currop.next;
end;
linkprio(current, semaphore + semcoru);
if timeout > 0 then
begin
link(current + corutimerchain, timerqueue);
d.current.corutimer:= timeout;
end else d.current.corutimer:= 0;
d.current.corutypeset:= operationtypeset;
passivate;
if d.current.corutimer < 0 then operation:= 0
else operation:= d.current.coruop;
d.current.corutimer:= 0;
currop:= operation;
d.current.coruop:= currop;
link(current+corutimerchain, idlequeue);
exit:
<*+1*>
<**> if (d.current.corutestmask and semchtest) extract 12 <> 0 and currop > 0
<**> then test_rec(23, currop+opsize-2, d.currop.opsize+opheadsize);
<*-1*>
end;
\f
message coroutinemonitor - 18 ;
<***** inspectch *****
this procedure inspects the queue of operations waiting at 'semaphore'.
the number of matching operations are counted and delivered in 'elements'.
if no operations are found the number of coroutines waiting
for operations of the typeset are counted and delivered as
negative value in 'elements'.
the semaphore is left unchanged. *>
procedure inspectch (semaphore, operationtypeset, elements);
value semaphore, operationtypeset;
integer semaphore, elements;
boolean operationtypeset;
begin
integer array field firstop, currop,firstcoru,currcoru;
integer counter;
counter:= 0;
firstop:= semaphore + semop;
currop:= d.firstop.next;
while currop <> firstop do
begin
if (operationtypeset and d.currop.optype) extract 12 <> 0 then
counter:= counter + 1;
currop:= d.currop.next;
end;
if counter=0 then
begin
firstcoru:=semaphore + sem_coru;
curr_coru:=d.firstcoru.next;
while curr_coru<>first_coru do
begin
if (operationtypeset and d.curr_coru.corutypeset) extract 12 <>0 then
counter:=counter - 1;
curr_coru:=d.curr_coru.next;
end;
end;
elements:= counter;
<*+1*>
<**> if (d.current.corutestmask and semchtest) extract 12 <> 0
<**> then test_rec_val(6, semaphore+prev-2, semsize, counter);
<*-1*>
end;
\f
message coroutinemonitor - 19 ;
<***** csendmessage *****
this procedure sends the message in 'mess' to the process defined by the name
in 'receiver', and returns an identification of the message extension used
for sending the message (this identification is to be used for calling 'cwait-
answer' or 'cregretmessage'. *>
procedure csendmessage (receiver, mess, messextension);
real array receiver;
integer array mess;
integer messextension;
begin
integer bufref, messext;
messref(maxmessext):= 0;
messext:= 1;
while messref(messext) <> 0 do messext:= messext + 1;
if messext = maxmessext then <* no resources *> messext:= 0 else
begin
messcode(messext):= 1 shift 12 add 2;
mon(16) send message :(0, mess, 0, receiver);
messref(messext):= monw2;
if monw2 > 0 then messextension:= messext else messextension:= 0;
end;
<*+1*>
<**> if (d.current.corutestmask and ceventtest) extract 12 <> 0
<**> then test_arr_val(9, mess, 16, messext);
<*-1*>
end;
\f
message coroutinemonitor - 20 ;
<***** cwaitanswer *****
this procedure asks the coroutine monitor to get an answer to the message
corresponding to 'messextension'. in case the answer has already arrived
it stays in the eventqueue until 'cwaitanswer' is called.
in case 'timeout' is positive, the coroutine is linked into the timer
queue, and in case the answer does not arrive within 'timout' seconds the
coroutine is restarted with result = 0. *>
procedure cwaitanswer (messextension, answer, result, timeout);
value messextension, timeout;
integer messextension, result, timeout;
integer array answer;
begin
integer messext;
messext:= messextension;
messcode(messext):= messcode(messext) extract 12;
link(current, idlequeue);
messop(messext):= current;
if timeout > 0 then
begin
link(current + corutimerchain, timerqueue);
d.current.corutimer:= timeout;
end else d.current.corutimer:= 0;
<*+1*>
<**> if (d.current.corutestmask and ceventtest) extract 12 <> 0
<**> then test_val(10, messext);
<*-1*>
passivate;
if d.current.corutimer < 0 then result:= 0 else
begin
mon(18) wait answer :(0, answer, messref(messextension), 0);
result:= monw0;
baseevent:= 0;
messref(messextension):= 0;
end;
d.current.corutimer:= 0;
link(current+corutimerchain, idlequeue);
end;
\f
message coroutinemonitor - 21 ;
<***** cwaitmessage *****
this procedure asks the coroutine monitor to give it a message, when some-
one arrives. in case a message has arrived already it stays at the event queue
until 'cwaitmessage' is called.
in case 'timeout' is positive, the coroutine is linked into the timer queue,
if no message arrives within 'timeout' seconds, the coroutine is restarted
with messbufferref = 0. *>
procedure cwaitmessage (processextension, mess, messbufferref, timeout);
value timeout, processextension;
integer processextension, messbufferref, timeout;
integer array mess;
begin
integer i;
integer array field messbuf;
proccode(processextension):= 2;
procop(processextension):= current;
link(current, idlequeue);
if timeout > 0 then
begin
link(current + corutimerchain, timerqueue);
d.current.corutimer:= timeout;
end else d.current.corutimer:= 0;
<*+1*>
<**> if (d.current.corutestmask and ceventtest) extract 12 <> 0
<**> then test_val(11, processextension);
<*-1*>
passivate;
if d.current.corutimer < 0 then messbufferref:= 0 else
begin
messbuf:= procop(processextension);
for i:=1 step 1 until 8 do mess(i):= core.messbuf(4+i);
proccode(procext):= 1 shift 12;
messbufferref:= messbuf;
baseevent:= 0;
end;
d.current.corutimer:= 0;
link(current+corutimerchain, idlequeue);
end;
\f
message coroutinemonitor - 22 ;
<***** cregretmessage *****
this procedure regrets the message corresponding to messageexten-
sion, to release message buffer and message extension.
i/o messages are not regretable. *>
procedure cregretmessage (messageextension);
value messageextension;
integer messageextension;
begin
integer array field messbuf;
messbuf:= messref(messageextension);
mon(82) regret message :(0, 0, messbuf, 0);
messref(messageextension):= 0;
<*+1*>
<**> if (d.current.corutestmask and ceventtest) extract 12 <> 0
<**> then test_val(14, messageextension);
<*-1*>
end;
\f
message coroutinemonitor - 23 ;
<***** semsendmessage *****
this procedure sends the message 'mess' to 'receiver' and at the same time it
defines a 'signalch(semaphore, operation, operationtype)' to be performed
by the monitor, when the answer arrives.
in case there are too few resources to send the message, the operation is
returned immediately with the result field set to zero. *>
procedure semsendmessage (receiver, mess, semaphore, operation, operationtype);
value semaphore, operation, operationtype;
real array receiver;
integer array mess;
integer semaphore, operation;
boolean operationtype;
begin
integer array field op;
integer messext;
op:= operation;
messref(maxmessext):= 0;
messext:= 1;
while messref(messext) <> 0 do messext:= messext + 1;
if messext < maxmessext then
begin
messop(messext):= op;
messcode(messext):=1;
d.op(1):= semaphore;
d.op.optype:= operationtype;
mon(16) send message :(0, mess, 0, receiver);
messref(messext):= monw2;
end;
<*+1*>
<**> if (d.current.corutestmask and semeventtest) extract 12 <> 0
<**> then test_arr_val(12, mess, 8, semaphore);
<*-1*>
if messext = maxmessext or messref(messext) = 0 <* no resources *> then
begin <* return the operation immediately with result = 0 *>
d.op(9):= 0;
signalch(semaphore, op, operationtype);
end;
end;
\f
message coroutinemonitor - 24 ;
<***** semwaitmessage *****
this procedure defines a 'signalch(semaphore, operation, operationtype)' to
be performed by the coroutine monitor when a message arrives to the process
corresponding to 'processextension'. *>
procedure semwaitmessage (processextension, semaphore, operation, operationtype);
value processextension, semaphore, operation, operationtype;
integer processextension, semaphore, operation;
boolean operationtype;
begin
integer array field op;
op:= operation;
procop(processextension):= operation;
d.op(1):= semaphore;
d.op.optype:= operationtype;
proccode(processextension):= 1;
<*+1*>
<**> if (d.current.corutestmask and semeventtest) extract 12 <> 0
<**> then test_val_val(13, processextension, semaphore);
<*-1*>
end;
\f
message coroutinemonitor - 25 ;
<***** semregretmessage *****
this procedure regrets a message sent by semsendmessage.
the message is identified by the operation in which the answer should be
returned.
the procedure sets the result field of the operation to zero, and then
returns it by performing a signalch. *>
procedure semregretmessage (operation);
value operation;
integer operation;
begin
integer i, j;
integer array field op, sem;
op:= operation;
i:= 1;
while i < maxmessext do
begin
if messref(i) > 0 and (messcode(i) = 1 and messop(i) = op) then
begin
mon(82) regret message :(0, 0, messref(i), 0);
messref(i):= 0;
sem:= d.op(1);
for j:=1 step 1 until 9 do d.op(j):= 0;
signalch(sem, op, d.op.optype);
i:= maxmessext;
end;
i:= i + 1;
end;
<*+1*>
<**> if (d.current.corutestmask and semeventtest) extract 12 <> 0
<**> then test_val(15, op);
<*-1*>
end;
\f
message coroutinemonitor - 26 ;
<***** link *****
this procedure links an object (allocated in the descriptor array 'd') into
a queue of alements (allocated in the descriptor array 'd'). the queues
are all double chained, and the chainhead is of the same format as the chain
fields of the objects.
the procedure links the object immediately after the head. *>
procedure link (object, chainhead);
value object, chainhead;
integer object, chainhead;
begin
integer array field prevelement, nextelement, chead, obj;
obj:= object;
chead:= chainhead;
prevelement:= d.obj.prev;
nextelement:= d.obj.next;
d.prevelement.next:= nextelement;
d.nextelement.prev:= prevelement;
if chead > 0 then <* link into queue *>
begin
prevelement:= d.chead.prev;
d.obj.prev:= prevelement;
d.prevelement.next:= obj;
d.obj.next:= chead;
d.chead.prev:= obj;
end else
begin <* link onto itself *>
d.obj.prev:= obj;
d.obj.next:= obj;
end;
end;
\f
message coroutinemonitor - 27 ;
<***** linkprio *****
this procedure is used to link coroutines into queues corresponding to
the priorities of the actual coroutine and the queue elements.
the object is linked immediately before the first coroutine of lower prio-
rity. *>
procedure linkprio (object, chainhead);
value object, chainhead;
integer object, chainhead;
begin
integer array field currelement, chead, obj;
obj:= object;
chead:= chainhead;
currelement:= d.chead.next;
while currelement <> chead
and d.currelement.corupriority <= d.obj.corupriority
do currelement:= d.currelement.next;
link(obj, currelement);
end;
\f
message coroutinemonitor - 28 ;
<*+1*>
<**>
<**> procedure endfileproc (z, s, b);
<**> zone z; integer s, b;
<**> begin
<**> getzone6(z, zoneia);
<**> zoneia(9):= 1 + 128//zoneia(20);
<**> setzone6(z, zoneia);
<**> setposition(z, 0, zoneia(9)-1);
<**> end;
<**>
<**>
<**> procedure test_header (key, size);
<**> value key; integer key, size;
<**> begin
<**> integer bytes; real time;
<**> if size > 50 then size:= 50;
<**> bytes:= testheadsize + size;
<**> outrec6(tz, bytes);
<**> systime(1, starttime, time);
<**> tz.testhead:= bytes shift 12 + key;
<**> tz.testtime:= time * 1000;
<**> tz.testcoru:= if current = 0 then 0 else d.current.coruident;
<**> end;
<**>
<**>
<**> procedure test_0 (key);
<**> value key; integer key;
<**> if teston then
<**> begin
<**> test_header(key, 0);
<**> end;
<**>
<**>
<**> procedure test_val (key, integerval);
<**> value key, integerval; integer key, integerval;
<**> if teston then
<**> begin
<**> test_header(key, 2);
<**> tz.testdata(1):= integerval;
<**> end;
<**>
\f
message coroutinemonitor - 29 ;
<**>
<**> procedure test_arr (key, iar, size);
<**> value key, size; integer key, size;
<**> integer array iar;
<**> if teston then
<**> begin
<**> integer i;
<**> test_header(key, size);
<**> for i:=1 step 1 until size/2 do tz.testdata(i):= iar(i);
<**> end;
<**>
<**>
<**> procedure test_arr_val (key, iar, size, integerval);
<**> value key, size, integerval; integer key, size, integerval;
<**> integer array iar;
<**> if teston then
<**> begin
<**> integer i;
<**> test_header(key, size+2);
<**> for i:= 1 step 1 until size/2 do tz.testdata(i):= iar(i);
<**> tz.testdata(i):= integerval;
<**> end;
<**>
<**>
<**> procedure test_rec (key, recref, size);
<**> value key, size, recref; integer key, size, recref;
<**> if teston then
<**> begin
<**> integer bytes, i;
<**> integer array field ref;
<**> ref:= recref;
<**> test_header(key, size);
<**> for i:= 1 step 1 until size shift (-1) do tz.testdata(i):= d.ref(i);
<**> end;
<**>
\f
message coroutinemonitor - 30 ;
<**>
<**> procedure test_rec_val (key, recref, size, integerval);
<**> value key, size, integerval, recref; integer key, size, integerval, recref;
<**> if teston then
<**> begin
<**> integer bytes, i;
<**> integer array field ref;
<**> ref:= recref;
<**> test_header(key, size+2);
<**> for i:= 1 step 1 until size shift (-1) do tz.testdata(i):= d.ref(i);
<**> tz.testdata(i):= integerval;
<**> end;
<**>
<**>
<**> procedure test_val_val (key, integerval1, integerval2);
<**> value key, integerval1, integerval2; integer key, integerval1, integerval2;
<**> if teston then
<**> begin
<**> integer bytes;
<**> test_header(key, 4);
<**> tz.testdata(1):= integerval1;
<**> tz.testdata(2):= integerval2;
<**> end;
<**>
<*-1*>
\f
message coroutinemonitor - 30a ;
<*************** extention to coroutine monitor procedures **********>
<***** signalbin *****
this procedure simulates a binary semaphore on a simple semaphore
by testing the value of the semaphore before signaling the
semaphore. if the value of the semaphore is one (=open) nothing is
done, otherwise a normal signal is carried out. *>
procedure signalbin(semaphore);
value semaphore;
integer semaphore;
begin
integer array field sem;
integer val;
sem:= semaphore;
inspect(sem,val);
if val<1 then signal(sem);
end;
\f
message coroutinemonitor - 30b ;
<***** coruno *****
delivers the coroutinenumber for a give coroutine id.
if the coroutine does not exists the value 0 is delivered *>
integer procedure coru_no(coru_id);
value coru_id;
integer coru_id;
begin
integer array field cor;
coru_no:= 0;
for cor:= firstcoru step corusize until (coruref-1) do
if d.cor.coruident//1000 = coru_id then
coru_no:= d.cor.coruident mod 1000;
end;
\f
message coroutinemonitor - 30c ;
<***** coroutine *****
delivers the referencebyte for the coroutinedescriptor for
a coroutine identified by coroutinenumber *>
integer procedure coroutine(cor_no);
value cor_no;
integer cor_no;
coroutine:= if cor_no <= 0 or maxcoru < cor_no then -1 else
firstcoru + (cor_no-1)*corusize;
\f
message coroutinemonitor - 30d ;
<***** curr_coruno *****
delivers number of calling coroutine
curr_coruno:
< 0 = -current_coroutine_number in disabled mode
= 0 = procedure not called from coroutine
> 0 = current_coroutine_number in enabled mode *>
integer procedure curr_coruno;
begin
integer i;
integer array ia(1:12);
i:= system(12,0,ia);
if i > 0 then
begin
i:= system(12,1,ia);
curr_coruno:= ia(3);
end else curr_coruno:= 0;
end curr_coruno;
\f
message coroutinemonitor - 30e ;
<***** curr_coruid *****
delivers coruident of calling coroutine :
curr_coruid:
> 0 = coruident of calling coroutine
= 0 = procedure not called from coroutine *>
integer procedure curr_coruid;
begin
integer cor_no;
integer array field cor;
cor_no:= abs curr_coruno;
if cor_no <> 0 then
begin
cor:= coroutine(cor_no);
curr_coruid:= d.cor.coruident // 1000;
end
else curr_coruid:= 0;
end curr_coruid;
\f
message coroutinemonitor - 30f.1 ;
<**** getch *****
this procedure searches the queue of operations waiting at 'semaphore'
to find an operation that matches the operationstypeset and a set of
select-values. each select value is specified by type and fieldvalue
in integer array 'type' and by the value in integer array 'val'.
0: eq 0: not used
1: lt 1: boolean
2: le 2: integer
3: gt 3: long
4: ge 4: real
5: ne
*>
procedure getch(semaphore,operation,operationtypeset,type,val);
value semaphore,operationtypeset;
integer semaphore,operation;
boolean operationtypeset;
integer array type,val;
begin
integer array field firstop,currop;
integer ø,n,i,f,t,rel,i1,i2;
boolean field bf,bfval;
integer field intf;
long field lf,lfval; long l1,l2;
real field rf,rfval; real r1,r2;
boolean match;
operation:= 0;
n:= system(3,ø,type);
match:= false;
firstop:= semaphore + semop;
currop:= d.firstop.next;
while currop <> firstop and -,match do
begin
if (operationtypeset and d.currop.optype) extract 12 <> 0 then
begin
i:= n;
match:= true;
\f
message coroutinemonitor - 30f.2 ;
while match and (if i <= ø then type(i) >= 0 else false) do
begin
rel:= type(i) shift(-18);
t:= type(i) shift(-12) extract 6;
f:= type(i) extract 12;
if f > 2047 then f:= f -4096;
case t+1 of
begin
; <* not used *>
begin <*boolean or signed short integer*>
bf:= f;
bfval:= 2*i;
i1:= d.currop.bf extract 12;
if i1 > 2047 then i1:= i1-4096;
i2:= val.bfval extract 12;
if i2 > 2047 then i2:= i2-4096;
match:= case rel+1 of (i1=i2,i1<i2,i1<=i2,i1>i2,i1>=i2,i1<>i2);
end;
begin <*integer*>
intf:= f;
i1:= d.currop.intf;
i2:= val(i);
match:= case rel+1 of (i1=i2,i1<i2,i1<=i2,i1>i2,i1>=i2,i1<>i2);
end;
begin <*long*>
lf:= f;
lfval:= i*2;
l1:= d.currop.lf;
l2:= val.lfval;
match:= case rel+1 of (l1=l2,l1<l2,l1<=l2,l1>l2,l1>=l2,l1<>l2);
end;
begin <*real*>
rf:= f;
rfval:= i*2;
r1:= d.currop.rf;
r2:= val.rfval;
match:= case rel+1 of (r1=r2,r1<r2,r1<=r2,r1>r2,r1>=r2,r1<>r2);
end;
end;<*case t+1*>
i:= i+1;
end; <*while match and i<=ø and t>=0 *>
\f
message coroutinemonitor - 30f.3 ;
end; <* if operationtypeset and ---*>
if -,match then currop:= d.currop.next;
end; <*while currop <> firstop and -,match*>
if match then
begin
link(currop,0);
d.current.coruop:= currop;
operation:= currop;
end;
end getch;
\f
message coroutinemonitor - 31 ;
activity(maxcoru);
goto initialization;
<*************** event handling ***************>
takeexternal:
currevent:= baseevent;
eventqueueempty:= false;
repeat
current:= 0;
prevevent:= currevent;
mon(66) test event :(0, 0, currevent, 0);
currevent:= monw2;
if monw0 < 0 <* no event *> then goto takeinternal;
if monw0 = 1 and monw1 > 0 and monw1 <= maxcoru then
cmi:= monw1
else
cmi:= - monw0;
if cmi > 0 then
begin <* answer to activity zone *>
current:= firstcoru + (cmi - 1) * corusize;
linkprio(current, readyqueue);
baseevent:= 0;
end else
if cmi = 0 then
begin <* message arrived *>
\f
message coroutinemonitor - 32 ;
receiver:= core.currevent(3);
if receiver < 0 then receiver:= - receiver;
procref(maxprocext):= receiver;
procext:= 1;
while procref(procext) <> receiver do procext:= procext + 1;
if procext = maxprocext then
begin <* receiver unknown *>
<* leave the message unchanged *>
end else
if proccode(procext) shift (-12) = 0 then
begin <* the receiver is ready for accepting messages *>
mon(26) get event :(0, 0, currevent, 0);
case proccode(procext) of
begin
begin <* message received by semwaitmessage *>
op:= procop(procext);
sem:= d.op(1);
for cmj:=1 step 1 until 8 do d.op(cmj):= core.currevent(4+cmj);
d.op(9):= currevent;
signalch(sem, op, d.op.optype);
proccode(procext):= 1 shift 12;
end;
begin <* message received by cwaitmessage *>
current:= procop(procext);
procop(procext):= currevent;
linkprio(current, readyqueue);
link(current + corutimerchain, idlequeue);
<*+1*>
<**> if (d.current.corutestmask and ceventtest) extract 12 <> 0
<**> then test_arr(17, core.currevent, 24);
<*-1*>
end;
end; <* case *>
currevent:= baseevent;
proccode(procext):= 1 shift 12;
end;
end <* message *> else
if cmi = -1 then
begin <* answer arrived *>
\f
message coroutinemonitor - 33 ;
if currevent = timermessage then
begin
mon(26) get event :(0, 0, currevent, 0);
coru:= d.timerqueue.next;
while coru <> timerqueue do
begin
current:= coru - corutimerchain;
d.current.corutimer:= d.current.corutimer - clockmess(2);
coru:= d.coru.next;
if d.current.corutimer <= 0 then
begin <* timer perion expired *>
d.current.corutimer:= -1;
linkprio(current, readyqueue);
link(current + corutimerchain, idlequeue);
end;
end;
mon(16) send message :(0, clockmess, 0, clock);
timermessage:= monw2;
currevent:= baseevent;
end <* timer answer *> else
begin
messref(maxmessext):= currevent;
messext:= 1;
while messref(messext) <> currevent do messext:= messext + 1;
if messext = maxmessext then
begin <* the answer is unknown *>
<* leave the answer unchanged - it may belong to an activity *>
end else
if messcode(messext) shift (-12) = 0 then
begin
case messcode(messext) extract 12 of
begin
\f
message coroutinemonitor - 34 ;
begin <* answer arrived after semsendmessage *>
op:= messop(messext);
sem:= d.op(1);
mon(18) wait answer :(0, d.op, currevent, 0);
d.op(9):= monw0;
signalch(sem, op, d.op.optype);
messref(messext):= 0;
baseevent:= 0;
end;
begin <* answer arrived after csendmessage *>
current:= messop(messext);
linkprio(current, readyqueue);
link(current + corutimerchain, idlequeue);
<*+1*>
<**> if (d.current.corutestmask and ceventtest) extract 12 <> 0
<**> then test_arr(19, core.currevent, 24);
<*-1*>
end;
end;
end else baseevent:= currevent;
end;
end;
until eventqueueempty;
\f
message coroutinemonitor - 35 ;
<*************** coroutine activation ***************>
takeinternal:
current:= d.readyqueue.next;
if current = readyqueue then
begin
mon(24) wait event :(0, 0, prevevent, 0);
goto takeexternal;
end;
<*+1*>
<**> if (d.current.corutestmask and schedulingtest) extract 12 <> 0
<**> then test_rec(20, current+prev-2, corusize);
<*-1*>
<*+2*> if testbit30 and d.current.corutestmask shift(-11) then
<**> begin
<**> systime(5,0,r);
<**> write(out,"nl",1,<<zd dd dd>,r,<: coroutine: :>,<<dd>,
<**> d.current.coruident mod 1000,<: ident: :>,<<ddd>,
<**> d.current.coruident//1000,<: aktiveres:>);
<**> end;
<*-2*>
corustate:= activate(d.current.coruident mod 1000);
cmi:= corustate extract 24;
<*+2*> if testbit30 and d.current.corutestmask shift(-11) then
<**> begin
<**> systime(5,0,r);
<**> write(out,"nl",1,<<zd dd dd>,r,<: coroutine: :>,<<dd>,
<**> d.current.coruident mod 1000,<: ident: :>,<<ddd>,
<**> d.current.coruident//1000,<: afbrudt, årsag=:>,cmi);
<**> end;
<*-2*>
if cmi = 1 then
begin <* programmed passivate *>
goto takeexternal;
end;
if cmi = 2 then
begin <* implicit passivate in activity *>
<*+1*>
<**> if (d.current.corutestmask and schedulingtest) extract 12 <> 0
<**> then test_rec(21, current+prev-2, corusize);
<*-1*>
link(current, idlequeue);
goto takeexternal;
end;
\f
message coroutinemonitor - 36 ;
<* coroutine termination (normal or abnormal) *>
<*+1*>
<**> if (d.current.corutestmask and schedulingtest) extract 12 <> 0
<**> then test_rec_val(22, current+prev-2, corusize, cmi);
<*-1*>
<* aktioner ved normal og unormal coroutineterminering insættes her *>
coru_term:
begin
if false and alarmcause extract 24 = (-9) <* break *> and
alarmcause shift (-24) extract 24 = 0 then
begin
endaction:= 2;
goto program_slut;
end;
if alarmcause extract 24 = (-9) <* break *> and
alarmcause shift (-24) = 8 <* parent *>
then sæt_bit_i(trapmode,15<*killed activities*>,0<*normal output*>);
if alarmcause shift (-24) extract 24 <> -2 or
alarmcause extract 24 <> -13 then
begin
write(zbillede,"nl",1,<:alarmcause(param,cause)=:>,<<d>,
alarmcause shift (-24),<:,:>,
alarmcause extract 24);
for i:=1 step 1 until max_coru do
j:=activate(-i); <* kill *>
<* skriv billede *>
end
else
begin
errorbits:= 0; <* ok.yes warning.no *>
goto finale;
end;
end;
goto dump;
link(current, idlequeue);
goto takeexternal;
\f
message coroutinemonitor - 37 ;
initialization:
<*************** initialization ***************>
<* chain head *>
prev:= -2; <* -2 prev *>
next:= 0; <* +0 next *>
<* corutine descriptor *>
<* -2 prev *>
<* +0 next *>
<* +2 (link field) *>
corutimerchain:= next + 4; <* +4 corutimerchain *>
<* +6 (link field) *>
coruop:= corutimerchain + 4; <* +8 coruop *>
corutimer:= coruop + 2; <*+10 corutimer *>
coruident:= corutimer + 2; <*+12 coruident *>
corupriority:= coruident + 2; <*+14 corupriority *>
corutypeset:= corupriority + 1; <*+15 corutypeset *>
corutestmask:= corutypeset + 1; <*+16 corutestmask *>
<* simple semaphore *>
<* -2 (link field) *>
simcoru:= next; <* +0 simcoru *>
simvalue:= simcoru + 2; <* +2 simvalue *>
<* chained semaphore *>
<* -2 (link field) *>
semcoru:= next; <* +0 semcoru *>
<* +2 (link field) *>
semop:= semcoru + 4; <* +4 semop *>
\f
message coroutinemonitor - 38 ;
<* operation *>
opsize:= next - 6; <* -6 opsize *>
optype:= opsize + 1; <* -5 optype *>
<* -2 prev *>
<* +0 next *>
<* +2 operation(1) *>
<* +4 operation(2) *>
<* +6 - *>
<* . - *>
<* . - *>
<*+1*> <* test record *>
<**>
<**> testhead:= 2; <* +2 code, length *>
<**> testtime:= 4; <* +4 time (sec.*100) *>
<**> testcoru:= 6; <* +6 corutine ident *>
<**> testdata:= 6; <* +8 testdata(1) *>
<**> <*+10 testdata(2) *>
<**> <* . - *>
<**> <* . - *>
<**> testheadsize:= 6;
<**> open(tz, 4, <:cmontest:>, 1 shift 18);
<**> if monitor(42) lookup entry :(tz, cmi, zoneia)
<**> + monitor(52) create area process :(tz, cmi, zoneia)
<**> + monitor(8) reserve process :(tz, cmi, zoneia)
<**> = 0 then teston:= true else
<**> begin
<**> teston:= false;
<**> write(out, <:<10>testoutput inactive - <cmontest> missing<10>:>);
<**> setposition(out, 0, 0);
<**> end;
<**> setposition(tz, 0, 0);
<**>
<*-1*>
\f
message coroutinemonitor - 39 ;
trap(dump);
systime(1, 0, starttime);
for cmi:= 1 step 1 until maxmessext do messref(cmi):= 0;
clockmess(1):= 0;
clockmess(2):= timeinterval;
clock(1):= real <:clock:>;
clock(2):= real <::>;
mon(16) send message :(0, clockmess, 0, clock);
timermessage:= monw2;
readyqueue:= 4;
initchain(readyqueue);
idlequeue:= readyqueue + 4;
initchain(idlequeue);
timerqueue:= idlequeue + 4;
initchain(timerqueue);
current:= 0;
corucount:= 0;
proccount:= 0;
baseevent:= 0;
coruref:= timerqueue + 4;
firstcoru:= coruref;
simref:= coruref + maxcoru * corusize;
firstsim:= simref;
semref:= simref + maxsem * simsize;
firstsem:= semref;
opref:= semref + maxsemch * semsize + 4;
firstop:= opref;
optop:= opref + maxop * opheadsize + maxnettoop - 6;
for cmi:= coruref step 2 until optop - 2 do d(cmi/2):= 0;
reflectcore(core);
<*+1*>
<**> semtest:= false add 1; <* signal, wait, inspect *>
<**> semchtest:= false add 2; <* signalch, waitch, inspectch *>
<**> ceventtest:= false add 4; <* csendmessage, cwaitanswer, *>
<**> <* cwaitmessage, cregretmessage *>
<**> semeventtest:= false add 8; <* semsendmessage, semwaitmessage, *>
<**> <* semregretmessage *>
<**> schedulingtest:= false add 16; <* pass, delay, exit *>
<*-1*>
algol list.on;
<* :5: individual initialization .................................. *>
\f
algol list.off;
message coroutinemonitor - 40 ;
if simref <> firstsem then initerror(1, false);
if semref <> firstop - 4 then initerror(2, false);
if coruref <> firstsim then initerror(3, false);
if opref <> optop + 6 then initerror(4, false);
if proccount <> maxprocext -1 then initerror(5, false);
goto takeexternal;
dump:
op:= op;
<* :6: trap-aktioner 1 *>
<*+1*>
<**> begin
<**> integer i, j;
<**> integer array field ref;
<**> for i:=1 step 1 until maxcoru do
<**> test_rec(24, firstcoru+prev-2+(i-1)*corusize, corusize);
<**> for i:=1 step 1 until maxsem do
<**> test_rec(25, firstsim+prev-2+(i-1)*simsize, simsize);
<**> for i:=1 step 1 until maxsemch do
<**> test_rec(26, firstsem+prev-2+(i-1)*semsize, semsize);
<**> ref:= firstop+opsize-2;
<**> for i:=1 step 1 until maxop do
<**> begin
<**> j:= d.ref(1)+opheadsize;
<**> test_rec(23, ref, if j < 60 then j else 60);
<**> ref:= ref+j;
<**> end;
<**> end;
<**>
<**> if teston then
<**> begin
<**> outrec6(tz, 2);
<**> tz.testhead:= -2;
<**> close(tz, true);
<**> end;
<**>
<*-1*>
<* :7: trap-aktioner 2 *>
end;
algol list.on;
message programslut;
program_slut:
end
▶EOF◀