|
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: 39936 (0x9c00)
Types: TextFile
Names: »tcmon«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦a2674cfeb⟧ »calgmon«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦a2674cfeb⟧ »calgmon«
└─⟦this⟧
algol8 coroutine monitor. lkn 79.06.14 version 1.0
begin
<* 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;
<* :1: declaration of trimming variables .......................... *>
maxsem:= maxsemch:= maxop:= maxcoru:= maxnettoop:= 0;
maxmessext:= maxprocext:= 1;
corusize:= 20;
simsize:= 6;
semsize:= 8;
opheadsize:= 8;
testbuffering:= 1;
timeinterval:= 5;
<* :2: initialization of trimming variables ....................... *>
<* :3: claiming of basic elements (semaphores, corutines etc.) .... *>
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*>
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);
<*************** 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;
<***** 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;
<***** 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;
<***** 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;
<***** 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;
<***** 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;
<* :4: procedures and common variables ........................... *>
<*************** 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;
<***** 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;
<***** 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;
<***** 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;
<***** 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.
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;
op:= 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;
link(op, semaphore + semop);
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;
<***** 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;
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;
<***** inspectch *****
this procedure inspects the queue of operations waiting at 'semaphore'.
the number of matching operations are counted and delivered 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;
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;
elements:= counter;
<*+1*>
<**> if (d.current.corutestmask and semchtest) extract 12 <> 0
<**> then test_rec_val(6, semaphore+prev-2, semsize, counter);
<*-1*>
end;
<***** 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, 8, messext);
<*-1*>
end;
<***** 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;
<***** 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;
<***** 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;
<***** 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;
<***** 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;
<***** 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;
<***** 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;
<***** 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;
<*+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;
<**>
<**>
<**> 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;
<**>
<**>
<**> 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*>
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 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 *>
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 *>
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
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;
<*************** coroutine activation ***************>
takeinternal:
current:= d.readyqueue.next;
if current = readyqueue then
begin
mon(24) wait event :(0, 0, baseevent, 0);
goto takeexternal;
end;
<*+1*>
<**> if (d.current.corutestmask and schedulingtest) extract 12 <> 0
<**> then test_rec(20, current+prev-2, corusize);
<*-1*>
corustate:= activate(d.current.coruident mod 1000);
cmi:= corustate extract 24;
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;
<* 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*>
link(current, idlequeue);
goto takeexternal;
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 *>
<* 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*>
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*>
<* :5: individual initialization .................................. *>
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:
<*+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*>
end;
end
▶EOF◀