|
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: 95232 (0x17400)
Types: TextFile
Names: »cltxt «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦39138f30b⟧
└─⟦this⟧ »cltxt «
\f
; tas 1.0 14.05.87 cltxt ...1...
;********************************************************************
;*********************** Exception rutine ***************************
;*********************** Testoutput rutiner *************************
;*********************** Central logic ******************************
;********************************************************************
;
; Terminal access system for rc8000 - A/S Regnecentralen
; Erik Poulsen
; Revisions historie
;
; 87.01.15 release til betatest
;
; 87.05.14 release 1.0
;
; 88.01.08 side 5/6 w1=0 ved kald af e0. i d42, d44, d48, d75
;
; 88.02.25 side 11 nyt format af f21, p39 i stedet for 15
;
; 88.03.17 release 1.2
;
; 88.25.10 side 3: sæt pausebit i break message til s
;
; 89.08.21 side 18: c76 defineret, max create link messages
;;
\f
; tas 1.0 14.05.87 exception routine cltxt ...2...
c.a89<0 ; if fp version
k=h55
z.
l0: 0 ; abs code start addr.
s3,s4 ; version
am. (l1.) ; +6: entry:
jl. l1. ; goto initialize;
l1: l2. ;
0,r.5
b. i8, j6 w. ; begin break;
u0 = k - 16 ; internal interrupt addr.
; u0+0 saved w0
; u0+2 saved w1
; u0+4 saved w2
; u0+6 saved w3
; u0+8 saved ex
; u0+10 saved ic
; u0+12 cause
; u0+14 saved sb
; interrupt entry:
rl. w3 u0.+12 ; w2:=ic; w3:=cause;
rs. w3 i2. ; set cause in break message
al w0 0 ;
al. w3 j4. ; set interrupt; use another interrupt
jd 1<11+0 ; address in this routine
dl. w3 u0.+12 ;
bl w0 x2-2 ;
c.-a88-2
sn w3 0 ; if couse=0 and
h. se w0 , ks w. ; instruction= ks <no> then
jl. j0. ; begin
bl w0 x2-1 ;
ac w0 (0) ; <no> := - <no>
rs. w0 u0.+13 ; cause:=no;
wa. w0 i4. ; length:=8,type:=<no>;
al. w1 u0. ; tail:=registers;
; am. (c0.) ;
; rl w3 f13 ; if curco.test=1 then
\f
;. tas 1.0 14.05.87 exception routine cltxt ...3...
; sz w3 1 ;
jl. w3 e0. ; curco testoutput;
al w0 0 ;
al. w3 u0. ; set interrupt;
jd 1<11+0 ;
dl. w1 u0.+2 ; reestablish all registers
dl. w3 u0.+6 ;
xl. u0.+9 ;
jl. (u0.+10) ; return;
z. ;
j0: bl w1 x2-1 ; <no> := - <no>
ac w1 x1 ; if instruction=je <no> then
h. sn w0 , je w. ; cause:=no;
rs. w1 i2. ; if instruction=je <no> then
h. sn w0 , je w. ; cause:=no;
rs. w1 u0.+12 ;
j1: ; send:
c.-a88-2
al w2 0 ;
am. (c15.) ;
bz w0 26 ;
sh w0 0 ; if buffer claim < 1 then
jl. j2. ; goto no buffers;
rl. w0 i6. ; length:=14, type:=1023;
al. w1 u0. ; tail:=registers.ex,ic,cause;
jl. w3 e0. ; testout;
jl. w3 e2. ; outblock;
al. w1 i5. ;
se w2 0 ; if buf > 0 then
jd 1<11+18 ; wait answer(buf,answer,result);
z.
; send_break:
j5: rl. w2 i2. ;
sh w2 99 ; if cause>99 then
jl. j6. ; message:=finis;
al. w1 i7. ;
jl. 4 ;
j6: al. w1 i1. ; send message(parent,mess,buf);
al. w3 c16. ;
jd 1<11+16 ; if buffer claim exceeded then
se w2 0 ; begin
jl. j3. ;
j2: jd 1<11+26 ; no buffers: wait envent;
se w0 1 ; if not answer then
\f
;. tas 1.0 14.05.87 exception routine cltxt ...4...
jl. j2. ; goto no buffers;
jd 1<11+26 ; get event; goto send;
jl. j1. ; end;
j3: jd 1<11+18 ; wait answer(result,mes,buf);
jl. 0 ; wait for ever;
j4: 0,r.8 ; interrupt addr for interrupt in
; interrupt routinen;
jl. j5. ; goto send_break;
i1: 4<12 + 1<8 + 1 ; break message to parent;
<:break :>,0
i2: 0
i3: 0,0,0
i4: 8<12
i6: 14<12+1023
i5: 0,r.8 ; answer
i7: 2<12 ; finis message to parent
<:finis :>,0
i8: 0,r.4
e. ; end break;
b. d90 ; begin central logic;
w.
d. c.a90<2 l. z. ; if list testoutput routines then list on
\f
; tas 1.0 14.05.87 testoutput routines cltxt ...5...
c.-a88-2
b. i20, j10, n20 w. ; begin testoutput;
n0: 4<12 + 2
d40: rs. w1 i1. ; test start_coroutine: save w1;
rs. w3 i3. ; save return;
rl. w0 n0. ; lenght:=4, type:=2;
al w1 x2 ; tail:=ic,prio;
jl. w3 e0. ; testout;
rl. w1 i1. ; restore w1;
jl. (i3.) ; return;
n1: 4<12+3
d41: rs. w3 i3. ; test start: save return;
ds. w1 i1. ; save w0,w1;
rl. w0 n1. ; length:=4, type:=3;
al. w1 i0. ; tail:=prio,result;
jl. w3 e0. ; testout;
dl. w1 i1. ; restore w0,w1;
jl. (i3.) ; return
d42: am. (c0.) ; test wait: fourth:=timer;
rl w2 f8 ;
al w1 0 ;
al w0 4 ; length:=0, type:=4;
jl. e0. ; testout and return;
d43: am 1 ; test inspect: type:=6;
d44: al w2 5 ; test pass: type:=5;
rx w2 0 ; length:=0;
rs. w3 i3. ; save return;
al w1 0 ;
jl. w3 e0. ; testout;
al w0 x2 ;
jl. (i3.) ; return;
n2: 10<12+7
d45: rl. w0 n2. ; test csensmessage: length:=10, type:=7;
jl. e0. ; testout and return;
n3: 2<12+8
d46: rs. w0 i0. ; test cwaitanswer:
rl. w0 n3. ; length:=2, type:=8;
al. w1 i0. ; tail:=timer;
jl. e0. ; testout and return;
\f
;. tas 1.0 14.05.87 testoutput routines cltxt ...6...
n4: 8<12
d47: ds. w0 i3. ; test cwaitanswer exit:
sn w0 1 ; if result <> 1 then length:=0;
am. (n4.) ; else length:=8;
al w0 9 ; type:=9; tail:=answer;
jl. w3 e0. ; testout;
rl. w0 i3. ;
jl. (i2.) ; return;
d48: al w0 10 ; test cregretmassage: length:=0, type:=10;
al w1 0 ;
jl. e0. ; testout and return;
n5: 6<12
d74: am 1 ; test g_lock: length:=6, type:=34:
d73: am 21 ; test g_open: length:=6, type:=33;
d50: am 1 ; test wait_sem: length:=6, type:=12;
d49: al w0 11 ; test signal: length:=6, type:=11;
wa. w0 n5. ;
al w1 x2 ; tail=semaphore;
jl. e0. ; testout and return;
d51: am -22 ; test wait_semafor_exit; length:=0, type:=13;
d75: al w0 35 ; test g_lock exit: length:=0, type:=35:
am. (c0.) ; fourth:=exit addr;
rl w2 f15 ;
al w1 0 ;
jl. e0. ; testout and return;
n6: 10<12+14
d52: rl. w0 n6. ; test send_letter: length:=10, type:=14;
jl. e0. ; testout and return;
n7: 2<12+15
d53: rs. w1 i1. ; test inspect mailbox:
rs. w3 i3. ; save mask,return;
rl. w0 n7. ; length:=2, type:=15;
al. w1 i1. ; tail:=mask;
jl. w3 e0. ; testout;
rl. w1 i1. ;
jl. (i3.) ; return;
n8: 2<12+16
d54: rs. w3 i3. ; test wait_letter:
ds. w1 i1. ; tail:=mask;
rl. w0 n8. ; length:=2, type:=16;
\f
;. tas 1.0 14.05.87 testoutput routines cltxt ...7...
al. w1 i1. ;
jl. w3 e0. ; testout;
rl. w0 i3. ;
dl. w1 i1. ;
jl. (i3.) ; return;
n9: 12<12
d55: rl w2 0 ; test exit_wait_letter:
rs. w3 i3. ; save return;
se w2 0 ; if result=0 then length:=0
am. (n9.) ; else length:=12;
al w0 17 ; type:=17; tail:=letter;
jl. w3 e0. ; testout;
al w0 x2 ;
jl. (i3.) ; return;
d56: ds. w3 i3. ; test send message: save w2,return;
rl w2 0 ; fourth:=mailbox;
rl. w0 i15. ; length:=18, type:=18;
jl. w3 e0. ; testout;
rl. w2 i2. ; restore w2;
jl. (i3.) ; return;
n10: 8<12+19
d57: rl. w0 n10. ; test wait_buffer: length:=8, type=19;
jl. e0. ; testout and return;
d58: rs. w3 i3. ; test exit wait_buffer: save return;
ds. w2 i2. ; save w1,w2;
al w0 20 ; length:=0, type:=20;
am. (c0.) ;
rl w2 f18 ; fourth:=ic;
jl. w3 e0. ; testout;
rl. w3 c0. ; w3:=current coroutine;
dl. w2 i2. ; restore w1,w2;
jl. (i3.) ; return;
n11: 2<12+21
d59: rs. w1 i1. ; test release buffer: save buffer addr;
al. w1 i1. ; tail:=buffer addr.;
rl. w0 n11. ; length:=2, type:=21;
jl. e0. ; testout and return;
n12: 6<12+22
\f
;. tas 1.0 14.05.87 testoutput routines cltxt ...8...
d60: rs. w1 i1. ; test exit: save return;
rl. w0 n12. ; length:=6, type:=22;
al w1 x3+f10 ; tail:=w0 w1 w2;
rl w2 x3 ; fourth:=ic;
jl. w3 e0. ; testout;
rl. w3 c0. ; w3:=current coroutine;
jl. (i1.) ; return;
n13: 10<12
d68: am 1 ; test rem_answer: type:=30;
d67: am 1 ; test tem_message: type:=29;
d66: am 1 ; test att_answer: type:=28;
d65: am 1 ; test message arrived: type:=27;
d64: am 1 ; test timerscan: type:=26;
d63: am 1 ; test message arrived: type:=25;
d62: am 1 ; test answer arrived: type:=24;
d61: al w0 23 ; test answer: type:=23, length:=8;
wa. w0 n13. ;
rs. w1 i1. ; save w1,w3;
rs. w3 i3. ;
al w1 x2+4 ; tail=buffer(0:4);
jl. w3 e0. ; testout;
rl. w1 i1. ; restore w1;
jl. (i3.) ; return;
d71: al w0 31 ; test create_coroutine: length:=0, type:=31;
al w2 x1 ; fourth:=cda;
jl. e0. ; testout and return;
d72: al w0 32 ; test remove_coroutine: length:=0, type:=32;
jl. e0. ; testout and return;
n14: 4<12+36
d76: rs. w3 i3. ; test wait_sem_letter:
ds. w1 i1. ; tail:=mask,sem addr;
rl. w0 n14. ; length:=4, type:=36;
al. w1 i0. ;
jl. w3 e0. ; testout;
rl. w0 i3. ;
rl. w1 i1. ;
jl. (i3.) ; return;
n15: 12<12
d77: rl w2 0 ; test exit_wait_letter:
\f
;. tas 1.0 14.05.87 testoutput routines cltxt ...9...
rs. w3 i3. ; save return;
se w2 1 ; if result=1 then length:=0
am. (n15.) ; else length:=12;
al w0 37 ; type:=37; tail:=letter;
jl. w3 e0. ; testout;
al w0 x2 ;
jl. (i3.) ; return;
n16: 2<12+38
d78: rs. w3 i3. ; test get_buffer:
rl. w0 n16. ; length:=2, type:=38;
rs. w1 i1. ; fourth:=pool;
al. w1 i1. ; tail:=buf addr;
jl. w3 e0. ; testout;
rl. w1 i1. ;
jl. (i3.) ; return;
i0: 0 ; saved w0
i1: 0 ; saved w1
i2: 0 ; saved w2
i3: 0 ; saved w3
; procedure register_testout
; at call: w0,w1,w2 registers der skal skrives i testoutput
; w3 return addt
;
; at call skal w3 peger på ord med testno<12 + testmask
; og w3+2 på ord med gemt værdi af w3
; at return: w0,w2,w2 unchanged, w3 indeholder gemt værdi af w3
; fra return addr+2
; proceduren returnere til return addr + 4
z.
e1:
c.-a88-2
b. i10,j10 w. ;
ds. w1 j1. ;
rs. w2 j2. ; save w0,w1,w2 i testrecord;
rs. w3 j4. ; save return addr
al w1 x3 ;
rl w3 x1+2 ; hent w3 fra return addr + 2
rs. w3 j3. ; save w3 i testrecord
rl. w2 c0. ; w2 := curco;
\f
;. tas 1.0 14.05.87 testoutput routines cltxt ...10...
rl w3 x1 ;
zl w0 6 ; sæt testrecord type
la w3 x2+f13 ; if curco.testmask and mask <> 0 then
sn w3 0 ; begin
jl. i1. ; length:=2, type:=fra kaldstedet
wa. w0 j5. ; tail:= w0,w1,w2,w3
al. w1 j0. ; testout
jl. w3 e0. ; end;
i1: dl. w1 j1. ; restore w0,w1,w2,w3;
dl. w3 j3. ;
am. (j4.) ; return;
jl 4 ;
j0: 0 ; w0 : testrecord
j1: 0 ; w1
j2: 0 ; w2
j3: 0 ; w3
j4: 0 ; saved return;
j5: 8<12 + 0 ; testrecord længde
e.
; procedure testout;
; at call: w0 tail length in bytes < 12 + type
; w1 first addr of words to output
; w2 first word to output
; w3 return
; at return: w0 undefined, w1 w2 w3 unchanged
z.
e0:
c.-a88-2
ds. w3 i8. ; save registers
ds. w1 i6. ;
ls w0 -12 ;
wa. w0 c17. ; w0:=length+word addr.;
am. (c20.) ;
rl w3 8 ;
sl w0 x3-8 ; if w0+8 >= last addr then
jl. w3 j3. ; outblock;
rl. w0 i5. ;
\f
;. tas 1.0 14.05.87 testoutput routines cltxt ...11...
jl. w3 j2. ; outword(length<12+type);
dl w0 110 ; w3,w0 := time;
ss. w0 c8. ; w0,w3:=(time-start time)mod 2**29;
la. w3 i12. ;
wd. w0 i9. ; w0:=time:=w0,w3//100;
jl. w3 j2. ; outword(time);
rl. w1 c0. ;
al w0 p39 ;
la w0 x1+f21 ;
ls w0 12 ; outword(curco.state extract 12 shift 12
wa w0 x1+f14 ; + curco.ident);
jl. w3 j2. ;
rl. w0 i7. ;
jl. w3 j2. ; outword(first);
rl. w1 i6. ;
j1: rl. w2 i5. ; rep:
ws. w2 i16. ; length:=length-2;
rs. w2 i5. ;
rl w0 x1 ; w0:=word to output;
al w1 x1+2 ; w1:=next;
al. w3 j1. ; prepare return to rep;
sl w2 0 ; if length>=0 then
jl. j2. ; outword and return to rep;
dl. w1 i6. ;
dl. w3 i8. ; reestablish w0,w1,w2,w3;
jl x3 ; return;
; procedure outword;
; at call: w0 word, w3 return
; at return: all registers unchanged
j2: rx. w1 c17. ; save w1, w1:=word addr.
rs w0 x1 ; buffer(word addr):=word to output;
al w1 x1+2 ; word addr.:=word addr. + 2;
rx. w1 c17. ; restore w1;
jl x3 ; return;
; procedure outblock;
; at call: w3 return;
; at return: all registers undefined
e2:
j3: rs. w3 i10. ; save return;
\f
;. tas 1.0 14.05.87 testoutput routines cltxt ...12...
al w0 0 ;
rs. w0 (c17.) ; word(word addr.):=0;
; PS: may write outside buffer;
rl. w0 c23. ;
se w0 0 ; if testoutput inactive then
jl x3 ; return;
j4: rl. w2 c20. ; cur:=current testoutput buffer;
al w0 1 ;
hs w0 x2 ; cur.open:=true;
al w1 x2+4 ;
al. w3 c18. ; send message(testarea,
jd 1<11+16 ; cur.message, buf);
am. (c20.) ;
rs w2 2 ; cur.buf:=buf;
rs. w2 i14. ;
c.a89<1 ;
m.single testoutput buffer
rl. w2 c20. ; if single buffer testoutput
jl. j5. ; goto wait_ans;
z. ;
al. w2 c21. ; testbuf:=test buffer 1;
sn. w2 (c20.) ; if cur = testbuf then
al. w2 c22. ; testbuf:=testbuffer 2;
rs. w2 c20. ; cur:=testbuf;
zl w3 x2 ;
sn w3 0 ; if cur.open then
jl. j6. ; begin
j5: al w0 0 ; wait_ans:
hs w0 x2 ; cur.open:=false;
rs. w0 i14. ; saved buf := 0;
rl w2 x2+2 ; buf:=cur.buf;
al. w1 i11. ; wait_answer(buf,
jd 1<11+18 ; answer,result);
se w0 1 ; if result <> ok then
jl. w3 j7. ; goto set inactive;
rl. w0 i11. ; if status = hard then
sz. w0 (i13.) ; goto set inactive;
jl. w3 j7. ;
rl. w2 c20. ; end;
j6: rl. w1 c24. ; s:= segment no;
al w1 x1+1 ; s:=s+1;
sn. w1 (c19.) ; if s = number of test segments then
al w1 1 ; s:=1;
rs w1 x2+10 ; cur.mes.segment:=s;
\f
;. tas 1.0 14.05.87 testoutput routines cltxt ...13...
rs. w1 c24. ; segment no:=s;
rl w1 x2+6 ; word addr := cur.mes.first;
dl w3 110 ;
ds w3 x1+2 ; word(0,1):=time;
al w1 x1+4 ; word addr:=word addr + 4;
rs. w1 c17. ;
rl. w2 i14. ; w2:=buf;
jl. (i10.) ; return;
j7: rs. w3 c23. ; set inactive: call with link to make w3<>0;
jl. (i10.) ; return;
i5: 0 ; saved w0
i6: 0 ; saved w1
i7: 0 ; saved w2
i8: 0 ; saved w3
i9: 100 ;
i10: 0 ; saved return (outblock)
i11: 0,r.8 ; answer area
i12: 31 ; mask
i13: -1-1<18 ; hard status bit
i14: 0 ; saved buf
i15: 18<12 + 18 ;
i16: 2<12 ;
\f
; tas 1.0 14.05.87 testoutput routines cltxt ...14...
e. ; end testoutput;
z.
d. c.a90<3 l. z. ; if list central logic then list on
\f
; tas 1.0 14.05.87 utility routines cltxt ...15...
; procedure remove(elem);
;
; removes a given element from its queue and leaves the element
; linked to itself.
;
; call return
; w0: - unchanged
; w1: - next(elem)
; w2: elem elem
; w3: return unchanged
e3:
d0: rl w1 x2 ; begin
rx w2 x2+2 ; prev(elem):= elem;
rs w1 x2 ; next(prev(elem)):= next(elem);
rx w2 x1+2 ; prev(next(elem)):= old prev(elem);
rs w2 x2 ; next(elem):= elem;
jl x3 ; end;
; procedure link(head,elem);
;
; links the element to the end of the queue;
;
; call return
; w0 - destroyed
; w1 head head
; w2 elem elem
; w3 return unchanged
e4:
d1: al w0 x3 ; begin
rl w3 x1+2 ; old prev:= last(head);
rs w2 x1+2 ; prev(head):= elem;
rs w2 x3+0 ; next(old prev):= elem;
rs w1 x2+0 ; next(elem):= head;
rs w3 x2+2 ; prev(elem):= old prev;
rl w3 0 ;
jl x3 ; end;
\f
;. tas 1.0 14.05.87 utility routines cltxt ...16...
; procedure get_mess_ext(ref);
;
; returns a reference to the first free message buffer extension or 0
; if no extensions are available. the extension is removed from the chain.
;
; call return
; w0: - destroyed
; w1: - unchanged
; w2: - ref or 0
; w3: return unchanged
b.j5 w.
e5:
d7: rl. w2 c4. ; begin ref := buffer_extension_head;
sn w2 0 ; if ref <> 0 then
jl. j0. ; begin
rl w0 x2 ; buffer_extension_head:= next(ref);
rs. w0 c4. ; ref := ref + 2;
al w2 x2+2 ; end;
j0: jl x3 ; end;
e.
\f
; tas 1.0 14.05.87 CL variables cltxt ...17...
m.cl variables
; variable in central logic
c0: 0 ; current coroutine descriptor addr.
c1: 0,0 ; head active queue
c2: 0,0 ; head timer queue
c4: 0 ; head message extention list
c5: 0 ; cdescr pool addr
c7: 0 ; addr på event descr for messages til tas
0
c8: 0 ; own start time
c10: 0 ; first free core
c11: 0 ; top used core
c12: 1 ; coroutine ident
c13: 0,r.5 ; navn på ps processen tem
c15: 0 ; own process descriptor addr.
c16: 0,r.5 ; parent name
c17: 0 ; word addr. (testoutput buffer)
c18: <:rcmtest:>,0,0; testoutput doc name
c19: 0 ; number of segment in testoutput area
c20: 0 ; current testoutput descriptor
; testbuffer descriptor 1
c21: 0<12+9 ; open, proc ( ignore answer )
0 ; buf
5<12 ; output message
0, ; first
0, ; last
0, ; segment no
c22: 0<12+9 ; testbuffer descriptor 2
0
5<12
0,0,0
c23: 0 ; testoutput active
c24: 0 ; segment count
c25: 0,r.8 ; common answer area
c26: <:tas:>,0,0,0,0;<:tascat:>
c27: 0,r.5 ; <:tasspool:>
c28: 0,r.3 ; coretable_lock semaphor
c30: 0 ; free_att pool addr
\f
;. tas 1.0 14.05.87 CL variables cltxt ...18...
c31: 0,0 ; used_att, head of chain
c32: 0 ; coretabel_base
c33: 0 ; coretable_top
c34: 0 ; coretable_size
c35: 0 ; c_entry
c36: 0 ; curretn_prio
c37: 0 ; free_head
c38: 0 ; corebuffer_base
c39: 0 ; segment_table_base
c40: 0 ; areatable_base
c41: 0 ; top_areatabel
c42: 0 ; ss
c44: 0 ; mcltable_base
c45: 0 ; top_mcltable
c46: 0 ; first_ttda
c47: 0 ; top_ttda
c48: 0 ; free_term
c49: 0 ; first_ph
c50: 0 ; tdescr_pool
c51: 0 ; used_tdescr
c52: 0,r.3 ; lock_sem
c53: 0 ; max_tbuf_size
c54: 0 ; std seg i link spool area
c55: 0 ; addr signon text buffer
0 ; lower
c56: 0 ; upper name base for terminal ps processer
0 ; lower
c57: 0 ; upper std name base for mcl programmer
0 ; lower
c58: 0 ; upper name base for spool/test area
c59: 0 ; pda for tascat processen
c60: 0 ; (antal timeout på term i mcl) shift 12
c61: 0 ; systxt pool adresse
c62: 0 ; antal hw i tekst delen af systext buffer
;c63: se neden for
c64: 0 ; pda for ps processen tem
c75: 0 ; send message til remoter
c76: 0 ; max create link messages
; de næste 8 ord bruges som svar på get stat message fra tascat
c65: 0 ; max pools efter create pool message
c66: 0 ; th efter create link
c67: 0 ; sm coroutiner aktive
c68: 0 ; frie corebuffere
\f
;. tas 1.0 14.05.87 CL variables cltxt ...19...
c69: 0 ; frie mcltable indgange
c70: 0 ; frie terminal type beskrivelser
c71: 0 ; antal segmenter i spool området
c43: 0 ; free ( frie segmenter i spool området )
; cdescr for cl
c72: 0 ; saved ic
0 ; prio
c63: 0 ; test maske
0 ; state
0 ; ident
m.end cl variable
; procedure table for procedure called from check_event_queue
; nr
c98: d10. ; 0 answer
d11. ; 1 answer arrived
d12. ; 2 message
d13. ; 3 message arrived
d14. ; 4 tem message
d15. ; 5 timerscan
d16. ; 6 att answer
d17. ; 7 rem answer
d18. ; 8 answer tas
d19. ; 9 ignore answer
c99=k
\f
; tas 1.0 14.05.87 central wait cltxt ...20...
; procedure central wait;
;
; central waiting point in coroutine system. checks the eventqueue
; and schedules pending events. if the active queue is empty the
; monitor procedure wait event is called otherwise the first co-
; routine is started.
;
; call return
; w0: - saved w0 from coru. descr
; w1: - saved w1 from coru. descr
; w2: - saved w2 from coru. descr
; w3: - current coroutine descriptor addr.
b.j5 w.
e70: ; entry after init:
d2: ; begin
al. w3 c72. ; curco:=cl cdescr;
rs. w3 c0. ;
; repeat
j0: jl. w3 d6. ; check event queue;
rl. w3 c1. ; if active queue empty then
se. w3 c1. ; begin
jl. j1. ; buf := last buf;
jd 1<11+24 ; wait event(buf,result);
jl. j0. ; end;
j1: al w3 x3-f2 ; until active queue not empty;
rs. w3 c0. ; corout:= first in active queue;
c.a88<1 ; if testoutput
rl w0 x3+f13 ;
sz w0 1<1 ; if CL testout then
jl. w1 d60. ; test exit; ( type 22 )
z. ;
dl w1 x3+f11 ; restore w0, w1, w2 from corout;
rl w2 x3+f12 ; restart corout;;
jl (x3) ; end;
e.
\f
; tas 1.0 14.05.87 check eventqueue cltxt ...21...
; procedure check eventqueue;
;
; inspects the eventqueue starting from the start.
; the scheduling is performed by calling a procedure.
;
; a procedure which is used for scheduling answers or messages
; must return with w2=0 if the answer/message is removed from
; the event queue
; - otherwise with w2='buf' ; i. e. the event queue must be
; inspected from the start when an event is removed by a
; scheduling procedure.
; exit to scheduling procedure with:
; w0: -
; w1: ref(event descriptor)
; w2: buf
; w3: return
; and return with
; w0
; w1
; w2 buf
; w3
;
; check must be called with
;
; call return
; w0: - destroyed
; w1: - destroyed
; w2: - last event
; w3: return destroyed
b. j10, i5 w.
d6: rs. w3 i0. ; begin save return;
al w2 0 ; last_buf := 0;
j0: jd 1<11+66 ; repeat
sh w0 -1 ; test_event(last_buf,buf,result);
jl. j5. ; if result <> empty then
se w0 0 ; begin
jl. j2. ; if result = message then
rl w1 x2+4 ;
ac w1 x1 ; ref :=
se. w1 (c15.) ; if buf.receiver = cur then
jl. j1. ; messdescr
rl. w1 c7. ; else buf.receiver.pseudoprocess.messdescr
\f
;. tas 1.0 14.05.87 check eventqueue cltxt ...22...
jl. j2. ;
j1: rl w1 x1+16 ; else <* answer *> ref:= buf.ref;
j2: hl w0 x1 ;
sn w0 0 ;
jl. j0. ; if ref.open then
hl w0 x1+1 ; begin
ls w0 1 ; call cmonproc(buf,ref);
am (0) ; end;
jl. w3 (c98.) ; end;
jl. j0. ; last_buf := buf;
; until result = empty;
j5: jl. (i0.) ; end;
i0: 0 ; saved return;
e.
; procedure answer(ref,buf);
;
; this procedure is called from procedure 'check_event_queue' when an
; answer to a message, sent by 'sendmessage, has arrived. (proc=0)
; 'ref' contains the address of the answer_descriptor and 'buf' contains the
; message buffer address. the answer is signalled to the mailbox
; given in answer_descriptor.
;
; call return
; w0: - destr.
; w1: ref destr.
; w2: buf buf
; w3: return unchanged
b.j5, i5 w.
d10: ds. w3 i0. ; begin
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<1 ; if CL testout then
jl. w3 d61. ; test answer; ( type 23 )
z. ;
al w0 0 ; with ref do
hs w0 x1 ; begin
al w0 1<1 ; open:= false;
rs w0 x1+8 ; type:= answer;
\f
;. tas 1.0 14.05.87 check eventqueue cltxt ...23...
rs w2 x1+10 ;
rl w2 x1+2 ; mailbox := answer_mailbox;
al w1 x1+4 ; letter := message extention + 4;
jl. w3 e30. ; send_letter(mailbox,letter);
dl. w3 i0. ; end;
jl x3 ; end;
0 ; saved buf
i0: 0 ; saved return
e.
; procedure answer arrived(ref,buf);
;
; is called from procedure 'check_event_queue' when an answer appears in
; the event queue and 'ref.open' is true, i. e. when a coroutine has
; called 'cwaitanswer(buf)' (proc=1). The coroutine is activated and
; the answer descriptor is closed.
;
; call return
; w0: - destroyed
; w1: ref destroyed
; w2: buf buf
; w3: return unchanged
b.j5, i5 w.
d11: ds. w3 i0. ; begin save buf, return;
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<1 ; if CL testout then
jl. w3 d62. ; test answer arrived; ( type 24 )
z. ;
al w0 0 ;
hs w0 x1 ; ref.open:= false;
rl w2 x1+2 ; corout:= ref.param1;
al w1 1 ; result:= ok;
rl w0 x2+f1 ; priority:= corout.priority;
jl. w3 e10. ; start(corout,priority,ok);
dl. w3 i0. ; restore buf, return;
jl x3 ; end;
0 ; saved buf
i0: 0 ; saved return
\f
;. tas 1.0 14.05.87 check eventqueue cltxt ...24...
e.
; procedure message(buf,ref);
;
; this procedure is called from 'check_event_queue' when a message is
; received and mess_descr.proc = 'message' (proc=2). the message
; descriptor must contain an letter and the address of a mailbox.
;
; eda +0: 1<12 + 2
; +2: open
; +4: mailbox addr
; letter -> +6:
; +8:
; +10: 1<2
; +12: buffer addr
;
;
; call return
; w0: - destr.
; w1: eda destr.
; w2: buf 0 (the message buffer is removed)
; w3: return destr.
b. j5, i5 w.
d12: rs. w3 i0. ; begin
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<1 ; if CL testout then
jl. w3 d63. ; test message; ( type 25 )
z. ;
rl w0 x1+2 ; if eda.open=0 then
sn w0 0 ; return
jl. (i0.) ;
jd 1<11+26 ; getevent(buf);
al w0 0 ; with ref do
rs w0 x1+2 ; begin
al w0 1<2 ; open:= false; <* the message class must be
; explicitly opened by a
; receiving coroutine *>
rs w0 x1+10 ; letter.type:= message;
\f
;. tas 1.0 14.05.87 check eventqueue cltxt ...25...
rs w2 x1+12 ;
rl w2 x1+4 ; letter.buffer:= buf;
al w1 x1+6 ; sem:= message_sem;
jl. w3 e30. ; send_letter(mailbox,letter);
rl. w3 i0. ; end;
al w2 0 ; buf:= 0; <* has been removed *>
jl x3 ; end;
i0: 0 ; saved return;
e.
; procedure message_arrived(buf,ref);
;
; this procedure is called from 'check_event_queue' when a message is
; received and mess_descr.proc = 'message arrived' (proc=3). the message
; descriptor must contain an letter and the address of a mailbox.
;
; eda +0: 1<12 + 3
; +2: open1 < 12 + open2
; +4: mailbox addr
; letter -> +6: sendes hvis open1<>0 og opcode
; +8: i buffer er >=9 og <=106
; +10: 1<3
; +12: buffer addr
; letter ->+14: sendes hvis open2<>0 og opcode
; +16: i buffer er <9 eller >106
; +18: 1<4
; +20: buffer addr
;
;
; call return
; w0: - destr.
; w1: eda destr.
; w2: buf 0 (the message buffer is removed)
; w3: return destr.
b. j5, i5 w.
d13: rs. w3 j0. ; save return
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<0 ; if CL testout then
\f
;. tas 1.0 14.05.87 check eventqueue cltxt ...26...
jl. w3 d65. ; message arrived; ( type 27 )
z. ;
zl w0 x2+8 ; w0:=buf.opcode;
sh w0 106 ;
sh w0 8 ; if w0<=106 or w0>=9 then begin
jl. i1. ;
zl w0 x1+2 ; if eda.open1<>0 then begin
sn w0 0 ;
jl. i3. ; get_event(buf);
jd 1<11+26 ;
al w0 0 ; eda.open1:=0;
hs w0 x1+2 ; let:=eda+6;
al w0 1<3 ; let.type:=1<3;
rs w0 x1+10 ; let.buf:=buf;
rs w2 x1+12 ; mbx:=eda.mbx;
rl w2 x1+4 ; goto S;
al w1 x1+6 ; end else goto exit;
jl. i2. ; end;
i1: zl w0 x1+3 ; /* w0>106 eller w0<9 */
sn w0 0 ; if eda.open2<>0 then
jl. i3. ; goto exit;
jd 1<11+26 ; get_event(buf);
al w0 0 ;
hs w0 x1+3 ; eda.open2:=0;
al w0 1<4 ; let:=eda+14;
rs w0 x1+18 ; let.type:=1<4;
rs w2 x1+20 ; let.buf:=buf;
rl w2 x1+4 ; mbx:=eda.mbx;
al w1 x1+14 ;
i2: jl. w3 e30. ; S: send_letter(mbx,let);
al w2 0 ; buf:=0;
i3: jl. (j0.) ; exit: return;
j0: 0 ; saved return;
e.
; procedure tem_message(buf,ref);
;
; this procedure is called from 'check_event_queue' when a message is
; received and mess_descr.proc = 'tem message' (proc=4). the message
; descriptor must contain an letter and the address of a mailbox.
\f
;. tas 1.0 14.05.87 check eventqueue cltxt ...27...
;
; -4: next hoved til sender kæde
; -2: prev
; eda +0: 1<12 + 4
; +2: open
; +4: mailbox addr
; letter -> +6: sendes hvis open<>0 og opcode
; +8: i buffer er >=90 eller <=99
; +10: 1<3 eller =106
; +12: buffer addr
;
;
; call return
; w0: - destr.
; w1: eda destr.
; w2: buf 0 (the message buffer is removed)
; w3: return destr.
b. i5,j5 w.
d14: rs. w3 j0. ; save return;
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<0 ; if CL testout then
jl. w3 d67. ; test tem message; ( type 29 )
z. ;
zl w0 x2+8 ; w0:=buf.opcode;
sh w0 99 ;
sh w0 89 ; if (w0>99 or w0<90 )
jl. 4 ; or w0<>106 then begin
jl. i2. ;
sn w0 106 ;
jl. i2. ;
rl w0 x2+6 ; sender:=buf.sender;
al w3 x1-4 ; w3:=addr eda.next;
rs. w3 j1. ; start:=w3;
i1: rl w3 x3 ; while w3.next<>start do begin
sn. w3 (j1.) ; if w3.sender=sender then
jl. i5. ; goto found;
se w0 (x3+4) ; goto not_found;
jl. i1. ;
al w1 x3+4 ; found: message_arrived(eda,buf);
rl. w3 j0. ; prepare return;
\f
;. tas 1.0 14.05.87 check eventqueue cltxt ...28...
jl. d13. ; end;
i2: rl w0 x1+2 ; /* w0<=99 and w0>=90 or w0=106 */
sn w0 0 ; if eda.open<>0 then begin
jl. i4. ;
jd 1<11+26 ; get_event(buf);
al w0 0 ; eda.open:=0;
rs w0 x1+2 ; let:=eda+6;
al w0 1<3 ; let.type:=1<4;
rs w0 x1+10 ; let.buf:=buf;
rs w2 x1+12 ; mbx:=eda.mbx;
rl w2 x1+4 ; send_letter(mbx,let);
al w1 x1+6 ; end;
jl. w3 e30. ;
al w2 0 ; buf:=0;
i4: jl. (j0.) ; return;
i5: jd 1<11+26 ; not_found: get_event(buf);
al w0 1 ; result:=1;
al. w1 j2. ; answer:=(status=p48); /* pool findes ikke */
jd 1<11+22 ; send_answer(result,answer,buf);
al w2 0 ; buf:=0;
jl. (j0.) ; return;
j0: 0 ; saved return;
j1: 0 ; sender
j2: p48 ; answer (pool findes ikke)
e.
; procedure timerscan(ref,buf);
;
; this procedure is called from 'check_event_queue' when an answer arrives
; from 'clock'(proc=5). the timer queue is inspected and coroutines which
; time out are started with result = timeout. after the inspection a
; delay-message is sent to 'clock'.
;
; call return
; w0: - destr.
; w1: ref destr.
; w2: buf 0 (the message buffer is removed)
; w3: return unchanged
\f
;. tas 1.0 14.05.87 check eventqueue cltxt ...29...
b.j5,i5 w.
d15: rs. w3 i0. ; begin
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<1 ; if CL testout then
jl. w3 d64. ; test timerscan: ( type 26 )
z. ;
al. w1 i2. ; <* release messagebuffer *>
jd 1<11+18 ; wait_answer(clock_mess_area,buf);
j4: ;
al. w2 c2. ; corout:= first in timer queue;
j1: rl w2 x2 ; while corout <> timer queue head do
j3: sn. w2 c2. ; begin
jl. j2. ; corout:= next(corout);
rl w1 x2-f2+f8 ; with corout do
sh w1 0 ; begin
jl. j1. ; if timer > 0 then
al w1 x1-a3 ; begin
sh w1 0 ; timer:=timer-a3;
al w1 0 ; if timer <=0 then
rs w1 x2-f2+f8 ; timer:=0;
se w1 0 ;
jl. j1. ; if timer = 0
rl w0 x2 ; then start(corout,prio,timeout);
rs. w0 i1. ;
al w2 x2-f2 ;
rl w0 x2+f1 ; end;
al w1 0 ; end;
jl. w3 e10. ;
rl. w2 i1. ;
jl. j3. ; end while;
j2: jl. w3 e40. ; timer_message;
rl. w3 i0. ; link:= ext1(16);
al w2 0 ; buf:= 0; <* has been removed *>
jl x3 ; end;
i0: 0 ; saved return
i1: 0 ; saved next coroutine;
i2: 0,r.8 ; answer area
e.
\f
;. tas 1.0 14.05.87 check eventqueue cltxt ...30...
; procedure att_answer(ref,buf);
;
; Proceduren kalds fra 'check_event_queue' når proc=6 i eda.
; Proceduren behandler svar på attention message sendt fra en pool handler
; til ejer af poolen. Event descriptor skal indeholde
;
; eda + 0: 1<12 + 6
; + 2: mbuf message buffer addr
; + 4: avar var addr
; + 6: next kædefelt
;
; Proceduren henter svaret med wait_answer og hægter eda ud af used_att
; kæden, og sætter eda tilbage til poolen free_att. Variablen hvis
; adresse står i avar nulstilles.
;
; call return
; w0: - destr.
; w1: ref destr.
; w2: buf 0 (the message buffer is removed)
; w3: return unchanged
b.j5,i5 w.
d16: rs. w3 j0. ; save return;
rs. w1 j1. ; save eda;
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<1 ; if CL testout then
jl. w3 d66. ; test att answer; ( type 28 )
z. ;
al. w1 c25. ;
jd 1<11+18 ; wait_answer(buf,ans,r);
rl. w1 j1. ;
al w0 0 ;
rs w0 (x1+4) ; word(ref.avar):=0;
rl. w1 c31. ; buf:=next(used_att);
al w2 0 ; prev:=0;
i1: sn w1 0 ; while buf<>0 do
jl. i3. ; begin
sn. w1 (j1.) ; if buf=eda then
jl. i2. ; goto F;
al w2 x1 ; prev:=next(buf);
rl w1 x1+6 ; buf:=next(buf);
\f
;. tas 1.0 14.05.87 check eventqueue cltxt ...31...
jl. i1. ; end;
; goto NF;
i2: rl w0 x1+6 ; F: p:=next(buf);
se w2 0 ; if prev<>0 then
rs w0 x2+6 ; next(prev):=p;
sn w2 0 ; if prev=0 then
rs. w0 c31. ; used_att:=p;
sn w0 0 ; if p=0 then
rs. w2 c31.+2 ; used_att.last:=p;
rl. w2 c30. ; w2:=addr free_att;
jl. w3 e57. ; release_bufffer(buf,free_att);
i3: al w2 0 ; NF: w2:=0;
jl. (j0.) ; return
j0: 0 ; saved return
j1: 0 ; saved eda
e.
; procedure rem_answer(ref,buf);
;
; Proceduren kaldes fra 'check_event_queue' når proc=7 i eda.
; Proceduren behandler svar på remove message sendt fra en pool handler
; til ejer af poolen. Event descriptor skal indeholde
;
; eda + 0: open<12 + 6
; + 2: mbx mailbox addr
;(letter->) + 4:
; + 6:
; + 8: 1<6 type
; +10: 0
; +12: 2 opcode
;
; Proceduren sætter open=0 og sender eda+4 og fremsom et letter til
; den mailbox hvis adresse der står i eda+2.
;
; call return
; w0: - destr.
; w1: ref destr.
; w2: buf 0 (the message buffer is removed)
; w3: return unchanged
\f
;. tas 1.0 14.05.87 check eventqueue cltxt ...32...
b.j5,i5 w.
d17: rs. w3 j0. ; save return;
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<1 ; if CL testout then
jl. w3 d68. ; test rem answer; ( type 30 )
z. ;
al w0 0 ;
hs w0 x1 ; eda.open:=0;
rl w2 x1+2 ; send_letter
al w1 x1+4 ; (eda.mbx,eda+4);
jl. w3 e30. ;
al w2 0 ; w2:=0;
jl. (j0.) ; return
j0: 0 ; saved return
e.
; procedure answer_tas(ref,buf);
;
; Proceduren kalds fra 'check_event_queue' når proc=8 i eda.
; Proceduren behandler svar på en message hvor svaret skal ignoreres.
; og samtidigt sendes svar på den message hvis buffer addr står i
; eda+2
;
; eda + 0: 1<12 + 8
; + 2: mbuf
;
; call return
; w0: - destr.
; w1: ref destr.
; w2: buf 0 (the message buffer is removed)
; w3: return unchanged
b.j5,i5 w.
d18: rs. w3 j0. ; save return
al w3 x2 ; gem buf i w3
rl w2 x1+2 ; w2:=mbuf
al w0 x1-2 ; sæt buf ext tilbage i pool
\f
;. tas 1.0 14.05.87 check eventqueue cltxt ...33...
rx. w0 c4. ;
rs w0 x1-2 ;
c.a88<1
rs. w3 6 ; testout registers
jl. w3 e1. ;
h. 39 , 1<1 w. ; type:=39, mask:=1<1
0 ;
z.
al. w1 c25. ; answer.status:=0;
al w0 0 ;
rs w0 x1 ;
al w0 1 ; result:=normal
jd 1<11+22 ; send answer /* til tascat */
al w2 x3 ; /* hent svar på output message */
al. w1 c25. ; wait_answer(ans,buf,res);
jd 1<11+18 ;
al w2 0 ; buf:=0;
rl. w3 j0. ;
jl x3 ; return;
j0: 0 ;
e.
; procedure ignore_answer(ref,buf);
;
; Proceduren kalds fra 'check_event_queue' når proc=9 i eda.
; Proceduren behandler svar på en message hvor svaret skal ignoreres.
;
; eda + 0: 1<12 + 9
;
; call return
; w0: - destr.
; w1: ref destr.
; w2: buf 0 (the message buffer is removed)
; w3: return unchanged
b.j5,i5 w.
d19: al w0 0 ;
hs w0 x1 ; open:=false;
al. w1 c25. ; wait_answer(ans,buf,res);
jd 1<11+18 ;
al w2 0 ; buf:=0;
jl x3 ; return;
\f
;. tas 1.0 14.05.87 check eventqueue cltxt ...34...
e.
\f
; tas 1.0 14.05.87 start coroutine cltxt ...35...
; procedure start_coroutine(priority,ic,corout)
; initialze coroutine descriptor and put it in
; active queue
;
; call return
; w0: priority destroyed
; w1: ic destroyed
; w2: corout corout
; w3: return current coroutine
; procedure start(corout,priority,result)
;
; removes the coroutine from its queue (normally the timer queue) and
; inserts it in active queue according to the call parameter 'priority'.
; the call parameter 'result' is returned in w0 of
; the coroutine which is activated.
;
; call return
; w0: priority destroyed
; w1: result destroyed
; w2: corout corout
; w3: return current coroutine
b.j5, i5 w.
e51: rs. w3 i0. ; start coroutine: begin save return;
rs w1 x2 ; corout.ic := ic;
rl. w1 c12. ; coroutine.ident := ident;
rs w1 x2+f14 ; ident := next ident;
al w1 x1+1 ;
rs. w1 c12. ;
rs w0 x2+f1 ; coroutine.prio := priority;
rl. w0 c63. ; coroutine.test mask := testmask;
rs w0 x2+f13 ;
c.a88<1 ; if testoutput
rl w0 x2+f13 ;
sz w0 1<0 ; if CL testout then
jl. w3 d40. ; test start_coroutine; ( type 2 )
z. ;
al w2 x2+f2 ;
jl. j3. ; goto com;
e10: rs. w3 i0. ; start: save return;
\f
;. tas 1.0 14.05.87 start coroutine cltxt ...36...
c.a88<1 ; if testoutput
rl w3 x2+f13 ;
sz w3 1<1 ; if CL testout then
jl. w3 d41. ; test start; ( type 3 )
z. ;
rs w1 x2+f10 ; corout.result:= result;
rs w0 x2+f1 ; corout.priority:= priority;
al w2 x2+f2 ;
jl. w3 d0. ; remove(corout);
rl w1 0 ;
j3: al w0 x2 ; com: worse:= rear of active queue;
al. w3 c1. ; while worse.prio > prio and
al w1 x1+1 ; worse <> active queue head do
j1: rl w3 x3+2 ; worse:= prev(worse);
sn. w3 c1. ;
jl. j2. ; 'insert corout in the rear of
sh w1 (x3-f2+f1) ; other coroutines of the same
jl. j1. ; priority'
j2: rl w1 x3 ;
rl w2 0 ;
jl. w3 d1. ; link(worse,corout);
al w2 x2-f2 ;
rl. w3 c0. ;
jl. (i0.) ; end;
i0: 0 ; saved returne.
e.
\f
; tas 1.0 14.05.87 wait cltxt ...37...
; procedure wait(timer,result);
; calling coroutine is suspended for max 'timer' seconds.
; 'timer' = 0 indicates no timeout. the return parameter 'result'
; indicates whether the coroutine was started by timeout or by
; the arrival of an internal or external event.
;
; call return
; w0: timer result
; w1: unchanged
; w2: unchanged
; w3 return current coroutine
b.j5 w.
e11: rs. w3 (c0.) ; begin curco.return:= return;
rl. w3 c0. ;
rs w0 x3+f8 ; curco.timer:= timer;
ds w2 x3+f12 ; curco.w1:=w1; curco.w2:=w2;
c.a88<1 ; if testoutput
rl w0 x3+f13 ;
sz w0 1<1 ; if CL testout then
jl. w3 d42. ; test wait; ( type 4 )
rl. w3 c0. ;
z. ;
al w2 x3+f2 ;
jl. w3 d0. ; remove(current coroutine);
al. w1 c2. ;
jl. w3 d1. ; link(timer queue head,current coroutine);
jl. d2. ; central wait;
; end;
e.
\f
; tas 1.0 14.05.87 pass cltxt ...38...
; procedure pass(priority);
;
; pending events are scheduled and calling coroutine is restarted
; with the priority given in call.
;
; call return
; w0: priority destroyed
; w1: - destroyed
; w2: - destroyed
; w3: return current coroutine
b.j5 w.
e12: rs. w3 (c0.) ; begin current coroutine.ic = return;
c.a88<1 ; if testoutput
am. (c0.) ;
rl w3 f13 ;
sz w3 1<0 ; if CL testout then
jl. w3 d44. ; test pass; ( type 5 )
z. ;
rl. w2 c0. ;
rl w1 x2+f10 ; result:= current_coroutine.result;
jl. w3 e10. ; start(current_coroutine,priority,result);
jl. d2. ; central wait;
e. ; end;
\f
; tas 1.0 14.05.87 inspect cltxt ...39...
; procedure inspect(priority,result);
;
; schedules pending events and checks if the active queue contains
; coroutines with priority higher than the call parameter 'priority'. in
; this case 'result' returns true (1).
;
; call return
; w0: priority result
; w1: - destroyed
; w2: - destroyed
; w3: return current coroutine
b.j5, i5 w.
e13: ds. w3 i1. ; begin save return, priority;
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<0 ; if CL testout then
jl. w3 d43. ; test inspect; ( type 6 )
z. ;
jl. w3 d6. ; check_event_queue;
rl. w0 i1. ; restore priority;
rl. w3 c1. ; corout:= first in active queue;
sl w0 (x3+f1) ;
am -1 ; result:= corout.prio > priority;
al w0 1 ;
rl. w3 c0. ;
jl. (i0.) ; end;
i0: 0 ; saved return
i1: 0 ; saved priority
e.
; procedure create_coroutine(cda);
;
; Henter en coroutine beskrivelse fra puljen af frie, og initialisere
; den til 0. I coroutine beskrivelsen initialiseres, main_mbx,
; stop_sem og next,prev til aktivkæden.
;
; call return
; w0: unch
; w1: cda eller 0
\f
;. tas 1.0 14.05.87 inspect cltxt ...40...
; w2: unch
; w3: return current coroutine
b. i5,j5 w.
e14: rs. w0 j0. ; save w0,w2, return;
ds. w3 j2. ;
rl. w2 c5. ;
jl. w3 e55. ; get_buffer(cdescr,cda);
sn w1 0 ; if cda<>0 then
jl. i2. ; begin
al w2 x1+q200-2 ;
al w0 0 ; for all words in coroutine descriptor do
i1: rs w0 x2 ; word:=0;
al w2 x2-2 ;
se w2 x1 ; end;
jl. i1. ;
al w2 x1+f2 ; q:=addr cda.active_next;
rs w2 x1+f2 ; cda.active_next:=q;
rs w2 x1+f3 ; cda.active_prev:=q;
al w2 x1+f22 ;
jl. w3 e53. ; init_mailbox(cda.main_mbx);
al w0 0 ;
al w2 x1+f26 ;
jl. w3 e52. ; init_semaphor(cda.stop_sem,0);
i2:
c.a88<1 ; if testoutput
am. (c0.) ;
rl w3 f13 ;
sz w3 1<0 ; if CL testout then
jl. w3 d71. ; test create coroutine; ( type 31 )
z. ;
rl. w0 j0. ;
rl. w2 j1. ; restore w0,w2;
rl. w3 c0. ; w3:=curco;
jl. (j2.) ; return
j0: 0 ; saved lock_count
j1: 0 ; saved w2
j2: 0 ; saved return
e.
\f
;. tas 1.0 14.05.87 inspect cltxt ...41...
; procedure remove_coroutine(cda);
;
; hægter en coroutine ud af aktiv/timer køen og sætter coroutine
; beskrivelsen tilbage til puljen af frie. Hvis lock_count i coroutinen
; er større end nul åbnes lock_sem tilsvarende.
;
; call return
; w0: undef
; w1: undef
; w2: cda undef
; w3: return current coroutine
b. i5 w.
e15: rs. w3 (c0.) ; curco.return:=return;
rs. w2 i0. ;
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<0 ; if CL testout then
jl. w3 d72. ; test remove coroutine; ( type 32 )
z. ;
al w2 x2+f2 ;
jl. w3 d0. ; remove(cda);
al w1 x2-f2 ;
rl w0 x1+f25 ;
al. w2 c52. ;
se w0 0 ; if cda.lock_count>0 then
jl. w3 e23. ; g_open(lock_sem,cda.lock_count);
rl. w2 c5. ;
jl. w3 e57. ; release_buffer(cda,cdescr);
jl. d2. ; central wait;
i0: 0 ; saved cda
e.
\f
; tas 1.0 14.05.87 csendmessage cltxt ...42...
; procedure csendpseudomessage(pda,mes,name,buf);
;
; allocates a message buffer extension and prepares it for cwaitanswer.
; then calls sendpseudomessage.
;
; return parameter 'buf': 0 buffer claims exceeded
; 1 no free extensions
; >1 message buffer address
;
; call return
; w0: pda destroyed
; w1: mess destroyed
; w2: name buffer address (or 0 or 1)
; w3: return current coroutine
; procedure csendmessage(mes,name,buf);
;
; allocates a message buffer extension and prepares it for cwaitanswer.
; then calls sendmessage.
;
; return parameter 'buf': 0 buffer claims exceeded
; 1 no free extensions
; >1 message buffer address
;
; call return
; w0: - destroyed
; w1: mess destroyed
; w2: name buffer address (or 0 or 1)
; w3: return current coroutine
b.j5,i5 w.
e16: al w0 0 ; begin csendpseudomessage:
; pda:=0;
e17: rs. w3 i4. ; begin csendpseudomessage;
rs. w0 i5. ; save pda;
ds. w2 i2. ; save mess, buf;
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<0 ; if CL testout then
jl. w3 d45. ; test csendmessage; ( type 7 )
z. ;
\f
;. tas 1.0 14.05.87 csendmessage cltxt ...43...
jl. w3 d7. ; get_mess_ext(ref);
sn w2 0 ; if ref <> 0 <* extension available *> then
jl. j1. ; begin
rl. w0 i0. ; <* initialize answer descriptor *>
rs w0 x2 ; ref.open:= false; ref.proc:= 12;
rs. w2 i3. ; save ref buf ext;
rl. w1 i1. ;
rl. w3 i2. ;
rl. w0 i5. ; if pda=0 then
se w0 0 ; send message(mess,name,buf,ref)
am 108 ; else
jd 1<11+16 ; send pseudo message(pda,mess,name,buf,ref);
se w2 0 ; if buffer claims exceeded
jl. j2. ; then release message buffer extension;
rl. w1 i3. ;
al w0 x1-2 ;
rx. w0 c4. ;
rs w0 x1-2 ;
jl. j2. ;
j1: al w2 1 ; end
j2: rl. w3 c0. ; else buf:= 1; <* no free extensions *>
jl. (i4.) ; end;
i0: 0<12+1 ; answer descriptor init (open=false,proc='answer_arived')
i1: 0 ; saved mess
i2: 0 ; saved name addr
i3: 0 ; saved ref buf ext
i4: 0 ; saved return
i5: 0 ; saved pda
e.
\f
; tas 1.0 14.05.87 cwaitanswer cltxt ...44...
; procedure cwaitanswer(buf,timer,result);
;
; prepares the message buffer extension for receiving the answer.
; the coroutine waits for max. 'timer' seconds for the answer. when the
; coroutine is restarted the action depends on 'result':
;
; result = timeout : the answer descriptor is closed
;
; result = answer arrived : the answer is received in the answer
; area in central logic and the message
; buffer extension is released.
;
; call return
; w0: timer result (timeout:0,wait_answer result:1,2,3,4,5)
; w1: answer area unch
; w2: buf buf
; w3: return current coroutine
b.j10,i5 w.
e18: ds. w0 i1. ; begin
rs. w1 i2. ;
rl. w1 i0. ; current_coroutine.return:= return;
rl. w3 c0. ;
ds w2 x3+f16 ; current_coroutine.buf:= buf;
c.a88<1 ; if testoutput
rl w3 x3+f13 ;
sz w3 1<0 ; if CL testout then
jl. w3 d46. ; test cwaitanswer; ( type 8 )
rl. w3 c0. ;
z. ;
rl w1 x2-2 ; with buf.ref do
al w0 1 ; begin
hs w0 x1 ; open:= true;
rs w3 x1+2 ; corout:= current_coroutine;
; end;
rl. w0 i1. ; restore timer;
rl. w1 i2. ;
jl. w3 e11. ; wait(timer,result);
rs. w1 i2. ;
rl w2 x3+f16 ; buf:= current_coroutine.buf;
rl w1 x2-2 ; ref:= buf.ref;
se w0 0 ; if result = timeout
jl. j2. ; then ref.open:= false
hs w0 x1 ;
\f
;. tas 1.0 14.05.87 cwaitanswer cltxt ...45...
jl. j4. ; else
j2: ; begin <* result = answer arrived *>
al w0 x1-2 ; release message buffer extension;
rx. w0 c4. ;
rs w0 x1-2 ;
rl. w1 i2. ;
jd 1<11+18 ; wait answer(buf,answer_area);
j4: rl. w3 c0. ; end;
c.a88<1 ; if testoutput
rl w3 x3+f13 ;
sz w3 1<0 ; if CL testout then
jl. w3 d47. ; test exit cwaitanswer; ( type 9 )
rl. w3 c0. ;
z. ;
jl (x3+f15) ; end;
; end;
i0: 0 ; saved return
i1: 0 ; saved timer
i2: 0 ; saved answer area addr
e.
\f
; tas 1.0 14.05.87 cregretmessage cltxt ...46...
; procedure cregretmessage(buf);
;
; this procedure is used to regret a message sent by csendmessage, i. e. the
; monitor procedure 'regretmessage' is called and the corresponding message
; buffer extension is released.
;
; call return
; w0: - destr.
; w1: - destr.
; w2: buf buf
; w3: return current_coroutine
b.j5, i5 w.
e19: rs. w3 i0. ; begin
c.a88<1 ; if testoutput
rl w0 x3+f13 ;
sz w0 1<0 ; if CL testout then
jl. w3 d48. ; test cregretmessage; ( type 10 )
z. ;
jd 1<11+82 ; regretmessage(buf);
rl w1 x2-2 ; ref:= buf.ref;
; ext:= next(message_buffer_ext_head);
al w0 x1-2 ; next(message_buffer_ext_head):= ref;
rx. w0 c4. ; next(ref):= ext;
rs w0 x1-2 ;
rl. w3 c0. ;
jl. (i0.) ; end;
i0: 0 ; saved return
e.
\f
; tas 1.0 14.05.87 signal cltxt ...47...
; procedure signal(sem);
;
; call return
; w0: - destroyed
; w1: - destroyed
; w2: sem destroyed
; w3: return current coroutine
b.j5, i5 w.
e20: rs. w3 i0. ; begin
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<0 ; if CL testout then
jl. w3 d49. ; test signal; ( type 11 )
z. ;
rl w1 x2+4 ; with sem do
al w3 x1+1 ; begin
rs w3 x2+4 ; count:= count + 1;
sl w1 0 ; if count <= 0 then
jl. j1. ; begin
rl w2 x2 ; corout:= next(sem);
al w0 0 ;
rs w0 x2+f28-f4 ; wait_sem_addr:=0;
jl. w3 d0. ; remove(corout); /* ud af sem kæden */
al w2 x2-f4+f6 ;
jl. w3 d0. ; remove(corout); /* ud af mbx kæden */
al w2 x2-f6 ;
rl w0 x2+f1 ; priority:= corout.prio;
al w1 1 ; result:= ok;
jl. w3 e10. ; start(corout,priority,result);
j1: rl. w3 c0. ; end;
jl. (i0.) ; end;
; end;
i0: 0 ; saved return
e.
\f
; tas 1.0 14.05.87 wait_semaphore cltxt ...48...
; procedure wait_semaphor(sem);
;
; call return
; w0: - destroyed
; w1: - destroyed
; w2: sem destroyed
; w3: return current coroutine
b.j5, i5 w.
e22: rs. w3 i0. ; begin
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<0 ; if CL testout then
jl. w3 d50. ; test wait_semaphore; ( type 12 )
z. ;
rl w1 x2+4 ; with sem do
al w1 x1-1 ; begin
rs w1 x2+4 ; count:= count-1;
rl. w3 c0. ;
sl w1 0 ; if count < 0 then
jl. (i0.) ; begin
rl. w1 i0. ;
rs w1 x3+f15 ; current_coroutine.return:= return;
rs w2 x3+f28 ; wait_sem_addr:=sem;
al w1 x2 ; head:= sem.coroutine_queue_head;
al w2 x3+f4 ; elem:= current_coroutine.sem_queue_elem;
jl. w3 d1. ; link(head,elem); /* ind i sem kæden */
al w2 x2-f4+f6 ;
rs w2 x2 ; /* hægt mbx kæden til sig selv */
rs w2 x2+2 ;
al w0 0 ; timer:= 0 <* no timeout *>
jl. w3 e11. ; wait(timer);
c.a88<1 ; if testoutput
rl w0 x3+f13 ;
sz w0 1<1 ; if CL testout then
jl. w3 d51. ; test wait_semaphore_exit; ( type 13 )
rl. w3 c0. ;
z. ;
jl (x3+f15) ; end;
; end with;
; end;
i0: 0 ; saved return
\f
;. tas 1.0 14.05.87 wait_semaphore cltxt ...49...
e.
\f
; tas 1.0 14.05.87 g_open, g_lock cltxt ...50...
; procedure procedure g_open(sem,n);
;
; tæller semafor value op med n, og for hver ventende coroutine
; undersøges om værdien er blevet stor nok til at starte coroutinen
;
; call return
; w0: n undef.
; w1: unch.
; w2: sem undef.
; w3: return curco
b. i5,j5 w.
e23: rs. w3 i0. ; begin save return;
rs. w1 i2. ; save w1;
c.a88<1 ; if testoutput
rs. w0 i1. ;
am. (c0.) ;
rl w0 f13 ;
sz w0 1<1 ; if CL testout then
jl. w3 d73. ; test g_open; ( type 33 )
rl. w0 i1. ;
z.
wa w0 x2+4 ; sem.value:=
rs w0 x2+4 ; sem.value + n;
al w1 0 ;
am. (c0.) ;
rs w1 f25 ; lock_count:=0;
sh w0 0 ; if sem.value>0 then
jl. j2. ; begin
rs. w2 i3. ;
al w1 x2 ; cda:=sem;
j1: rl w1 x1 ;
sn w1 x2 ; while (cda:=cda.next) <> sem do
jl. j2. ; begin
rl w0 x2+4 ;
sl w0 (x1-f4+f25); if sem.value >= cda.lock_count then
jl. 4 ;
jl. j1. ; begin
ws w0 x1-f4+f25 ;
rs w0 x2+4 ; sem.value:=
rs. w2 i1. ; sem.value-cda.lock_count;
al w2 x1 ; remove(cda); /* ud af semaphor kæde */
\f
;. tas 1.0 14.05.87 g_open, g_lock cltxt ...51...
jl. w3 d0. ; prio:=cda.prio;
al w2 x2-f4 ; result:=ok;
rl w0 x2+f1 ; start(cda,prio,result);
al w1 0 ; cda:=sem;
jl. w3 e10. ; end;
rl. w1 i1. ; end;
rl. w2 i3. ;
jl. j1. ; end;
j2: rl. w3 c0. ;
rl. w1 i2. ;
jl. (i0.) ; end;
i0: 0 ; saved return
i1: 0 ; saved cda
i2: 0 ; saved w1
i3: 0 ; sem
e.
; procedure g_lock(sem,n);
;
; under søger om en semafors værdie er større end n, hvis det er
; tilfældet tælles den n ned og retur fra proceduren, eller sættes
; coroutinen i kø til semaforen indtil semafor værdien er talt op med
; g_open af en anden coroutine
;
; call return
; w0: n undef.
; w1: undef.
; w2: sem undef.
; w3: return curco
b. i5,j5 w.
e24: rs. w3 i0. ; begin save return;
rs. w0 i1. ;
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<1 ; if CL testout then
jl. w3 d74. ; test g_lock; ( type 34 )
rl. w0 i1. ;
z. ;
\f
;. tas 1.0 14.05.87 g_open, g_lock cltxt ...52...
rl. w3 c0. ;
rs w0 x3+f25 ; lock_count:=n;
ac w0 (0) ; v:=sem.value - n;
wa w0 x2+4 ;
sh w0 -1 ; if v>=0 then begin
jl. j1. ; sem.value:=v;
rs w0 x2+4 ; return;
jl. (i0.) ; end;
j1: rl. w0 i0. ;
rs w0 x3+f15 ; curco.sav_ret:=return;
al w1 x2 ; head:=sem;
al w2 x3+f4 ; elem:=curco.sem_queue;
jl. w3 d1. ; link(head,elem);
al w0 0 ; timer:=0; /* no timeout */
jl. w3 e11. ; wait(timer);
c.a88<1 ; if testoutput
rl w0 x3+f13 ;
sz w0 1<1 ; if CL testout then
jl. w3 d75. ; test g_lock exit; ( type 35 )
rl. w3 c0. ;
z. ;
jl (x3+f15) ; end;
i0: 0 ; saved return;
i1: 0 ; n
e.
\f
; tas 1.0 14.05.87 send_letter cltxt ...53...
; procedure send_letter(mailbox,letter);
;
; signals an letter to a mailbox. if the coroutine queue of
; the mailbox contains a coroutine which is waiting for an letter
; of this type,the coroutine is started. otherwise the letter is
; queued to the mailbox.
;
; call return
; w0: - destroyed
; w1: letter destroyed
; w2: mailbox destroyed
; w3: return current coroutine
b.j10, i5 w.
e30: rs. w3 i0. ; begin
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
sz w0 1<0 ; if CL testout then
jl. w3 d52. ; test send_letter; ( type 14 )
z. ;
rl w3 x2 ; head:= sem.coroutine_queue_head;
j1: sn w3 x2 ; corout:= next(head); found:= false;
jl. j4. ; while corout <> head and -, found do
rl w0 x3-f6+f9 ; if logand(corout.mask,letter.type) <> 0 then
la w0 x1+4 ; begin
se w0 0 ;
jl. j3. ; found:= true;
rl w3 x3 ;
jl. j1. ;
j3: rs w1 x3-f6+f16 ; corout.latop:= letter;
rl w0 x1+4 ; type:= letter.type;
rs. w0 i1. ;
al w2 x3 ;
jl. w3 d0. ; remove(corout); /* ud af mbx kæden */
al w1 0 ; sem:=wait_sem_addr;
rx w1 x2-f6+f28 ; wait_sem_addr:=0;
sh w1 0 ; if sem>0 then
jl. j2. ; /* coroutine venter på semaphor */
rl w0 x1+f32 ; sem.value:=sem.value+1;
ba. w0 1 ;
rs w0 x1+f32 ;
j2: al w2 x2-f6+f4 ;
\f
;. tas 1.0 14.05.87 send_letter cltxt ...54...
jl. w3 d0. ; remove(corout); /* ud af sem kæden */
al w2 x2-f4 ;
rl. w1 i1. ; result:= type;
rl w0 x2+f1 ; priority:= corout.prio;
jl. w3 e10. ; start(corout,priority,result);
jl. j5. ; end
; else corout:= next(corout);
j4: rx w2 2 ; if -,found
al w1 x1+4 ; then link(sem.letter_queue,letter);
jl. w3 d1. ;
j5: rl. w3 c0. ;
jl. (i0.) ; end;
i0: 0
i1: 0
e.
\f
; tas 1.0 14.05.87 inspect_mailbox cltxt ...55...
; procedure inspect_mailbox(mailbox,mask,letter,result);
;
; checks if 'mailbox_letter_queue' contains an letter which matches 'mask'.
; if no matching letter is found, 'letter' returns = 0,
; otherwise 'letter' refers to the first matching letter.
; 'result' returns 'true' (1) if the active queue contains coroutines of
; priorities higher than the priority of calling coroutine.
;
; call return
; w0: - (result= 0,1)
; w1: mask letter or 0
; w2: mailbox mailbox
; w3: return current coroutine
b.j10, i5 w.
e31: rs. w3 i0. ; begin
rs. w2 i1. ; save mailbox;
c.a88<1 ; if testoutput
am. (c0.) ;
rl w0 f13 ;
so w0 1<1 ; if CL testout then
jl. 6
am -1000 ;
jl. w3 d53.+1000 ; test inspect_mailbox; ( type 15 )
z. ;
al w0 x1 ;
rl w1 x2+4 ; head:= sem.letter_queue_head;
j1: ; letter:= next(head); found:= false;
sn w1 x2+4 ; while letter <> head and -,found do
jl. j3. ; if logand(letter.type,mask) <> 0
rl w3 x1+4 ; then found:= true
la w3 0 ; else letter:= next(letter);
se w3 0 ;
jl. j4. ;
rl w1 x1 ;
jl. j1. ;
j3: al w1 0 ; if -,found then letter:= 0;
j4: rl. w3 c0. ;
rl w0 x3+f1 ; priority:= current_coroutine.prio;
rl. w2 c1. ; corout:= first in active queue;
sh w0 (x2+f1) ;
am -1 ;
al w0 1 ; result:= corout.prio > priority;
rl. w2 i1. ;
\f
;. tas 1.0 14.05.87 inspect_mailbox cltxt ...56...
jl. (i0.) ; end;
i0: 0 ; saved return
i1: 0 ; saved mailbox
e.
\f
; tas 1.0 14.05.87 wait_letter cltxt ...57...
; procedure wait_letter(mailbox,mask,timer,letter)
;
; if 'mailbox.letter_queue' contains an letter
; which matches 'mask', the letter is removed from the queue . a 'pass'
; is executed if the active queue contains coroutines of priorities higher
; than the priority of calling coroutine. if no matching letter is found
; pending events are scheduled and the calling coroutine waits for max. 'timer'
; seconds for an letter to arrive.
;
; if the letter contains a message or an answer ('letter.type' = 1<0 or 1<1 ,
; resp ) , the buffer contents is copied to the common message-answer area in
; central logic, a buffer containing an answer is removed from the event
; queue by 'waitanswer'.
;
;
; call return
; w0: timer result ( 0(timeout) or letter.type)
; w1: mask letter (undefined if result = timeout)
; w2: mailbox destr.
; w3: return current_coroutine
b.j10, i5 w.
e32: rs. w3 i0. ; begin
rx. w1 i0. ;
rl. w3 c0. ;
rs w1 x3+f15 ; current_coroutine.return:= return;
rx. w1 i0. ; current_coroutine.waitch_mask:= mask;
ds w1 x3+f9 ; current_coroutine.timer:= timer;
c.a88<1 ; if testoutput
rl w0 x3+f13 ;
so w0 1<0 ; if CL testout then
jl. 6 ;
am -1000 ;
jl. w3 d54.+1000 ; test wait_letter; ( type 16 )
z. ;
jl. w3 e31. ; inspect_mailbox(mailbox,mask,letter,result);
se w1 0 ; if letter = 0 then
jl. j1. ; begin <* wait in mailbox queue *>
al w1 x2 ; head:= mailbox.coroutine_queue_head;
al w2 x3+f6 ; elem:= current_coroutine.mailbox_queue_elem;
jl. w3 d1. ; link(head,elem);
al w0 0 ;
\f
;. tas 1.0 14.05.87 wait_letter cltxt ...58...
rs w0 x2+f28-f6 ; sem_wait_addr:=0;
al w2 x2-f6+f4 ;
rs w2 x2 ; /* hægt sem kæden til sig selv */
rs w2 x2+2 ;
rl w0 x2-f4+f8 ; timer:= current_coroutine.timer;
jl. w3 e11. ; wait(timer,result);
se w0 0 ; if result = timeout then
jl. j6. ; begin
rs w0 x3+f10 ; current_coroutine.result:= timeout;
al w2 x3+f6 ; elem:= current_coroutine.mailbox_queue_elem;
jl. w3 d0. ; remove(elem);
jl. j6. ; end;
; goto exit;
; end;
j1: rs w1 x3+f16 ; current_coroutine.latop:= letter;
rl w2 x1+4 ;
rs w2 x3+f10 ; current_coroutine.result:= letter.type;
al w2 x1 ;
jl. w3 d0. ; remove(letter);
rl. w3 c0. ; if waiting <* coroutines of higher
sn w0 0 ; priority in active queue *> then
jl. j2. ; begin
rl w0 x3+f1 ; priority:= current_coroutine.prio;
jl. w3 e12. ; pass(priority);
; end;
j2: rl w0 x3+f10 ;
j6: rl. w3 c0. ; exit:
c.a88<1 ; if testoutput
rl w1 x3+f16 ;
rl w3 x3+f13 ;
so w3 1<0 ; if CL testout then
jl. 6 ;
am -1000 ;
jl. w3 d55.+1000 ; test wait_letter_exit; ( type 17 )
rl. w3 c0. ;
z. ;
rl w0 x3+f10 ; result:= current_coroutine.result;
rl w1 x3+f16 ; letter:= current_coroutine.latop; <* undef if timeout *>
jl (x3+f15) ; end;
i0: 0 ; saved return
e.
\f
; tas 1.0 14.05.87 sendmessage cltxt ...59...
; procedure sendmessage(name,message,letter,mailbox,result);
;
; sends a massage to the process given by 'name'. when the answer arrives
; it is signalled to the mailbox. the calling coroutine must
; provide the eda which is used as a message buffer extention and a letter
;
; eda + 0: open<12 + 0
; + 2: mailbox addr
; letter -> + 4:
; + 6:
; + 8: 1<1
; +10: buffer address
;
; call return
; w0: mailbox destr.
; w1: params destr.
; w2: eda buffer addres ( or 0 = claims exceeded )
; w3: return current coroutine
;
; 'params' points at a parameter area containing:
;
; params +0: name(1)
; +2: name(2)
; +4: name(3)
; +6: name(4)
; +8: name table address
; +10: mess(1)
; +12: mess(2)
; etc.
b.j5,i5 w.
e33: rs. w3 i2. ; begin
rs. w0 i1. ; with letter.answer_descriptor do
c.a88<1 ; if testoutput
am. (c0.) ;
rl w3 f13 ;
so w3 1<0 ; if CL testout then
jl. 6 ;
am -1000 ;
jl. w3 d56.+1000 ; test sendmessage ( type 18 )
z. ;
rl. w0 i0. ;
rs w0 x2 ; proc:= answer;
\f
;. tas 1.0 14.05.87 sendmessage cltxt ...60...
rl. w0 i1. ; open:= true;
rs w0 x2+2 ; answer_mailbox := mailbox;
al w3 x1 ;
al w1 x1+10 ; name_address:= params;
; message_address:= params+10;
jd 1<11+16 ; sendmessage(name_addres,message_address,eda,result);
rl. w3 c0. ;
jl. (i2.) ; end;
i0: 1<12+0 ; answer_descriptor init;
i1: 0 ; saved mailbox
i2: 0 ; saved return
e.
; procedure wait_sem_letter(mailbox,semaphor,mask,letter);
;
; Venter på et letter med en given type, på en given mailbox, eller på at
; en semaphor skal blive åbnet. Mask angiver hvilke typer letter der
; skal ventes på. Bit 23 i maks er bruges til at angive om der skal
; ventes på semaphor.
;
; call return
; w0: semaphor result (1=sem, ellers letter.type)
; w1: mask letter (undef hvis result=1)
; w2: mailbox addr undef
; w3: return curco
b.j5,i6 w.
e34: sz w1 1 ; if mask and 1 = 0 then
jl. i1. ; wait_letter(mailbox,mask,0,letter);
al w0 0 ;
jl. e32. ;
i1: rs. w3 j0. ; save return;
rl. w3 c0. ; w3:=curco;
rs w1 x3+f9 ; curco.mask:=mask;
rs w0 x3+f11 ; curso.w0:=sem;
rl. w0 j0. ;
rs w0 x3+f15 ; curso.return:=return;
c.a88<1 ; if testoutput
rl w0 x3+f11 ;
\f
;. tas 1.0 14.05.87 sendmessage cltxt ...61...
rl w3 x3+f13 ;
so w3 1<0 ; if CL testout then
jl. 6 ;
am -1000 ;
jl. w3 d76.+1000 ; test wait sem letter; ( type 36 )
z. ;
jl. w3 e31. ; inspect_mailbox(mailbox,mask,letter,result);
se w1 0 ; if letter=0 then
jl. i3. ; begin /* ingen letter på mailbox */
rs. w2 j1. ;
rl w1 x3+f11 ;
rl w2 x1+f32 ; sem.value:=sem.value-1;
al w2 x2-1 ;
rs w2 x1+f32 ; if sem.value>=0 then
sl w2 0 ; goto exit;
jl. i5. ; /* hægt curco til semaphor */
rs w1 x3+f28 ; sem_wait_addr:=sem;
al w2 x3+f4 ; elem:=curco.sem_queue;
jl. w3 d1. ; link(sem,elem);
rl. w3 c0. ;
rl. w1 j1. ; /* hægt curco til mailbox */
al w2 x3+f6 ; elem:=curco.mbx_queue;
jl. w3 d1. ; link(mbx,elem);
al w0 0 ;
am. (c0.) ;
rl w1 f11 ;
jl. w3 e11. ; wait(0,result);
se w0 1 ; if result=semaphor then
jl. i2. ; begin
al w2 x3+f6 ; remove(curco.mbx_queue);
jl. w3 d0. ; w3:=curco;
rl. w3 c0. ; goto exit;
jl. i5. ; end;
i2: rl. w3 c0. ; /* result = letter.type */ goto exit1;
jl. i6. ; end;
i3: rs w1 x3+f16 ; /* fundet letter med rigtig type */
rl w2 x1+4 ;
rs w2 x3+f10 ; result:=letter;
al w2 x1 ;
jl. w3 d0. ; remove(letter);
rl. w3 c0. ; w3:=curco;
sn w0 0 ; if waiting coroutine with higher
jl. i4. ; priority then
rl w0 x3+f1 ; pass(curco.prio);
\f
;. tas 1.0 14.05.87 sendmessage cltxt ...62...
jl. w0 e12. ;
i4: rl w0 x3+f10 ;
jl. 4 ;
i5: al w0 1 ; exit: result:=1;
i6: rl w1 x3+f16 ; exit1:
c.a88<1 ; if testoutput
am. (c0.) ;
rl w3 f13 ;
so w3 1<1 ; if CL testout then
jl. 6 ;
am -1000 ;
jl. w3 d77.+1000 ; test wait sem letter exit; ( type 37 )
rl. w3 c0. ;
z. ;
jl (x3+f15) ; return;
j0: 0 ; saved w0
j1: 0 ; saved w2
j2: 0 ; saved return
e.
\f
; tas 1.0 14.05.87 timer_message cltxt ...63...
; procedure timer_message;
;
; sends a delay-message to 'clock'.
;
; call return
; w0: - unchanged
; w1: - destr.
; w2: - buf or 0
; w3: return current_coroutine
b.j5, i5 w.
e40: rs. w3 i0. ; begin
al. w1 i1. ; mess:= delaymess;
al. w2 i3. ; ref:= answer_descr;
al. w3 i2. ; name:= <:clock:>;
jd 1<11+16 ; sendmessage(name,mess,ref,result);
rl. w3 c0. ;
jl. (i0.) ; end;
i0: 0 ; saved return
i1: 0,a3 ; timer delay message
i2: <:clock:>,0,0,0 ;
i3: 1<12+5 ; timer message eda
e.
\f
; tas 1.0 14.05.87 reserve_buffer cltxt ...64...
; procedure reserve_buffer(bytes,first,last);
;
; reserve some bytes from free core
;
; call return
; w0: unchanged
; w1: bytes first buffer addr.
; w2: last buffer addr.
; w3: return unchanged
b. j5 w.
e50: sz w1 1 ; begin
al w1 x1+1 ; if odd then bytes:=bytes+1;
ac w1 x1 ;
rl. w2 c11. ;
wa w1 4 ; top used := top used - bytes;
rs. w1 c11. ; w1 := first buffer addr.
al w2 x2-2 ; w2 := last buffer addr.
sl. w1 (c10.) ; if top used >= first free core then
jl x3 ; return;
je -11 ; rcm fault;
e. ; end;
\f
; tas 1.0 14.05.87 init semaphore and mailbox cltxt ...65...
; procedure init_semaphore(sem,value);
;
; initialize an semaphore to empty
;
; call return
; w0: value unchanged
; w1: unchanged
; w2: sem unchanged
; w3: return unchanged
b. j5 w.
e52: rs w2 x2+f30 ; begin
rs w2 x2+f31 ; sem.prev:=sem.next:=sem;
rs w0 x2+f32 ; sem.value:=value;
jl x3 ; return;
e. ; end;
; procedure init_mailbox(mailbox);
;
; initialize an mailbox to empty
;
; call return
; w0: destroyed
; w1: unchanged
; w2: mailbox unchanged
; w3: return unchanged
b. j5 w.
e53: rs w2 x2+f40 ; begin mailbox.next_co := mailbox;
rs w2 x2+f41 ; mailbox.prev_co := mailbox;
al w0 x2+f42 ; mailbox.next_let := mailbox;
rs w0 x2+f42 ; mailbox.next_le := mailbox;
rs w0 x2+f43 ;
jl x3 ; return;
e. ; end;
\f
; tas 1.0 14.05.87 create_pool cltxt ...66...
; procedure create_pool(elements,bufsize,pool);
;
; reserve memory for a pool, and initialize the pool
;
;
; call return
; w0: elements destroyed
; w1: bufsize destroyed
; w2: pool
; w3: return destroyed
b. j5, i5 w.
e54: ds. w0 i0. ; begin save return, elements;
rs. w1 i2. ; save bufsize;
wm. w1 i0. ; size:=bufsize*elements;
al w1 x1+f54 ; size:=size+pool head size;
sn w0 0 ; if size>2**23 then
sh w1 0 ; rcm fault;
je -20 ;
jl. w3 e50. ; reserve_buffer(size,first,last);
rs. w1 i3. ; pool:=first;
rs w1 x1+f50 ; pool.next:=pool;
rs w1 x1+f51 ; pool.prev:=pool;
rl. w0 i0. ; pool.elem:=elements;
rs w0 x1+f52 ;
al w3 x1+f54 ; first:=first+pool head size;
rs w3 x1+f53 ; pool.first_free:=first;
al w1 x3 ;
j0: wa. w3 i2. ; rep: next:=first+bufsize;
sl w3 x2 ; if next <= last then
jl. j1. ; begin
rs w3 x1 ; elem(next):=next;
al w1 x3 ; first:=next;
jl. j0. ; goto rep;
j1: al w0 0 ; end;
rs w0 x1 ; elem(next):=0;
rl. w2 i3. ;
jl. (i1.) ; return;
; end;
i1: 0 ; saved return
i0: 0 ; elements
i2: 0 ; bufsize
i3: 0 ; pool
\f
;. tas 1.0 14.05.87 create_pool cltxt ...67...
e.
; procedure get_buffer(pool,buff_addr);
;
; henter en buffer fra en pool, hvis der er tom returneres 0
;
; call return
; w0: undef
; w1: buffer addr eller 0
; w2: pool unch.
; w3: return curco
b. j5, i5 w.
e55: rs. w3 j0. ; save return;
rl w3 x2+f52 ; w3:=pool.sem.value;
al w1 0 ; buf addr := 0;
sh w3 0 ; if w3 > 0 then
jl. i1. ; begin
al w3 x3-1 ; pool.sem.value:=w3-1;
rs w3 x2+f52 ;
rl w1 x2+f53 ; buf_addr:=pool.first_free;
rl w0 x1 ; pool.first_free:=
rs w0 x2+f53 ; word(buf_addr);
i1: ; end;
c.a88<1 ; if testoutput
am -1000 ;
am. (c0.+1000) ;
rl w0 f13 ;
so w0 1<1 ; if CL testout then
jl. 6 ;
am -1000 ;
jl. w3 d78.+1000 ; test get_buffer; ( type 38 )
z. ;
am -1000 ;
rl. w3 c0.+1000 ;
jl. (j0.) ; w3:=curco; return;
j0: 0 ; saved return;
e.
\f
;. tas 1.0 14.05.87 create_pool cltxt ...68...
\f
; tas 1.0 14.05.87 wait_buffer cltxt ...69...
; procedure wait_buffer(pool,buffer);
;
; get the address of a free buffer in a pool
;
;
; call return
; w0: destroyed
; w1: buffer addr
; w2: pool unch.
; w3: return current coroutine
b. j5 w.
e56:
am -1000 ;
rl. w1 c0.+1000 ; begin
ds w3 x1+f18 ; save pool, return;
c.a88<1 ; if testoutput
am -1000 ;
am. (c0.+1000) ;
rl w0 f13 ;
so w0 1<1 ; if CL testout then
jl. 6 ;
am -1000
jl. w3 d57.+1000 ; test wait_buffer; ( type 19 )
z. ;
jl. w3 e22. ; wait_semaphore(pool);
rl w2 x3+f17 ; ref:=pool.first_free;
rl w1 x2+f53 ; pool.first_free:=next(ref);
rl w0 x1 ;
rs w0 x2+f53 ;
c.a88<1 ; if testoutput
rl w0 x3+f13 ;
so w0 1<1 ; if CL testout then
jl. 6 ;
am -1000
jl. w3 d58.+1000 ; test wait_buffer_exit; ( type 20 )
z. ;
jl (x3+f18) ; end;
e.
\f
; tas 1.0 14.05.87 release buffer cltxt ...70...
; procedure release_buffer(buffer,pool);
;
; put a buffer back in a pool
;
;
; call return
; w0: destroyed
; w1: buffer addr. destroyed
; w2: pool unchanged
; w3: return current coroutine
b. j5, i5 w.
e57: rs. w3 i0. ; begin save return;
ds. w2 i2. ; save buffer,pool;
c.a88<1 ; if testoutput
am -1000 ;
am. (c0.+1000) ;
rl w0 f13 ;
so w0 1<1 ; if CL testout then
jl. 6 ;
am -1000
jl. w3 d59.+1000 ; test release_buffer; ( type 21 )
z. ;
jl. w3 e20. ; signal(pool);
dl. w2 i2. ;
al w0 x1 ; w0:=buffer;
rx w0 x2+f53 ; pool.first_free:=buffer, w0:=first;
rs w0 x1 ; next(buffer):=first;
jl. (i0.) ; return;
; end;
i0: 0 ; saved return;
i1: 0 ; buffer addr.
i2: 0 ; pool
e.
; coroutine beskrivelse til receive message coroutine
u9: 0,a20,-1,p36,1,0,r.27
1<12+4, 0,r.4, 1<3, 0, 1<12+2,
0,r.4, 1<2, 0, 0, 0, 1<12,
h. 0,r.(:q38-94:) w.
\f
;. tas 1.0 14.05.87 release buffer cltxt ...71...
e. ; end CL
▶EOF◀