|
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: 92928 (0x16b00)
Types: TextFile
Names: »kkrcmonret«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦87223b8a0⟧ »kkrcmonfil«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦87223b8a0⟧ »kkrcmonfil«
└─⟦this⟧
(
message monchange release 6.2 to 7.0
clear temp mondef moncentral monprocs mondisc monfpaline monhost monfpasub,
montabinit monprocfnc1 monprocfnc2 mons1 mons2 moncatinit,
mdef mcentral mprocs mdisc mfpaline mhost mfpasub,
mtabinit mprocfnc1 mprocfnc2 ms1 ms2 mcatinit
contract entry.kkrcmonfil mondef moncentral monprocs mondisc monfpaline,
monhost monfpasub montabinit monprocfnc1 monprocfnc2 mons1 mons2 moncatinit
skip 36.1
c=copy mess.no 1
mdef=edit mondef
skip 36.1
c=copy mess.no 1
mcentral=edit moncentral
skip 36.1
c=copy mess.no 1
mprocs=edit monprocs
skip 36.1
c=copy mess.no 1
mdisc=entry mondisc
skip 36.1
c=copy mess.no 1
mfpaline=entry monfpaline
skip 36.1
c=copy mess.no 1
mhost=edit monhost
skip 36.1
c=copy mess.no 1
mfpasub=edit monfpasub
skip 36.1
c=copy mess.no 1
mtabinit=entry montabinit
skip 36.1
c=copy mess.no 1
mprocfnc1=entry monprocfnc1
skip 36.1
c=copy mess.no 1
mprocfnc2=edit monprocfnc2
skip 36.1
c=copy mess.no 1
ms1=edit mons1
skip 36.1
c=copy mess.no 1
ms2=edit mons2
skip 36.1
c=copy mess.no 1
mcatinit=edit moncatinit
head cpu
end)
$def
;********************
l./b.a450/,d,i/
b.a800,b200 w.
/,
l./a135/,r/=6/=7/
l./a136/, r/=2/=0/
l./i0=/,r/81 03 01/81 08 01/
l./a199=2/,l1,i/
a400=0 ; coroutine monitor inclusion (default no)
; **** definition of coroutine monitor formats:
;
; coroutine description;
a694 = -6 ; next in semaphore queue
a696 = -4 ; previous in semaphore queue
a698 = -2 ; priority
a700 = 0 ; save ic (return)
a702 = 2 ; next coroutine
a704 = 4 ; prev coroutine
a706 = 6 ; timer
a708 = 8 ; mask f. waitchained
a710 = 10 ; save w0(for test purposes only) or result
a712 = 12 ; save w1
a714 = 14 ; save w2
a716 = 16 ; testmask
a718 = 18 ; ident
a720 = 20 ; user exit (0 or exit addr)
a722 = 22 ; return address for waitsem,waitchained,cwaitanswer
a724 = 24 ; ref. to operation (waitchained) or buf (cwaitanswer)
; operation:
a670 = +0 ; next operation
a672 = +2 ; prev operation
a674 = +4 ; type
; chained semaphore:
a650 = +0 ; next coroutine
a652 = +2 ; prev coroutine
a654 = +4 ; next operation
a656 = +6 ; prev operation
; simple semaphore:
a660 = +0 ; next coroutine
a662 = +2 ; prev coroutine
a664 = +4 ; count
; second process extension.
; contains key variables of the coroutine system .
a538 = -12 ; start of testbuffer
a540 = -10 ; start of next record in test buffer
a542 = -8 ; top of test buffer
a544 = -6 ; test output flag (1 = on)
a546 = -4 ; next in active queue
a548 = -2 ; prev in active queue
a550 = 0 ; current coroutine
a552 = 2 ; next in timer queue
a554 = 4 ; prev in timer queue
a556 = 6 ; name of the testoutput process
a566 = 16 ; start of testoutput message
a582 = 32 ; last event pointer
a584 = 34 ; message decriptor pointer(cur)
a586 = 36 ; start of table containing references to user defined procedures
a588 = 38 ; first message buffer extension
a590 = 40 ; start of common message-answer area
a616 = 56 ; name of 'clock'
a626 = 66 ; start of 'clock'-message
a630 = 70 ; answer descriptor for answer from 'clock'
/,
l./a303=j0/,d,i/
a303= j0 ; top of save area
a305= j0, j0 = j0+2 ; first process extension
a306= j0, j0 = j0+2 ; second process extension
/,
l./format of device/,i/
a60 = 16 ; <mess descr>
/,f
$central
;********************
l./i0=/,r/81 01 12/81 04 06/
l./c103/,r/103/200/,
l./b26=b5/,i/
c.a400-1
b27: 0 ;124: first process extension(cur)
b28: 0 ;126: second process extension(cur)
b141:0 ;128: coroutine testoutput address
; links to cmon procedures:
b140:c100 ;130: address of cmon procedure start
c101 ;132: - '' - wait
c102 ;134: - '' - pass
c103 ;136: - '' - inspect
c104 ;138: - '' - csendmessage
c105 ;140: - '' - cwaitanswer
c106 ;142: - '' - answer_arrived
c107 ;144: - '' - signal_binary
c108 ;146: - '' - signal_sem
c109 ;148: - '' - wait_sem
c110 ;150: - '' - signal_chained
c111 ;152: - '' - inspect_chained
c112 ;154: - '' - wait_chained
c113 ;156: - '' - sem_send_mess
c114 ;158: - '' - sem_answer_proc
c115 ;160: - '' - message_received
c116 ;162: - '' - timer_message
c117 ;164: - '' - timer_scan
c118 ;166: - '' - cregretmessage
c119 ;168: - '' - user testoutput
z.
/,
l./c99:/,l./ds w1 x3+a325/,
l./;if the new current/,i/
c.a400-1
; insert process extension addresses in monitor table
dl w1 x2+a306 ;
wa w0 x2+a182 ;
wa w1 x2+a182 ;
ds w1 b28 ;
z.
/,
;<* insert date of options and room for machine id.*>
l./b128=/, r/>1/>1-6/,
l1 , i/
a130 ; date of options
a131 ; time of options
0, r.4 ; room for machine id.
/,
f
$procs
;********************
l./i0=/, r/81 01 12/81 04 09/
l./e57/,l1,r/c29/e58/,
r/ not used/set process extensions/,
l./d16:/,l./i14:/,l./jl (i3)/,d,i/
jl. (i3.) ; return;
/,
l./e19:/,
l./ds w3 b15+2/, i/
aa w3 b15+2 ; clockchange+
/,
l.';procedure start i/o',i/
; procedure set process extension(first ext,last ext)
;
; save w0: result (return)
; save w1: first process ext (call)
; save w2: second process ext (call)
; save w3: -
e58:
c.a400-1
rl w2 x1+a29 ; first:= save w1(cur)
rl w0 x1+a30 ; last:= save w2(cur)
sl w2 (0) ; if last < first then
rx w2 0 ; exchange(first,last)
jl w3 d112 ; check within(first,last)
rl w3 x1+a30 ; w3:= sec. proc. ext.
rl w2 x1+a29 ; w2:= first proc. ext.
ds w3 x1+a306 ; insert log. addr in process description
wa w2 x1+a182 ;
wa w3 x1+a182 ;
ds w3 b28 ; insert phys. addr in monitor table
jl r0 ; goto result 0;
z.
c.a400
jl c29 ;
z.
/,
l./e.;end of start i/,l1,i#
c.a400-1
\f
m. coroutine monitor
;************************** c o r o u t i n e m o n i t o r *************************
; locations in process extension 1 are used by cmonprocedures as described below:
;
; -2: signalch
; b27 +0: start
; +2: check_eventqueue
; +4: check_eventqueue
; +6:
; +8: generate_testoutput
; +10: inspect_chained
; +12: inspect_chained
; +14: timermess
; +16: timerscan
; +18: timerscan
; +20: generate_testoutput
; +22: " - "
; +24: " - "
\f
b.h50 w.
; 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: link link
h0: 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 link old last(head)
h1: 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
; 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: - destroyed
; w2: - ref or 0
; w3: link link
b.j5 w.
h7: rl w1 b28 ; begin
rl w2 x1+a588 ; ref:= cur.ext2.buffer_extension_head;
sn w2 0 ; if ref <> 0 then
jl. j0. ; begin
rl w0 x2 ; cur.ext2.buffer_extension_head:= next(ref);
rs w0 x1+a588 ;
al w2 x2+2 ; ref:= ref+2;
; end;
j0: jl x3 ; end;
e.
\f
; procedure answer arrived(buf,ref);
;
; 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)'. the coroutine is activated and the answer
; descriptor is closed.
;
; call return
; w0: - destroyed
; w1: ref destroyed
; w2: buf buf
; w3: link link
b.j5 w.
c106: am (b27) ; begin
ds w3 +6 ; ext1(4,6):= (buf,link);
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput active
jl. j0. ; then generate testoutput(1<6);
jl. w3 h4. ;
3<22+1<6 ;
j0: al w0 0 ;
hs w0 x1 ; ref.open:= false;
rl w2 x1+2 ; corout:= ref.param1;
al w1 1 ; result:= ok;
rl w0 x2+a698 ; priority:= corout.priority;
jl. w3 c100. ; start(corout,priority,ok);
am (b27) ;
dl w3 +6 ; (buf,link):= ext1(4,6);
jl x3 ; end;
e.
\f
; 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. if 'corout.user_exit' <> 0 a jump to 'user_exit' is
; made with register contents:
; w0: -
; w1: -
; w2: current_coroutine
; w3: link
b.j5
w.
h2: ; begin
; repeat
j0: jl. w3 h6. ; check event queue;
rl w2 b28 ; if active queue empty then
rl w3 x2+a546 ; begin
se w3 x2+a546 ; buf:= cur.ext2.last event;
jl. j1. ; wait event(buf,result);
rl w2 x2+a582 ;
jd 1<11+24 ;
jl. j0. ;
; end;
j1: al w2 x3-2 ; until active queue not empty;
rs w2 (b28) ; corout:= first in active queue;
rl w1 x2+a720 ; if corout.user_exit <> 0
se w1 0 ; then jump to user_exit;
jl w3 x1 ;
rl w3 (b28) ;
dl w1 x3+a712 ;
rl w2 x3+a714 ; restart corout;;
jl (x3) ; end;
e.
\f
; procedure check eventqueue;
;
; inspects the eventqueue starting at 'last event'('last event' = 0
; if the queue must be inspected from the start). pending events
; which have arrived after 'last event' are scheduled if
; 'event descriptor.open' = true. the scheduling is performed by calling
; either a 'cmon'-standard procedure (even procedure number in event
; descriptor) or a user defined procedure (odd procedure number which
; is used as index in the procedure table in process extension 2).
;
; a procedure ('user' or 'cmon') 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 'cmon'- or user-procedure with:
; w0: -
; w1: ref(event descriptor)
; w2: buf
; w3: link
b. j10 w.
h6: am (b27) ; begin
rs w3 +2 ; ext1(2):= link;
rl w3 b28 ;
rl w2 x3+a582 ; last_buf:= cur.ext2.last_event;
j0: jd 1<11+66 ; repeat
rl w3 b28 ;
sh w0 -1 ; test_event(last_buf,buf,result);
jl. j5. ; if result <> empty then
se w0 0 ; begin
jl. j2. ; if result = message
rl w1 x2+4 ;
ac w1 x1 ;
se w1 (b1) ; then ref:=
jl. j1. ; if buf.receiver = cur then cur.ext2.messdescr
rl w1 x3+a584 ; else buf.receiver.messdescr <* pseudoprocess *>
jl. j2. ;
j1: rl w1 x1+a60 ; else <* answer *> ref:= buf.ref;
j2: hl w0 x1 ;
sn w0 0 ;
jl. j0. ; if ref.open then
hl w0 x1+1 ; begin
sz w0 1 ; if even procedure number
jl. j3. ; then call cmonproc(buf,ref);
am (0) ;
jl w3 (130) ;
jl. j0. ; else
j3: ; begin <* odd procedure number *>
rl w3 x3+a586 ; <* use procedure number in event *>
hl w0 x1+1 ; <* descriptor as index in proce- *>
ls w0 +1 ; <* dure table in cur.ext2 *>
wa w0 x3 ;
am (0) ;
jl w3 (0) ; call userproc(buf,ref);
jl. j0. ; end;
; end;
; end;
; until result = empty;
j5: sn w2 0 ; <* if 'last_buf' points at a message , 'last_event'
jl. j6. ; <* must be reset as the message may be regretted
rl w0 x2+4 ; <* before next scan.
se w0 0 ;
sz w0 -8 ; cur.ext2.last_event:= if last_buf points at message
al w2 0 ; then 0
j6: rs w2 x3+a582 ; else last_buf;
am (b27) ; link:= ext1(2);
jl (2) ; end;
e.
\f
; procedure entry 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: link current coroutine
b.j5 w.
c102: am (b28) ; begin
rs w3 (0) ; current_coroutine.ic:= link;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput active
jl. j0. ; then generate testoutput(testkind);
jl. w3 h4. ;
3<22+1<2 ;
j0: rl w2 (b28) ;
rl w1 x2+a710 ; result:= current_coroutine.result;
jl. w3 c100. ; start(current_coroutine,priority,result);
jl. h2. ; central wait;
e. ; end;
\f
; procedure entry 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: link current coroutine
b.j5 w.
c103: am (b28) ; begin
rs w3 (0) ; current_coroutine.ic:= link;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput is active then
jl. j0. ; generate testoutput(1<3);
jl. w3 h4. ;
3<22+1<3 ;
j0: rs w0 (b27) ; ext1(0):= priority;
jl. w3 h6. ; check_event_queue;
rl w0 (b27) ; priority:= ext1(0);
rl w3 b28 ;
rl w3 x3+a546 ; corout:= first in active queue;
sl w0 (x3-4) ;
am -1 ; result:= corout.prio > priority;
al w0 1 ;
rl w3 (b28) ;
jl (x3) ; end;
e.
\f
; procedure entry 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: link current coroutine
b.j5
w.
c100: rs w3 (b27) ; begin
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput is active then
jl. j0. ; generate testoutput(1<0);
jl. w3 h4. ;
3<22+1<0 ;
j0: rs w1 x2+a710 ; corout.result:= result;
rs w0 x2+a698 ; corout.priority:= priority;
al w2 x2+2 ;
jl. w3 h0. ; remove(corout);
rl w1 0 ;
al w0 x2 ;
rl w2 b28 ; worse:= rear of active queue;
al w3 x2+a546 ; while worse.prio > prio and
al w1 x1+1 ; worse <> active queue head do
j1: rl w3 x3+2 ; worse:= prev(worse);
sn w3 x2+a546 ;
jl. j2. ; 'insert corout in the rear of
sh w1 (x3-4) ; other coroutines of the same
jl. j1. ; priority'
j2: rl w1 x3 ;
rl w2 0 ;
jl. w3 h1. ; link(worse,corout);
al w2 x2-2 ;
rl w3 (b28) ;
am (b27) ;
jl (0) ; end;
e.
\f
; procedure entry 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: - destroyed
; w2: - -
; w3 link current coroutine
b.j5
w.
c101: am (b28) ; begin
rs w3 (0 ) ; current coroutine.return:= link;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput active then
jl. j0. ; generate testoutput(1<1);
jl. w3 h4. ;
3<22+1<1 ;
j0: rl w2 (b28) ; current coroutine.timer:= timer;
rs w0 x2+a706 ;
al w2 x2+2 ;
jl. w3 h0. ; remove(current coroutine);
rl w3 b28 ;
al w1 x3+a552 ;
jl. w3 h1. ; link(timer queue head,current coroutine);
jl. h2. ; central wait;
; end;
e.
\f
; procedure entry csendmessage(mess,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: link current coroutine
b.j5,i5 w.
c104: am (b28) ; begin
rs w3 (0) ; current_coroutine.ic:= link;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ;
jl. j0. ; if testoutput active
jl. w3 h4. ; then generate_testoutput(1<4);
3<22+1<4 ;
j0: ds w2 (b27) ;
jl. w3 h7. ; 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;
rl w3 b27 ;
rs w2 x3+2 ; ext1(2):= ref;
rl w1 x3-2 ;
rl w3 x3 ; send message(mess,name,buf,ref);
jd 1<11+16 ;
se w2 0 ; if buffer claims exceeded
jl. j2. ; then release message buffer extension;
am (b27) ;
rl w1 (+2) ;
rl w3 b28 ;
al w0 x1-2 ;
rx w0 x3+a588 ;
rs w0 x1-2 ;
jl. j2. ;
j1: al w2 1 ; end
j2: rl w3 (b28) ; else buf:= 1; <* no free extensions *>
jl (x3) ; end;
i0: 0<12+12 ; answer descriptor init (open=false,proc='answer_arrived')
e.
\f
; procedure entry cwaitanswer(buf,timer,result);
;
; prepares the message buffer extension for receiving the answer. if
; the buffer has been answered, 'last_event' is reset as the buffer
; may have been skipped during an earlier inspection of the event queue.
; 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 process extension 2 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 in ext2 if result <> timeout
; w2: buf buf
; w3: link current coroutine
b.j10 w.
c105: rs w3 (b27) ; begin
am (b28) ;
rl w3 +a544 ;
sn w3 0 ;
jl. j0. ; if testoutput active
jl. w3 h4. ; then generate_testoutput(1<5);
3<22+1<5 ;
j0: rl w3 (b28) ;
rl w1 (b27) ; current_coroutine.return:= link;
ds w2 x3+a724 ; current_coroutine.buf:= buf;
rs w0 (b27) ; ext1(0):= timer;
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 x2+4 ;
sz w0 -8 ; if buf.state = answer pending
jl. j1. ; then last_event:= 0; <* inspect from start *>
al w0 0 ;
am (b28) ;
rs w0 +a582 ;
j1: rl w0 (b27) ; timer:= ext1(0);
jl. w3 c101. ; wait(timer,result);
rl w2 x3+a724 ; 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 ;
jl. j4. ; else
j2: ; begin <* result = answer arrived *>
rl w3 b28 ; release message buffer extension;
al w0 x1-2 ;
rx w0 x3+a588 ;
rs w0 x1-2 ;
se w2 (x3+a582) ;
jl. j3. ;
al w0 0 ; if buf = last_event then last_event:= 0;
rs w0 x3+a582 ;
j3: al w1 x3+a590 ;
jd 1<11+18 ; wait answer(buf,cur.ext2.answer_area);
j4: rl w3 (b28) ; end;
jl (x3+a722) ; end;
e. ; end;
\f
; procedure entry signal binary(sem);
; procedure entry signal(sem);
;
; call return
; w0: - destroyed
; w1: - destroyed
; w2: sem destroyed
; w3: link current coroutine
b.j5 w.
c107: am 1 ; signal_binary:
c108: al w0 0 ; signal:
am (b28) ; begin
rs w3 (0) ;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput active
jl. j0. ; then generate_testoutput(1<7);
jl. w3 h4. ;
3<22+1<7 ;
j0: rl w1 x2+4 ; with sem do
al w3 x1+1 ; begin
se w0 0 ; count:= count+1;
la w3 0 ; if binary
rs w3 x2+4 ; then count:= count and 1;
sl w1 0 ; if count <= 0 then
jl. j1. ; begin
rl w2 x2 ; corout:= next(sem);
jl. w3 h0. ; remove(corout);
al w2 x2+6 ;
rl w0 x2+a698 ; priority:= corout.prio;
al w1 1 ; result:= ok;
jl. w3 c100. ; start(corout,priority,result);
j1: rl w3 (b28) ; end;
jl (x3) ; end;
e. ; end;
\f
; procedure entry wait_semaphore(sem);
;
; call return
; w0: - destroyed
; w1: - destroyed
; w2: sem destroyed
; w3: link current coroutine
b.j5 w.
c109: am (b28) ; begin
rs w3 (0) ;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput active
jl. j0. ; then generate_testoutput(1<8);
jl. w3 h4. ;
3<22+1<8 ;
j0: rl w1 x2+4 ; with sem do
al w1 x1-1 ; begin
rs w1 x2+4 ; count:= count-1;
rl w3 (b28) ;
sl w1 0 ; if count < 0 then
jl (x3) ; begin
rl w1 x3 ;
rs w1 x3+a722 ; current_coroutine.return:= link;
al w1 x2 ; head:= sem.coroutine_queue_head;
al w2 x3-6 ; elem:= current_coroutine.sem_queue_elem;
jl. w3 h1. ; link(head,elem);
al w0 0 ; timer:= 0 <* no timeout *>
jl. w3 c101. ; wait(timer);
rl w3 (b28) ; end;
jl (x3+a722) ; end with;
e. ; end;
\f
; procedure entry signal_chained(sem,oper);
;
; signals an operation to a chained semaphore. if the coroutine queue of
; the semaphore contains a coroutine which is waiting for an operation
; of this type,the coroutine is started. otherwise the operation is
; queued to the semaphore.
;
; two reserved types exist:
; 1<0: message
; 1<1: answer
;
; call return
; w0: - destroyed
; w1: operation destroyed
; w2: semaphore destroyed
; w3: link current coroutine
b.j10 w.
c110: am (b27) ; begin
rs w3 -2 ;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ;
jl. j0. ; if testoutput active
jl. w3 h4. ; then generate_testoutput(1<9);
3<22+1<9 ;
j0: 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-a694+a708; if logand(corout.mask,oper.type) <> 0 then
la w0 x1+4 ; begin
se w0 0 ;
jl. j3. ; found:= true;
rl w3 x3 ;
jl. j1. ;
j3: rs w1 x3-a694+a724; corout.latop:= operation;
rl w0 x1+4 ; type:= oper.type;
al w2 x3 ;
jl. w3 h0. ; remove(corout);
al w2 x2-a694 ;
rl w1 0 ; result:= type;
rl w0 x2+a698 ; priority:= corout.prio;
jl. w3 c100. ; start(corout,priority,result);
jl. j5. ; end
; else corout:= next(corout);
j4: rx w2 2 ; if -,found
al w1 x1+4 ; then link(sem.operation_queue,oper);
jl. w3 h1. ;
j5: rl w3 (b28) ;
am (b27) ;
jl (-2) ; end;
e.
\f
; procedure entry inspect_chained(sem,mask,oper,result);
;
; checks if 'sem_operation_queue' contains an operation which matches 'mask'.
; if no matching operation is found, 'oper' returns = 0,
; otherwise 'oper' refers to the first matching operation.
; '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 oper or 0
; w2: sem sem
; w3: link current coroutine
b.j10 w.
c111: am (b28) ; begin
rs w3 (0) ;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput active
jl. j0. ; then generate_testoutput(1<10);
jl. w3 h4. ;
3<22+1<10 ;
j0: am (b27) ;
rs w2 +12 ; save(sem);
al w0 x1 ;
rl w1 x2+4 ; head:= sem.operation_queue_head;
j1: ; oper:= next(head); found:= false;
sn w1 x2+4 ; while oper <> head and -,found do
jl. j3. ; if logand(oper.type,mask) <> 0
rl w3 x1+4 ; then found:= true
la w3 0 ; else oper:= next(oper);
se w3 0 ;
jl. j4. ;
rl w1 x1 ;
jl. j1. ;
j3: al w1 0 ; if -,found then oper:= 0;
j4: rl w3 (b28) ;
rl w0 x3+a698 ; priority:= current_coroutine.prio;
rl w2 b28 ;
rl w2 x2+a546 ; corout:= first in active queue;
sh w0 (x2-4) ;
am -1 ;
al w0 1 ; result:= corout.prio > priority;
am (b27) ;
rl w2 +12 ;
jl (x3) ; end;
e.
\f
; procedure entry wait_chained(sem,mask,timer,oper);
;
; if 'sem.operation_queue' contains an operation
; which matches 'mask', the operation 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 operation is found
; pending events are scheduled and the calling coroutine waits for max. 'timer'
; seconds for an operation to arrive.
;
; if the operation contains a message or an answer ('oper.type' = 1<0 or 1<1 ,
; resp ) , the buffer contents is copied to the common message-answer area in
; process extension 2. a buffer containing an answer is removed from the event
; queue by 'waitanswer'.
;
;
; call return
; w0: timer result ( 0(timeout) or oper.type)
; w1: mask oper (undefined if result = timeout)
; w2: sem destr.
; w3: link current_coroutine
b.j10 w.
c112: rs w3 (b27) ; begin
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput active
jl. j0. ; then generate_testoutput(1<11);
jl. w3 h4. ;
3<22+1<11 ;
j0: rx w1 (b27) ;
rl w3 (b28) ;
rs w1 x3+a722 ; current_coroutine.return:= link;
rx w1 (b27) ; current_coroutine.waitch_mask:= mask;
ds w1 x3+a708 ; current_coroutine.timer:= timer;
jl. w3 c111. ; inspect_chained(sem,mask,oper,result);
se w1 0 ; if oper = 0 then
jl. j1. ; begin <* wait in semaphore queue *>
al w1 x2 ; head:= sem.coroutine_queue_head;
al w2 x3+a694 ; elem:= current_coroutine.sem_queue_elem;
jl. w3 h1. ; link(head,elem);
rl w0 x2-a694+a706 ; timer:= current_coroutine.timer;
jl. w3 c101. ; wait(timer,result);
se w0 0 ; if result = timeout then
jl. j3. ; begin
rs w0 x3+a710 ; current_coroutine.result:= timeout;
al w2 x3+a694 ; elem:= current_coroutine.sem_queue_elem;
jl. w3 h0. ; remove(elem);
jl. j6. ; goto exit;
; end;
; end;
j1: rs w1 x3+a724 ; current_coroutine.latop:= oper;
rl w2 x1+4 ;
rs w2 x3+a710 ; current_coroutine.result:= oper.type;
al w2 x1 ;
jl. w3 h0. ; remove(oper);
rl w3 (b28) ; if waiting <* coroutines of higher
sn w0 0 ; priority in active queue *> then
jl. j2. ; begin
rl w0 x3+a698 ; priority:= current_coroutine.prio;
jl. w3 c102. ; pass(priority);
; end;
j2: rl w0 x3+a710 ;
j3: sz w0 -4 ; if oper.type = message or answer then
jl. j6. ; begin
rl w2 x3+a724 ; oper:= current_coroutine.latop;
rl w3 b28 ;
rl w2 x2+8 ; buf:= oper.buf;
se w0 1<1 ; if oper.type = answer then
jl. j5. ; begin
se w2 (x3+a582) ;
jl. j4. ; if buf = last_event
al w0 0 ; then last_event:= 0;
rs w0 x3+a582 ;
j4: al w1 x3+a590 ; area:= common message-answer area;
jd 1<11+18 ; waitanswer(buf,area);
jl. j6. ; end
j5: al w1 x3+a590 ; else
dl w0 x2+10 ; begin <* message *>
ds w0 x1+2 ;
dl w0 x2+14 ;
ds w0 x1+6 ;
dl w0 x2+18 ; <* copy to common massage-answer area *>
ds w0 x1+10 ;
dl w0 x2+22 ;
ds w0 x1+14 ; end;
; end;
j6: rl w3 (b28) ; exit:
rl w0 x3+a710 ; result:= current_coroutine.result;
rl w1 x3+a724 ; oper:= current_coroutine.latop; <* undef if timeout *>
jl (x3+a722) ;
e. ; end;
\f
; procedure entry sem_sendmessage(name,message,oper,sem.result);
;
; sends a massage to the process given by 'name'. when the answer arrives
; it is signalled to the chained semaphore 'sem'. the calling coroutine must
; provide the operation 'oper' which is used as:
;
; 1) message_buffer_extension and 2) answer_operation(sem_answer_proc)
; -6 (next operation) oper +0 next operation
; -4 (prev operation) +2 prev operation
; -2 (type) +4 type=answer(1<1)
; ext. +0 open,'sem_answer_proc' +6 -
; +2 answer_sem +8 buffer address
;
;
; call return
; w0: sem destr.
; w1: params destr.
; w2: oper buffer addres ( or 0 = claims exceeded )
; w3: link 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.
c113: am (b28) ; begin
rs w3 (0) ;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput active
jl. j0. ; then generate_testoutput(1<12);
jl. w3 h4. ;
3<22+1<12 ;
j0: rs w0 (b27) ; with oper.answer_descriptor do
rl. w0 i0. ; begin
rs w0 x2+6 ; proc:= sem_answerproc;
rl w0 (b27) ; open:= true;
rs w0 x2+8 ; answer_sem:= sem;
al w3 x1 ; end;
al w1 x1+10 ; name_address:= params;
; message_address:= params+10;
al w2 x2+6 ; ref:= oper.answer_descriptor;
jd 1<11+16 ; sendmessage(name_addres,message_address,ref,result);
rl w3 (b28) ;
jl (x3) ; end;
i0: 1<12+28 ; answer_descriptor init;
e.
\f
; procedure sem_answer_proc(ref,buf);
;
; this procedure is called from procedure 'check_event_queue' when an
; answer to a message, sent by 'sem_sendmessage, has arrived. 'ref'
; contains the address of the answer_descriptor and 'buf' contains the
; message buffer address. the answer is signalled to the chained semaphore
; given in answer_descriptor.
;
; call return
; w0: - destr.
; w1: ref destr.
; w2: buf buf
; w3: link link
b.j5 w.
c114: am (b27) ; begin
ds w3 +6 ;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput active
jl. j0. ; then generate_testoutput(1<13);
jl. w3 h4. ;
3<22+1<13 ;
j0: al w0 0 ; with ref do
hs w0 x1 ; begin
al w0 1<1 ; open:= false;
rs w0 x1-2 ; type:= answer;
rx w2 x1+2 ; sem:= answer_sem;
al w1 x1-6 ; buffer:= buf;
jl. w3 c110. ; signal_chained(sem,operation);
am (b27) ; end;
dl w3 +6 ;
jl x3 ; end;
e.
\f
; procedure message_received(buf,ref);
;
; this procedure is called from 'check_event_queue' when a message is
; received and mess_descr.proc = 'message_received'. the message descriptor
; must contain an operation and the address of a chained semaphore.
;
; message_descriptor message_operation
; -6: next operation -
; -4: prev operation -
; -2: type type = message (1<0)
; mess_descr +0: open,'message_received' -
; +2: semaphore address buffer address
;
;
; call return
; w0: - destr.
; w1: ref destr.
; w2: buf 0 (the message buffer is removed)
; w3: link link
b.j5 w.
c115: am (b27) ; begin
rs w3 +6 ;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput active
jl. j0. ; then generate_testoutput(1<14);
jl. w3 h4. ;
3<22+1<14 ;
j0: jd 1<11+26 ; getevent(buf);
al w0 0 ; with ref do
hs w0 x1 ; begin
al w0 1<0 ; open:= false; <* the message class must be
; explicitly opened by a
; receiving coroutine *>
rs w0 x1-2 ; oper.type:= message;
rx w2 x1+2 ; oper.buffer:= buf;
al w1 x1-6 ; sem:= message_sem;
jl. w3 c110. ; signal_chained(sem,oper);
am (b27) ; end;
rl w3 +6 ;
al w2 0 ; buf:= 0; <* has been removed *>
jl x3 ; end;
e.
\f
; procedure entry timer_message;
;
; sends a delay-message to 'clock'.
;
; call return
; w0: - unchanged
; w1: - destr.
; w2: - buf or 0
; w3: link current_coroutine
b.j5 w.
c116: am (b27) ; begin
rs w3 +14 ;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput active
jl. j0. ; then generate_testoutput(1<15);
jl. w3 h4. ;
3<22+1<15 ;
j0: rl w3 b28 ;
al w1 x3+a626 ; mess:= cur.ext2.delaymess;
al w2 x3+a630 ; ref:= cur.ext2.answer_descr;
al w3 x3+a616 ; name:= <:clock:>;
jd 1<11+16 ; sendmessage(name,mess,ref,result);
rl w3 (b28) ;
am (b27) ;
rl w1 +14 ;
jl x1 ; end;
e.
\f
; procedure timerscan(ref,buf);
;
; this procedure is called from 'check_event_queue' when an answer arrives
; from 'clock'. 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: link link
b.j5,i5 w.
c117: am (b27) ; begin
rs w3 +16 ; ext1(16):= link;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput active
jl. j0. ; then generate_test_output(1<16);
jl. w3 h4. ;
3<22+1<16 ;
j0: rl w3 b28 ;
al w1 x3+a566 ; <* release messagebuffer *>
jd 1<11+18 ; wait_answer(cur.ext2.test_mess_area,buf);
j4: ;
al w2 x3+a552 ; corout:= first in timer queue;
j1: rl w2 x2 ; while corout <> timer queue head do
j3: sn w2 x3+a552 ; begin
jl. j2. ; corout:= next(corout);
rl w1 x2+4 ; with corout do
sh w1 0 ; begin
jl. j1. ; if timer > 0 then
al w1 x1-1 ; begin
rs w1 x2+4 ;
se w1 0 ; timer:= timer-1;
jl. j1. ; if timer = 0
rl w0 x2 ; then start(corout,prio,timeout);
am (b27) ;
rs w0 +18 ;
al w2 x2-2 ;
rl w0 x2+a698 ; end;
al w1 0 ; end;
jl. w3 c100. ;
am (b27) ;
rl w2 +18 ;
rl w3 b28 ;
jl. j3. ; end while;
j2: jl. w3 c116. ; timer_message;
am (b27) ;
rl w3 +16 ; link:= ext1(16);
al w2 0 ; buf:= 0; <* has been removed *>
jl x3 ; end;
e.
\f
; procedure entry 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: link current_coroutine
b.j5 w.
c118: am (b28) ; begin
rs w3 (0) ;
am (b28) ;
rl w3 +a544 ;
sn w3 0 ; if testoutput active
jl. j0. ; then generate test_output(1<17);
jl. w3 h4. ;
3<22+1<17 ;
j0: jd 1<11+82 ; regretmessage(buf);
rl w1 x2-2 ; ref:= buf.ref;
rl w3 b28 ; ext:= next(message_buffer_ext_head);
al w0 x1-2 ; next(message_buffer_ext_head):= ref;
rx w0 x3+a588 ; next(ref):= ext;
rs w0 x1-2 ;
rl w3 (b28) ;
jl (x3) ; end;
e.
\f
; procedure entry testout
;
;
; this procedure creates a user test record defined by the registers
; as follows:
;
; call return
; w0: testrecord ident unch.
; w1: start address unch.
; w2: no_of_halfwords unch.
; w3: link current coroutine
b.j5 w.
c119: am (b28) ; begin
rs w3 (0) ;
am (b28) ; if test output active then
rl w3 +a544 ;
sn w3 0 ;
jl. j0. ;
jl. w3 h4. ; generate testoutput(1<18)
3<22+1<18;
j0: rl w3 (b28) ;
jl (x3) ; end;
e.
\f
; procedure generate testoutput(testkind);
;
; this procedure creates a testrecord or initiates the creation of a test
; record as follows:
;
; 1) if word 128 in monitor table is set ( <> 0 ) a message defining the
; test record is sent to the coroutine test output process.
;
; 2) otherwise a test record is written in the cyclical test output buffer.
; formats in the cyclical buffer:
;
; user test record coroutine function (signal etc.)
; +0 testkind testkind
; +2 time1 time1
; +4 time2 time2
; +6 user_ident,length w0
; +8 test information w1
; +10 - " - w2
; +12 - " - coroutine ident
; +14 etc. address of current coroutine
;
; testkind values:
; 1<0 : start
; 1<1 : wait
; 1<2 : pass
; 1<3 ; inspect
; 1<4 : csendmessage
; 1<5 : cwaitanswer
; 1<6 : answer_arrived
; 1<7 : signal_sem-signal_binary
; 1<8 : wait_semaphore
; 1<9 : signal_chained
; 1<10 : inspect_chained
; 1<11 : wait_chained
; 1<12 : sem_sendmessage
; 1<13 : sem_answer_proc
; 1<14 : message_received
; 1<15 : timer_message
; 1<16 : timer_scan
; 1<17 : cregretmessage
; 1<18 : user defined testrecord
;
; call return
; w0: - unchanged
; w1: - unchanged
; w2: - unchanged
; w3: link current coroutine
b.j10,i5
w.
h4: am (b27) ; begin
rs w3 +8 ; ext1(8):= link;
rl w3 b27 ;
ds w1 x3+22 ; save working registers
rs w2 x3+24 ;
rl w1 x3+8 ;
rl w3 (b28) ;
rl w0 x3+a716 ; if testkind is included in curr.corout.testm then
la w0 x1 ; begin
sn w0 0 ;
jl. j6. ;
rl w3 b141 ; if core(128) <> 0 then
sn w3 0 ; begin
jl. j1. ;
rl w3 b28 ;
al w1 x3+a566 ;
rs w0 x1 ; cur.ext2.testmess(1):= testkind;
al w3 x3+a556 ;
jd 1<11+16 ; send message(testmes,cmontest);
jd 1<11+18 ; wait answer;
jl. j6. ; else
j1: rl w3 b28 ; begin ! create record in cyclical buffer !
am (b27) ; if testkind = user record
rl w1 +24 ;
se. w0 (i0.) ; then length:= length(user record)
al w1 8 ; else length:= 8;
rl w2 x3+a540 ; if (start(next record)+length+8) >
wa w1 x3+a540 ; top(test buffer) then
al w1 x1+8 ; begin
sh w1 (x3+a542) ;
jl. j2. ;
al w1 0 ; insert dummy end record
rs w1 x2 ;
rl w2 x3+a538 ; start(next record):= start(test buffer);
; end;
j2: rs w0 x2 ; insert testkind in record
rl w3 0 ;
jd 1<11+36 ; get clock
ds w1 x2+4 ; insert time in test record
sn. w3 (i0.) ; if testkind = coroutine function then
jl. j3. ; begin
rl w3 (b28) ;
am (b27) ;
dl w1 +22 ;
ds w1 x2+8 ; insert w0,w1
am (b27) ;
rl w0 +24 ;
rs w0 x2+10 ; insert w2
rl w0 x3+a718 ;
ds w0 x2+14 ; insert coroutine_ident, addr. of curr,corout.
al w2 x2+14 ;
jl. j5. ; end
j3: rl w3 b27 ; else
dl w1 x3+22 ; begin <* user defined test record *>
rl w3 x3+24 ;
hs w0 x2+6 ; insert user identification
hs w3 x2+7 ; insert length
al w2 x2+8 ;
j4: rl w0 x1 ; transfer test information
rs w0 x2 ;
al w3 x3-2 ;
sh w3 0 ;
jl. j5. ;
al w2 x2+2 ;
al w1 x1+2 ;
jl. j4. ; end;
; end;
j5: rl w3 b28 ;
al w2 x2+2 ; update start(next record) in procees ext2
rs w2 x3+a540 ;
j6: rl w3 b27 ;
dl w1 x3+22 ; load working registers
rl w2 x3+24 ;
rl w3 x3+8 ; return:=ext1(8);
jl x3+2 ; end;
i0: +1<18 ; testkind f. user test record
e.
e.
z.
#,
;<*rettelse til errorlog *>
l./g66:/, l./j1:/,
l./rlw1x1+a141/, l1,i/
sh w1 (b3) ; if receiver defined then
jl. j2. ;
/,
l./al w3 32/, r/ /j2: /,
l./h4:/,
l./dlw0/, i/
rs. w2 i8. ; save received buffer
rl w1 b19 ; check for clockchange c.w1=cur receiver
jl. w3 j24. ;
rl. w2 i8. ; restore buffer
/,
l./c35:/, l./rx w0/,
i/
al. w3 j38. ; set continue adr
/,
l./j22:/, r/j22 :/ /, i/
j22 : al. w3 j38. ; prepare continue adr
/,
l./j24:/, i/
; called when a message or an interrupt is received
; called with w1=cur receiver and w3 holding the return adr
/,
l./jl.j38./, r/./ /, r/j38./x3 /,
l1, i/
rs. w3 i9. ; save return adr
/,
l./j36:/, l./b19/, l1, i/
jl. (i9.) ;
/,
l./i6:/, l 1, i/
i8 : 0 ; saved buffer from message received
i9 : 0 ; return adr for j24
/,
f
$disc
;********************
$fpaline
;********************
$host
;********************
l./i0=/, r/01 12/04 27/
l./n4:/, l./n5:/, l./j1/, r/j1/j0/,
l./n11:/, l./+p99/, r/rl/zl/,
l./n22:/, l./p93/, r/p93 /p323/,
l./p91/, r/p91 /p321/,
f
$fpasub
;********************
l./i0=/, r/810112/81 03 25/
;<* ret fejl i mt driver: set state=regretted hvis sender er stoppet*>
l./h118:/, l./q1:/, l./j1:/,
l./u2/, r/u2/u3/, r/testmore/no block/,
f
$tabinit
;********************
$procfnc1
;********************
$procfnc2
;********************
l./i0=/,r/81 01 09/81 04 06/
l./m158:/,l./x2+a50/,i/
rl w0 x1+a30 ;
rs w0 x2+a60 ; mref.pseudo:= save w2(cur)
/,f
$s1
;********************
l./i0=/,
r/810126/81 05 20/
l./c4=/, i/
c16= 2 ; stack depth ( of nested 'reads' )
/,
l./c82=/, r/1760/0760/,
l./c16:c82/, d,
l./; definition of core table entry format:/,
l./c19/, d 2,i/
c22=c18+2 ; segment no in susercat or -1
c19=c22+2 ; kind , name of alternative primary input
c93=c19+10 ; kind , name of alternative primary output
c11=c93+10+2 ; size of coretable entry
/,
l./; definition of a console descr/,
l./c44=/, r/c43+4/c96+10/, i/
c95=c43+4 ; primin : kind , name
c96=c95+10 ; primout: kind , name
/,
l./; meaning of command mask:/,
l./; bit 2:/, r/print/print,date/,
l./; bit 3:/, r/load/load,read,unstack,i,o/,
l./; definition of work area format:/,
l./c90=/, i/
; *** start of part to be saved-restored
/,
l./c65=c57+2/, r/c57/c71/, i/
; *** end of part to be saved-restored
c58=c57+2 ; input stack pointer
c59=c58+2 ; first stack element
; subformat of stack entry:
; name + nta of area
c60=10 ; segment no
c61=c60+2 ; saved last addr
c62=c61+2 ; saved char shift
c63=c62+2 ; saved char addr
c64=c63+2 ; (size of entry)
c71=c16*c64+c59; (top of stack)
c72=c71-c64 ; last stack entry start
c73=c59-c64 ; base of stack
/,
l./d0:/,
l./rl w0 b4;/, d./rl w0 x1;/, i/
am (b4) ;
rl w0 a199<1 ;
/,
l./jl. f1./, d, i/
jl. (i4.) ; goto end line;
/,
l./i3:/, l1, i/
i4: g30 ;
/,
l./; procedure next char/, i/
b. i20, j20 w.
i0: 0 ; saved link
i1: 0 ; saved w3
i2: 0 ; saved w1
i5: h20 ; first of buffer
j0: g3 ; end line: not allowed
j1: g12 ; end line: area unknown
j2: g15 ; end line: area error
j5: e24 ; pointer to: work
j6: e26 ; pointer to: last addr
j7: e28 ; pointer to: char addr
j8: e27 ; pointer to: char shift
j10: e47 ; pointer to: area input mess
j11: e49 ; pointer to: last of buffer
j12: e50 ; pointer to: segment number
j13: e32 ; pointer to: answer
; procedure stack input
; stacks the input pointers and selects the given area for input
;
; call: w2=name, w3=link
; exit: all regs undef
d79: ; stack input:
rs. w3 i0. ; save return;
rl. w1 (j5.) ; w1 := work;
rl w3 x1+c58 ; w3 := stack pointer;
sn w3 x1+c72 ; if stack pointer = last stack entry then
jl. (j0.) ; goto not allowed; (* i.e. stack overflow *)
al w3 x3+c64 ; increase (stack pointer);
rs w3 x1+c58 ;
rl. w1 (j6.) ;
rs w1 x3+c61 ; save last addr in stack entry;
dl. w1 (j7.) ;
ds w1 x3+c63 ; save char shift and char addr in stack entry;
dl w1 x2+2 ; move name to stack entry;
ds w1 x3+2 ;
dl w1 x2+6 ;
ds w1 x3+6 ;
; prepare variables for immediately buffer change
al w0 -1 ;
rs w0 x3+c60 ; segment.stack entry := -1;
rl. w2 i0. ; w2 := return;
jl. d82. ; goto next segment;
; procedure unstack input
; restores the char pointers from the stack, and maybe also the buffer
;
; call: w2=link
; exit: all regs undef
d80: ; unstack input:
rl. w1 (j5.) ; w1 := work;
rl w3 x1+c58 ; w3 := stack pointer;
sn w3 x1+c73 ; if stack pointer = stack base then
jl x2 ; return;
al w0 x3-c64 ;
rs w0 x1+c58 ; decrease (stack pointer);
dl w1 x3+c63 ;
ds. w1 (j7.) ; restore char shift and char addr from stack entry;
rl w1 x3+c61 ;
rs. w1 (j6.) ; restore last addr from stack entry;
jl. d81. ; goto get segment;
; procedure get segment
;
; call: w2 = link
; exit: w1,w2,w3=unch, w0=undef
d81: ; get segment:
am 0-1 ; increment := 0;
; procedure get next segment
;
; call: w2 = link
; exit: w1,w2,w3=unch, w0=undef
d82: ; next segment:
al w0 1 ; increment := 1;
; procedure read segment
;
; call: w0 = increment, w2 = link
; exit: w1,w2,w3=unch, w0=undef
d83: ; read segment:
ds. w3 i1. ; save return, w3;
rs. w1 i2. ; save w1;
rl. w1 (j5.) ; w1 := work;
rl w3 x1+c58 ; w3 := stack pointer;
sn w3 x1+c73 ; if stack pointer = stack base then
jl. i10. ; goto return;
rl. w1 i5. ; w1 := first of buffer;
al w2 x1+510 ; w2 := last of buffer;
ds. w2 (j11.) ;
sn w0 0 ; if increment <> 0 then
jl. i8. ; begin
rs. w2 (j6.) ; last addr := last of buffer;
rs. w1 (j7.) ; char addr := first of buffer;
al w1 -16 ;
rs. w1 (j8.) ; char shift := -16;
i8: ; end;
wa w0 x3+c60 ; segment := segment + increment;
rs w0 x3+c60 ;
rs. w0 (j12.) ;
jd 1<11+92; create entry lock process(area name);
se w0 0 ; if result <> ok then
jl. (j1.) ; goto area unknown;
al. w1 (j10.) ;
jd 1<11+16; send message (area input, area name);
al. w1 (j13.) ;
jd 1<11+18; wait answer(answer area);
rl w1 x1 ;
lo w1 0 ; w1 := status 'or' result;
jd 1<11+64; remove process (area name);
se w1 1 ; if any arror then
jl. (j2.) ; goto area error;
i10: ; return:
rl. w1 i2. ; restore regs;
dl. w3 i1. ;
jl x2 ; return;
e. ;
/,
l./d1:/,
l./al w0 10;/, d./al w2 x2+2;/,
i/
al w1 -16 ; char shift := -16;
al w2 x2+2 ; char addr := char addr + 2;
sh. w2 (e26.) ; if char addr > last addr then
jl. i0. ; begin
al w0 10 ; char := newline;
rl. w1 e24. ;
rl w2 x1+c58 ;
sn w2 x1+c73 ; if stack pointer = stack base then
jl. i1. ; goto classify char; (* i.e. not end of area-read-buffer *)
jl. w2 d82. ; get next segm;
jl. d1. ; goto next char;
; end;
/,
l./i1:/, d, i/
ds. w2 e28. ;
i1: ; classify char:
/,
l./se w1 5;/, d./z. jl x3+0;/, i/
jl x3 ; end;
/,
l./d2:/,
l./al w0 0;/, d1, i/
al w1 0 ;
se. w1 (e87.) ; if areabuf undef then
jl. w2 d81. ; get segment;
rs. w1 e87. ; areabuf := defined;
al w0 0 ; param type := 0;
/,
l./d3:/,
l./ld w2 -2;/, i/
al w2 0 ;
/,
l./d7:/, d, i/
d11: ; newline or semicolon:
sn w0 10 ;
jl. d8. ; while char <> newline do
jl. w3 d1. ; next char;
jl. d11. ; goto delimiter;
d7: ; unknown:
sn w0 25 ; if char = em then
jl. w2 d80. ; unstack input;
al w2 3 ;
/,
l./d22:/,
l./; procedure typeline(buf)/,
l./b.i24/, i/
; procedure send buf (mess, buf)
; (as typeline, but at call: w1=mess)
/,
l./d23:/, d, i/
w.
d23: ; type line:
al. w1 e44. ; mess := output message;
d26: ; send buf:
rs. w3 e60. ;
/,
l./dl w1 x2+a11+2;/, g3/w1/w0/,
l./al. w1 e44./, d,
l./d31:/, l./+12/, r/+12/c22/,
l./d35:/, l./i25:/, l./jl. w3 d30./,
r/;/; reserve core/, l1,
d 2, i/
al w3 x1+c95 ; move kind,name of primin
al w2 x2+c19 ; and primout to coretable
j0 : rl w0 x3 ; (set by i and o commands )
rs w0 x2 ;
al w3 x3+2 ;
al w2 x2+2 ;
se w3 x1+c44 ;
jl. j0. ;
/,
l./i10:/, d,
l./i8:/, d./i23:/, i/
; transfer claims to child,
; the claimlist in the console-description
i8: ; not 'all' bs (console):
rl. w3 e25. ; w3 := claimbase := console;
i13: ; next chaintable:
rs. w3 i22. ; save claimbase;
dl w1 x3+c44+6 ; perm claim := claimlist(claimbase);
ds. w1 i24. ;
wa w0 x3+c44+0 ; temp entries := temp+perm entry claim;
wa w1 x3+c44+2 ; temp segms := temp+perm segm claim;
rs. w0 i23. ; main entries := temp entries;
al w0 0 ; temp entries := 0;
ws. w3 e25. ; w3 := index in claimlist;
ls w3 -2 ;
wa w3 b22 ; w3 := chain table number;
sl w3 (b24) ; if all chains handled then
jl. (i2.) ; return;
rl w3 x3 ; w3 := chain table addr;
al. w2 g20. ; error addr := claims exceeded;
i14: ; transfer claim:
; w0=temp entries, w1=temp segments
; w2=error address
; w3=chaintable address
rs. w2 i20. ; save(error addr);
al w2 0 ; key := 0;
i15: ; next key:
ds. w1 x2+e52. ; claim(key) := entries,segments;
al w2 x2+4 ; increase(key);
sn w2 a109*4 ; if key = min aux key then
dl. w1 i24. ; entries,segments := perm claim;
sh w2 a110*4 ; if key <= max cat key then
jl. i15. ; goto next key;
dl w1 x3-a88+18 ; name := docname.chaintable;
ds. w1 e21. ;
dl w1 x3-a88+22 ;
ds. w1 e23. ;
rl. w3 e25. ; w3 := proc name;
al w3 x3+c29 ;
al. w2 e20. ; w2 := docname;
al. w1 e51. ; w1 := claim;
jd 1<11+78; set bs claim;
sn w0 0 ; if result = ok then
jl. i16. ; goto maincat entries;
se w0 1 ; if result <> claims exceeded then
jl. i17. ; goto next entry;
al w0 1 ;
hs. w0 e81. ; fiddle with remove indicator...
jl. w3 d40. ; remove child;
jl. (i20.) ; goto error;
i16: ; maincat entries:
ld w1 -100 ; perm claim := 0,0;
ds. w1 i24. ;
rx. w0 i23. ; w0 := main entries; main entries := 0;
rl w3 b25 ; w3 := main catalog chain table;
al. w2 g25. ; w2 := error addr := no maincat entries;
se w0 0 ; if main entries <> 0 then
jl. i14. ; goto transfer claim;
i17: ; next entry:
rl. w3 i22. ; increase (claimbase);
al w3 x3+8 ;
jl. i13. ; goto next chaintable;
i20: 0 ; error addr
i22: 0 ; claimbase
i23: 0 ; main entries;
i24=k+2, 0,0 ; perm claim (entries, segments)
/,
l./d36:/,
l./jl. w3 d25./, r/ole,/ole,coretableelement,/,
l./al. w1 e61./, i/
; override these default w0 and w2 assignments,
; in case of user-defined primary input (or -output) names
al w1 x3+c19 ; w1 := addr of primary input descr;
rl w0 x1+2 ;
se w0 0 ; if name defined then
rs. w1 e61. ; child w0 := primary input descr;
al w1 x3+c93 ; w1 := addr of primary output descr;
rl w0 x1+2 ;
se w0 0 ; if name defined then
rs. w1 e63. ; child w2 := primary output descr;
/,
l./d37:/,
l1 ,i/
rl. w1 e29. ; if state.process <> wait start
zl w1 x1+a13 ; then goto error
so w1 2.100000 ;
jl. g3. ;
/,
l./1<11+52/, l1, i/
al. w3 i1. ; prevent remove of process
/,
l./e51./, i/
al. w3 e40. ;
/,
l./1<11+16/, l-1, d,
l./w3/, r/w3/w1/,
l./rs. w3 (i19.)/, r/i19/e12/,
r/w3/w1/,
l./i12:/, i/
i9: am 2 ;
i10: am 2 ;
i11: am 2 ;
/,
l./i14:/, g 1/w3/w2/,
l./al.w3 e40/, d,
l./;dont/, d./jl. i15./,
l./i19:/, d, i/
i3 : 2.100000 ; state bit : wait for stop or start
/,
l./d41:/, d./jl. i0./, i/
w.
d41: ; find work:
rl. w1 e13. ; work := first work;
i0: ; loop:
rs. w1 e24. ;
sn w2 (x1+c50) ; if state(work) = state then
jl x3 ; return;
al w1 x1+c2 ; increase(work);
sh. w1 (e14.) ; if work <= last work then
jl. i0. ; goto loop;
jl. g31. ; goto exam next; <* not expecting this answer *>
/,
l./d42:/,
l./ds w3 x1+c51/, l1, i/
rs. w2 e88. ; expected answer := state;
/,
l./; procedure restore work/,
l./; w0 destroyed/, r/destroyed/logical status/,
l./; w1 work/, r/work/ /,
l./d43:/,
r/rs./rl./,
l./i0:/, i/
rs. w2 e87. ; areabuf := undef;
/,
l./rl. w3 e59./, g1/w3/w0/,
l./d45:/,
l./;procedure set_zero/, d./i3:/, i/
; procedure clear claimlist
; comment sets zeroes in whole claimlist of console descr
;
; call: w3 = link
; exit: all regs undef
b. i10 w.
d46: ; clear claimlist:
rl. w1 e25. ; w1 := console;
al w2 x1+c48-c44+2; w2 := rel top of claimlist;
al w0 0 ;
i0: ; rep:
al w2 x2-2 ; decrease(pointer);
sl w1 x2 ; if pointer <= start of console then
jl x3 ; return;
rs w0 x2+c44 ; claimlist(pointer) := 0;
jl. i0. ; goto rep;
/,
l./d61:/,
l./j1:/, g2/w1/w3/, l-1, r/x1/x3/,
l2, r/rl/wa/,
l1, d,
r/al w3 x3/ /,
l./d71:/,
l./e.z.jl. g18/, r/ jl.g18.//,
l./d78:/,
l./i1:/, l./shw1/, r/h/l/, r/1/3/, r/x3/x1/,
l./; parameter table:/,
l./i6=/, l1, i/
i9=(:d11-d2:)<2+0
/,
l./h1:/,
l./i6,i7/, r/i7/i9/, r/delimit0/endline/,
l./i7,i7/, r/,i7/, i9/, r/,delimit0/, endline/,
l./i7,i7/, r/,i7/, i9/, r/,delimit0/, endline/,
l./d25=k-2/, l1, i/
jl. d26. ;
d26=k-2
/,
l./d35=k-2/, l1, i/
jl. d36.
d36=k-2
jl. d38.
d38=k-2
/,
l./f1: jl. g30./, d,
i/
jl. d79. ;
d79=k-2
/,
f
$s2
;********************
l./i0=/,
r/810112/81 05 05/
l./e8:/, i/
e12:h3 ; <top command table>
/,
l./e24:h8/, r/>/> ( initially: first work )/,
l1, i/
; *** the following variables must match part of work-area
/,
l./e25:/, r/0 /h21/, r/>/> ( initially: first console )/,
l./e27:/, r/0/8/, r/>/> (initially: prepared for empty char buf)/,
l./e30:/, l1, i/
; *** end of work-area match
/,
l./e39:/, i/
e88:0 ; expected answer
e89:0 ; executing reentrant code: 0=false, -1=true (initially = false)
/,
l./e50:/, l1, i/
e87: 0 ; areabuf state: 0=defined, else undef (initially defined)
/,
l./g1:/, l1, d, i/
g48=k+4
<:ready **date not initialized <0>:> ; text until date initialized
/,
l./g2:/,
l./<:syntax error/, r/error/error:/,
l./g27:/, l1, r/<:ille/<:ille/,
l./g28:/, i/
g47: jl. w1 g28. ;
<:input aborted<0>:>
/,
l./g28:/,
l./g2./, i/
se w3 (b13) ; if clock initialized then
rs. w3 g48. ; remove warning
/,
l./al w3 -1;/, l1, i/
rs. w3 e89. ; executing reentrant code := true;
/,
l./al w0 58;/, d1,
l./g46:/,
l./al w1 0; reset remove list/,
d./rs. w1 e33./,
l./g30:/, l1, i/
rs. w2 e81. ; reset remove list indicator
/,
l./g32:/,
l./sn w0 0;/, i/
sz. w2 (e89.) ; if executing non-reentrant code
jl. g41. ; and
se. w2 (e88.) ; event <> expected answer then
jl. g32. ; goto exam next;
g41: ;
/,
l./al. w1 e51./, i/
jl. w3 d41. ; find work(event,old work);
/,
l1, l./jl. w3 d41./, d1,
l./g34:/,
l./dl w0 x1+4/, d3,
l./rs. w1 e24./, d, i/
al w0 x1+c73 ; input stack pointer := stack base;
rs w0 x1+c58 ;
g39: ; end;
/,
l./al w2 x2-2/, d./al. w3 e40./,
l./jd 1<11+16/, d, i/
jl. w3 d26. ; send buf (input mess, buf);
/,
l./jl. g2./, r/g2. /g47./,
l./rl. w2 e52./, d./ds. w3 e27./, i/
al w2 x1+c66-2 ; char shift := > 0; (* i.e. change word *)
ds. w2 e28. ; char addr := work + linebuf - 2;
wa. w2 e52. ;
rs. w2 e26. ; last addr := char addr + bytes;
/,
l./g36:/,
l1, r/g1/g98/,
l./rl. w3 e7./, i/
jl. w3 d19. ; init write;
al w3 -1 ;
rs. w3 e89. ; executing reentrant code := true;
/,
l./g45:/, d, i/
; init write has been called
/,
l./g38:/,
l./jl. g2./, l1, i/
; all commands, not contained in primary part of command table, are
; considered non-reentrant
al w3 0 ;
rs. w3 e89. ; executing reentrant code := false;
/,
l./g50:/, i/
g98: rl. w1 e24. ; if stack=stackbase then
rl w2 x1+c58 ; goto endline else
sn w2 x1+c73 ; goto next command
jl. g1. ;
jl. g35. ;
/,
l./jl. w3 d41./, l1, d,
l./g42:/,
l./jl.w3 d42./, d./jl.g30./ , i/
rs. w2 e23.+2 ; clear function
zl. w1 e32.+1 ; if stop bit on then
so w1 8.200 ; begin
jl. g97. ;
zl. w1 e32. ; save function
rs. w1 e23.+2 ;
se w1 10 ; if function = replace then
jl. g97. ; save areaname
rl. w3 e24. ; save name in input buffer
al w3 x3+c66 ;
dl. w1 e32.+10 ;
ds w1 x3+2 ;
dl. w1 e32.+14 ;
ds w1 x3+6 ; end
dl. w1 e26. ; simulate empty input string
ds. w1 e28. ; ( after unstack command)
g97: jl. w3 d42. ; save work
am 0 ; +2 error (dont care)
rl. w3 e23.+2 ; if function =finis or replace then
se w3 10 ;
sn w3 2 ;
sz ;
jl. g30. ;
jl. w3 d76. ; adjust bs claim
jl. w3 d40. ; remove process
rl. w3 e23.+2 ; if function =replace then
se w3 10 ;
jl. g30. ;
rl. w2 e24. ; stack input and
al w2 x2+c66 ;
jl. w3 d79. ; goto next command
jl. g35. ;
/,
l./b.i30w.;new:/, i/
g45: ; base for command-relatives
; define pseudo-entries for conditinally-assembled commands
g70: ; break
g72: ; include
g73: ; exclude
g74: ; call
g75: ; list
g76: ; max
g77: ; replace
g83: ; all
g89: ; job
g90: ; print
g91: ; modify
jl. g18. ; goto not implemented;
; command syntax: read <area name>
g57: ; read:
jl. w3 d15. ; next name;
al. w2 e20. ;
am -2048 ;
jl. w3 d79.+2048; stack input (name);
jl. g35. ; goto next command;
; command syntax: unstack
g58: ; unstack:
am -2048 ;
jl. w2 d80.+2048; unstack input;
jl. g35. ; goto next command;
; command syntax: date <year> <month> <date> <hour> <min> <sec>
b. i20, j30 w. ;
j0: ; minimum values:
81 , 1 , 1 , 0 , 0 , 0
j1: ; top values:
99+1, 12+1, 31+1, 23+1, 59+1, 59+1
j2: ; year,month,day,hour,min,sec
0 , 0 , 0 , 0 , 0 , 0
j5: ; month table: jan, ..., dec
h. 365, 396, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334
w.
j11: 4 ; minutes per four minutes
j13: 24 ; hours per day
j14: 60 ; minutes per hour
j17: 365*3+366 ; days per four years (inclusive leap year)
j18: 10000 ; units per second
j20: 60*4 * 10000 ; units per four minutes
j30: <:oldcat:> ; name of successor-command
g49: ; date:
al w1 0 ; for i := 0 step 2 until 10 do
i0: ; begin
jl. w3 d16. ; next integer;
sl. w0 (x1+j0.) ; if number < min value
sl. w0 (x1+j1.) ; or number >= top value then
jl. g2. ; goto syntax error; (* i.e. illegal date *)
rs. w0 x1+j2. ; save number;
al w1 x1+2 ;
se w1 12 ;
jl. i0. ; end;
dl. w2 j2.+2 ; w1 := year; w2 := month;
sh w2 2 ; if month > february then
al w1 x1-1 ; year := year - 1;
al w1 x1-68 ; days := (year - 68)
wm. w1 j17. ; * days in four years
as w1 -2 ; æ47æ 4
ba. w1 x2+j5.-1 ; + month table (month)
wa. w1 j2.+4 ; + day;
wm. w1 j13. ; w1 := hours := days * 24
wa. w1 j2.+6 ; + hour;
al w2 0 ; w2w3 := min;
rl. w3 j2.+8 ;
wm. w1 j14. ; w0w1 := minutes := hours * 60
aa w1 6 ; + min;
wd. w1 j11. ; w1 := fourmin := minutes æ47æ 4;
wm. w0 j14. ; seconds := minutes mod 4 * 60
wa. w0 j2.+10 ; + sec;
wm. w0 j18. ; msec := seconds * 10000;
rl w3 0 ; (w2=0) w3 := msec;
wm. w1 j20. ; clock := fourmin * 2400000
aa w1 6 ; + msec;
jd 1<11+38; set clock (clock);
dl. w1 j30.+2 ; name := successor command name;
ds. w1 e21. ;
al w0 1 ; type := 1; <* i.e. pretend that 'oldcat' has been read *>
sl w0 (b25) ; if maincat not defined yet then
jl. g36. ; goto next command; <* i.e. interpret 'oldcat' *>
jl. g35. ; goto next command;
e. ;
/,
l./g51:/,
l./rl. w3 e25.;/, d./al w2 x3+c1-2/, r/;/; clear claimlist;/,
l./jl. g16.;sorry goto end line/,
l./rl. w3 e25.;/, d./al w1 x1+4;/, d./ds w0 x1 ;/, i/
wa. w2 e25. ;
dl. w0 i6. ; perm claim(work device) :=
ds w0 x2+c44+6 ; standard segment,entries;
/,
l./jl. g52./, i/
al w0 0 ;
rs w0 x1+c95+2 ; clear primary input name;
rs w0 x1+c96+2 ; clear primary output name;
/,
l./i11:0/, d-1,
l./g83:/, d, l1, i/
g83 = k ; all:
/,
l./c.-4000/,
l./hs w0 x1+c26;/,
l./rl.w1 e25.;/, d./al w1 x1+c44;/, r/;/; clear claimlist;/,
l./e. jl. g18.; goto endline/, d, i/
e.
/,
l./g52:/, i/
b. j5 w.
g94: am c95-c96 ; i:
g95: al w1 x1+c96+2 ; o:
jl. w3 d16. ; get kind
rs w0 x1-2 ;
jl. j1. ; continue with get name
/,
l./jl. w3 d15./, r/ / j1: /,
l./j2:/, l1, i/
e.
/,
l./g70:/, d, l1, i/
g70 = k ; break:
/,
l1, r/w./ /,
l./jl. g18./, d, i/
z.
/,
l./g72:/, d1, l1, i/
g72 = k ; include:
am 2 ;
g73 = k ; exclude:
/,
l./al w0 0; dummy instr/, d,
l1, d1,
l./g74:/, d, l1, i/
g74 = k ; call:
/,
l./jl. g18./, d, i/
e.
z.
/,
l./g75:/, d, l./b.i24/, r/24 /24 w./, l1, i/
i7: <: error <0>:>
i8: <: stop <0>:>
i9: <: run <0>:>
i10: <: wait <0>:>
g75 = k ; list:
/,
l./w. rl w2 b6/, r/w./ /,
l./al w1 x1 -12;/, r/al/ac/,
l1, d,
l./zl w1 x2+a13;/, d./i11:/, i/
bl w0 x2+a13 ; w0 := process state;
al. w1 i7. ;
sz w0 2.10000000;
al. w1 i10. ;
sz w0 2.00100000;
al. w1 i8. ;
sz w0 2.01000000;
al. w1 i9. ;
jl. w3 d21. ; writetext(process state);
rl w1 x2+a34 ;
/,
l./jl. g2.;/, r/g2. /g47./,
l1, d,
l./jl. g35./, d./<: wait /,
l./jl. g18./, d, i/
e.
z.
/,
l./g76:/, d, l1, i/
g76 = k ; max:
/,
l./w.jl.w3 d19./, d, i/
w.
/,
l./i0:/,
l./jl. g2.;/, r/g2. /g47./,
l./jl. g18./, d, i/
e.
z.
/,
l./g77:/, d, i/
/,
l./b.i24/, i/
g77 = k ; replace:
/,
l./rl w3 66/, r/66/b1/,
l./i13:;/, d./i4:/, i/
i2: am g13-g11;
i3: am g11-g12;
i4: am g12-g14;
/,
l./i21:/, d,
l./i23:/, d1, i/
e.
z.
/,
l./; stepping stone/,
l./jl.d16./, i/
jl. d15., d15=k-2
/,
l./d34./, i/
jl. g27., g27=k-2
/,
l./jl. d61./, i/
jl. d46., d46=k-2
/,
l./d78=k-2/, l1, i/
/,
l./g79:/,
l./jd 1<11+52/, l1, i/
al. w3 i1. ; (prevent remove process(name))
/,
l./jd 1<11+8;/, i/
al. w3 e20. ;
/,
l./g86:/, d3, i/
; command syntax: user <lower> <upper>
; command syntax: login <lower> <upper>
; command syntax: project <lower> <upper>
g86: am c43-c42; user: update userbase;
g82: am c42-c41; login: update loginbase;
g80: al w2 x1+c41 ; project: update projectbase;
/,
l./rs. w0 i3./, d, i/
rs w0 x2+0 ; lower := integer;
/,
l./i0:/, d-1, i/
rs w0 x2+2 ; upper := integer;
/,
l./i1:/, d2,
l./i3:/, d,
l./g81:/,
l./al.w1e66.-2/, r/e66.-2;/e51.+a110*4;/,
l./g84:/, d, i/
; command syntax: temp <docname> <segments> <entries>
g84: ; temp:
am c45-c47; (update temp claims)
; command syntax: perm <docname> <segments> <entries>
g85: ; perm:
al w3 c47 ; (update perm claims)
wa. w3 e25. ;
rs. w3 i6. ; save abs addr of claim;
/,
l./rl. w3 e25./, d2, i/
am. (i6.) ; update segments and entries;
ds w1 x2 ;
/,
l./g85:/, d./jl.g35./,
l./i5:0/, l1, i/
i6: 0 ; abs addr of claim (in console descr)
/,
l./g89:/, d, i/
w.
/,
l./rl. w1 e25./, i/
g96 = k ; get:
am -1 ;
g89 = k ; job:
al w0 0 ; set startflag
rs. w0 i16. ;
al w3 0 ;
rs w3 x1+c95+2 ; clear primin and primout
rs w3 x1+c96+2 ;
/,
l./rl. w1 e25./, d./jl. w3 d46./, i/
jl. w3 d46. ; clear claimlist;
/,
l./rs. w1 i16./, d,
l./al w3 510;/, d1, i/
al w3 x2-510 ; w3 := last used in segment;
/,
l./j8:/,
r/e21. /(i6.)/,
l1, r/e23. /(i7.)/,
l./sh w1 -1/, d1,
l./e79./, g 9/e79. /(i5.)/,
l./j4:/, l./e25/, r/e25. /(i3.)/,
l./j5:/, l./c44/, r/c44/c95/, r/;/; (until i and o are defined in susercat)/,
l./j2:/, d 1, i/
j2: ;
rl. w1 (i3.) ; restore console
al w2 -1 ; areabuf := undef;
rs. w2 (i4.) ;
sn. w2 (i16.) ; if only load then
jl. g35. ; goto next command;
/,
l./i10:/, i/
i3: e25
i4: e87
i5: e79
i6: e21
i7: e23
/,
l./i16:/, r/entry0/job/, r/getentry0/job command/,
l./jl. g18./, d,
l./g87:/,
d./i1:/, i/
w.
g87: am 1<8 ; lock: lock := true;
g88: al w0 0 ; unlock:lock := false;
rs. w0 (i0.) ;
jl. g35. ; goto next command;
i0: e80 ; lock indicator
/,
l./;print:/, r/;print:/;/, i/
c. (:c23>15a.1:)-1/,
l./g91:/, d1, i/
g91 = k ; modify:
/,
l./g90:/, d-1,d, i/
g90 = k ; print:
/,
l./i26:/,
l./am -2046/, d1, i/
z.
e.
/,
l./g93:/,
l./sl w0 -1/, d1, i/
sz. w0 (i1.) ; if prio < 0 or prio >= 4096 then
/,
l./jl. g35.;/, l./i1:1<12/, r/1<12/-1<12/, l1, i/
e.
/,
l./d76:/,
l./rl.w1 e25/, r/e25/e29/, r/console/child/,
l 1, r/c29/a11/,
l./j6:/,
l./jl. (i10.)/, i/
am -2048 ;
rs. w3 e87.+2048; areabuf := undef;
/,
l./h0:/,
l./; can em sub/, r/8.77/8.76/,
l./w.h2=/,
l./:dump:/, i/
<:date:> , 1<21+1<14+g49-g45
/,
l./:functi:/, i/
<:i:>,0 , 1<20+g94-g45
/,
l./list/, i/
<:get<0>:> , 1<20+g96-g45
/,
l./:perm:/, i/
<:o:>,0 , 1<20+g95-g45
/,
l./:remove:/, i/
<:read:> , 1<20+1<14+g57-g45
/,
l./:user:/, i/
<:unstac:> , 1<20+1<14+g58-g45
/,
l./b110 = g45/, d./g77=g18/, i/
b110 = g45 ; command base
b112 = d2 ; call next param
b113 = d15 ; call next name
b114 = d16 ; call next integer
b115 = g2 ; goto syntax error
b116 = g35 ; goto next command
b117 = g36 ; goto exam command
b118 = e19 ; integer just read
b119 = e20 ; name just read
b120 = e8 ; pointer to: last of init code
b121 = d19 ; call init write
b122 = d20 ; call write char
b123 = d21 ; call write text
b124 = d23 ; call type line
b125 = d42 ; call save work
b126 = g47 ; goto input aborted
b129 = g11 ; goto catalog error
b130 = d79 ; call stack input
/,
l./h10:;/, d, i/
h10 = k - c11 ; base of core table:
/,
l./i0:/, r/h10 /h10+c11/,
l./i1:/, r/h10. /h10.+c11/,
l./se. w2 i0./, r/i0. /h11./,
l./g39 ; addr of after initcat/, d1,
i/
/,
l./h12:/,
l./i10:/, l1, i/
; initialize work table
b. j1 w.
al. w3 h8. ;
j0: ; rep:
al w1 x3+c73 ; for all work table entries do
rs w1 x3+c58 ; stack pointer := stack base;
al w3 x3+c2 ;
sh. w3 h9. ;
jl. j0. ;
e. ;
/,
l./b.j1/, r/j1/j3/,
l./h21/, r/h21. /(j2.)/,
l./j0:/, r/c18/c25/, l./c18/, r/c18/c25/,
l./h5/, r/h5. /(j3.)/,
l./e./, i/
jl. i9.
j2: h21
j3: h5
/,
l./rl w1 (b6)/, r/ / i9: /,
l./rs w0 x1+a18; top address(s) :=/, i/
rs. w0 (4) ; top core :=
jl. 4 ;
e17 ;/,
f
$catinit
;********************
l./i0=/,
r/801124/81 04 06/
l./s.k=k/, r/f40/f50/,
l./e5:/, g 2/:>/<0>:>/,
l./initialize date/, r/::/using the date command <10> :/,
l./;procedure typechar(char)/,
d./f0:/,
d./f1:/,
d./f2:/,
d./f4:/,
d./i1:/,
d./e.;end/,
i/
; procedure type newline
; outputs a newline char on the console
;
; call: w3 = link
; exit: w0 = undef, w1,w2,w3 = unch
f3: ; type newline:
al w0 10 ; char := newline;
; continue with type char;
; procedure type char
; outputs the given char on the console
; (if the char is <newline>, the buffer is sent)
; ***** note: return inf etc are not saved for reentrant use of this code!!!
;
; call: w0 = char, w3 = link;
; exit: all regs unch
f0: ; type char:
b. i24 w.
ds. w2 i0. ; save regs;
ds. w0 i1. ;
rl w2 0 ;
i10: ; put char: (w0 = w2 = char)
jl. w3 f42. ; write char (char);
se w2 10 ; if char = newline then
jl. i15. ; begin
jl. w3 f44. ; type line (buf);
jl. w3 f45. ; save work (buf);
am ;+2: error: (continue)
; (maybe status-errors ougth to repeat a couple of times ???)
jl. w3 f41. ; init write;
i15: ; end;
dl. w2 i0. ; restore regs;
dl. w0 i1. ;
jl x3 ; return;
; procedure typetextline (text);
; outputs the text on the console, terminated by a newline char
; call: w1=text addr, w3=link
; exit: w0,w1,w3=unch, w2 = undef
f2: ; typetextline:
am 10-32 ; char := newline;
; continue with typeout;
; procedure typetext (text);
; outputs the text on the console, terminated by a space
; call: w1=text addr, w3=link
; exit: w0,w1,w3=unch, w2=undef
f1: ; typetext:
al w2 32 ; char := space;
ds. w2 i0. ; save regs;
ds. w0 i1. ;
jl. w3 f43. ; writetext (text);
al w0 x2 ;
jl. i10. ; goto put char
i0=k+2, 0, 0 ; saved w1,w2
i1=k+2, 0, 0 ; saved w3,w0
e. ;
/,
l./f5:/,
l./al w2 x1+6;/, d,
l./al. w2 e6./, d,
l./i0:/, d1, i/
i0: ; end with newline:
jl. w3 f3. ; type newline;
/,
l./f6:/,
l./al w2 x1+6/, d,
l./al. w2 e8./, d,
l./jl. i0./, r/;/; goto end with newline;/,
l./f8:/,
l./i2:/,
l./al. w2 e10./, d./jl.w3 f0./, i/
jl. w3 f2. ; type textline (<:input sumerror:>);
/,
l./f22:/,
l./i20:/,
l./al w2 x1-2;/, d./jl. i21.;/,
l./; procedure insert all entries/,
l./j7=k-2/, d,
l./j9=k-2/, d,
l./j11=k-2/, d,
g-3/:>/<0>:>/,
l./i20: ; error at output catsegment:/,
l./al. w2 j7./, d./jl.w3 f0./, i/
jl. w3 f2. ; type textline (<:repair not possible:>);
/,
l./i21:/,
l./al. w2 j9./, d./jl. w3 f0./, i/
jl. w3 f2. ; type textline (<:update of entry count not possible:>);
/,
l./i25:/,
l./al. w2 j11./, d1, i/
jl. w3 f1. ; typetext (<:insert entry:>);
/,
l./d38:/, i/
d49: 0, r.4 ; initcat switches: automatic startup area name
/,
l./e0:/, d, i/
/,
l./e9:/, r/,e10=k-2//,
l./e11:/, r/,e12=k-2//,
l./e13:/, r/,e14=k-2//,
l./e15:/, d,
l./e17:/, d,
g-3/:>/<0>:>/,
l./jl.f4.,f4=k-2/, d,
i/
jl. f2. , f2 = k-2
/,
l./; procedure dismount kit/,
l./j6=k-2/, d,
l./j8=k-2/, d,
g-2/:>/<0>:>/,
l./i10:/,
l./al. w1 j5./, d./jl. i15./, i/
am j5-j7 ; text := <:delete bs:>
/,
l./al. w1 j7./, d, r/w2 j8./w1 j7./,
l./; procedure mount main catalog/,
l./j4=k-2/, d,
l./j6=k-2/, d,
l./j8=k-2/, d,
l./j10=k-2/, d,
l./j12=k-2/, d,
g-5/:>/<0>:>/,
l./i15:/,
l./al. w1 j3./, d1, i/
am j3-j5 ; text := <:remove aux entry:>;
i17: ; error at connect main catalog:
am j5-j9 ; text := <:connect main catalog:>;
i19: ; error at create main catalog:
al. w1 j9. ; text := <:create aux entry:>;
/,
l./i17:/, d./jl.i16.;/,
l./i18:/,
l./al. w1 j7./, d, r/w2 j8./w1 j7./,
r/out/ textline/,
l./jl. w3 f1./, d./i19:/, d./jl. i16./, i/
jl. w3 f2. ;
/,
l./i20:/,
l./al. w1 j11./, d, r/w2 j12/w1 j11/, r/out/ textline/,
l1, r/f1./f2./,
l./al w0 10/, d1,
l./f35:/, l1, i/
f41: jl. (2),b121; call init write;
f42: jl. (2),b122; call write char;
f43: jl. (2),b123; call write text;
f44: jl. (2),b124; call type line;
f45: jl. (2),b125; call save work;
f46: jl. (2),b126; goto command aborted;
f47: jl. (2),b129; goto catalog error;
f48: jl. (2),b130; call stack input;
/,
l./f40:/,
l./rs. w3 j0./, d./j2=k-2/, i/
jl. w1 f2. ; type textline... and return;
<:auxcat to be repaired<0>:>
/,
l./; error in init/,
d./e. ;end of scatinit;/, i/
æ12æ
; *********************************************
; *********************************************
; ** **
; ** main control of monitor initialization **
; ** **
; *********************************************
; *********************************************
b. i10 w.
i0: f19 ; autoload device controllers
i1: f20 ; start up device controllers
g0: ; init catalog:
jl. w3 f41. ; init write;
rl. w0 d36. ;
se w0 0 ; if discload then
jl. w3 (i0.) ; autoload device controllers;
jl. w3 (i1.) ; start up device controller;
rl. w0 d36. ; w0 := discload flag;
rl. w1 d49. ; w1 := first word of startup area name;
se w0 0 ; if not discload
sn w1 0 ; or area name <> 0 then
jl. i2. ; goto write start header;
; automatic startup is demanded
jl. w3 g11. ; call (automatic oldcat);
al. w2 d49. ; name := startup area name;
jl. w3 f48. ; stack input (name);
jl. f31. ; goto next command;
i2: am (b4) ; get name of console 2
rl w2 +a199<1 ;
dl w1 x2+4 ;
ds. w1 e1.+2 ;
dl w1 x2+8 ;
ds. w1 e1.+6 ;
al. w3 e1. ; send output message
al. w1 i3. ;
jd 1<11+16 ;
jd 1<11+18 ; wait answer dont care about the answer and dont check
jl. f31. ;
i3: 5<12, e19 , e20
0, r.5 ; eight words for answer
e. ;
; ************************************************
; ************************************************
æ12æ
/,
l./g43:/,
l./i5:/,
l./dl w1 x3+d61+2/, r/text/textline/,
l./al. w2 j5./, d,
r/f1/f2/,
l./al w0 10/, d1,
l./jl. g10./, r/g10/f47/,
l./i8:/,
l./jl. w3 f5./,
l1, r/:>/<0>:>/,
l./j5=k-2/, r/j5=k-2/ 0 /,
l./g49:/,
l./i3:/,
l./al. w2 j6./, d,
l./jl. w3 i3./, r/w3/ /,
l./j6=k-2/, d,
g-1/:>/<0>:>/,
l./g46:/,
l-2, r/:>/<0>:>/,
l./j9=k-2/, d, i/
j10: 0,0 ; current command name
0 ; (end of name)
j6: 0, 0 ; saved w3,w0
/,
l./i5:/,
l./al. w1 j8./, d, r/w2 j9/w1 j8/, r/out/ textline/,
l1, r/f1/f2/,
l1, d1,
l./jl. f31. ; goto next command;/, l1, d,
l./g54:/,
l./g2:/,
l./al. w2 e12./, d./al w0 10/, i/
; type textline (<:input sizeerror:>);
/,
l./jl. w3 f0./, r/f0/f2/,
l./g3:/,
l./g5:/,
l./rl w0 x1+0;/, d, i/
dl w1 x1+2 ; w0 := first word of command;
ds. w1 j10.+2 ; save command;
; cur action := action table;
/,
l./al. w2 e14./, d,
r/f1/f2/, r/out/ textline/,
l./ ; create:/, i/
; local procedure type command;
;
; call: w2=link
; exit: w0,w2,w3=unch, w1=undef
f4: ; type command:
ds. w0 j6.+2 ; save regs;
al. w1 j10. ;
jl. w3 f1. ; typetext (command name);
dl. w0 j6.+2 ; restore regs;
jl x2 ; return;
/,
l./g35:/,
l./jl. g54.;/, l1, i/
e. ; end binin-command
/,
l./procedure initialize date./,
d./i30: 60 ; sec/, d,
l./f19:/,
l./s24=s22/,
l./w.i0:rs.w3 i2./, d./i2:/, i/
w.
i0: ; initialize segment:
rl. w0 i3. ; initialize (top of initcat code);
rs. w0 (i4.) ;
rl. w2 i5. ;
dl w1 x3-2 ; move initcat switches;
ds w1 x2+d37-d36;
dl w1 x3-10 ; move startup area name;
ds w1 x2+d49+2-d36;
dl w1 x3-6 ;
ds w1 x2+d49+6-d36;
jl (10) ; goto system start;
i3: h13 ; top of initcat code
i4: b120 ; pointer to ...
i5: d36 ; pointer to initcat switches
/,
l./; segment 10/,
l./j0:/, r/;/;x3-4: /,
i/
j9: 0, r.4 ;x3-12: init cat switch: startup area name
/,
l./j1:/, r/;/;x3-2: /,
l./i3:/,
l./rs. w2 j2./, l1, i/
; ************* note: uses special knowledge to format of autoboot-program
dl w1 30 ; get startup area name from fixed part of autoboot!!!
ds. w1 j9.+2 ;
dl w1 34 ;
ds. w1 j9.+6 ;
/,
f
▶EOF◀