|
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: 66048 (0x10200)
Types: TextFile
Names: »ttem«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »ttem«
! *** ttem ***
;
;
; program for terminal access, terminal multiplexing and terminal spooling
; release 2.1 jan. 1980 knud christensen
!
terminalmodule
begin
!fp.no;
!sections 32;
procedure waitmess
(.w3.; ! return !
w2); ! abs ref message buffer (return) !
procedure sendwait
(.w3.; ! return !
w0 ; ! result (return) !
w1 ; ! abs ref message (call) !
w2); ! abs ref process name (call) !
procedure open
(.w3.; ! return !
w0 ; ! number of elements to open (call) !
w2); ! abs ref semaphore (call) !
procedure lock
(.w3.; ! return !
w0 ; ! number of elements to lock (return) !
w2); ! abs ref semaphore (call) !
procedure link
(.w3.; ! return !
w1 ; ! abs ref queue element (call) !
w2); ! abs ref queue head (call) !
procedure move
(.w3.; ! return !
w0 ; ! number of halfwords to move (call) !
w1 ; ! abs ref first halfword to move (call) !
w2); ! abs ref destination (call) !
procedure copy
(.w3.; ! return !
w0 ; ! number of halfwords (call/return) !
! or !
! -2 stopped !
! -3 unintel !
w2); ! abs ref first halfword (call) !
procedure create_ph
(.w3.; ! return !
ref cp_phhead,cp_psname,cp_sender;
w0); ! result (return) 1 = ok , 0 = not ok !
procedure remove_ph
(.w3.; ! return !
ref rp_phhead);
procedure create_th
(.w3.; ! return !
ref ct_thhead,ct_termproc;
word ct_type,ct_localid,ct_bufs,ct_timers,
ct_mask,ct_subst);
procedure remove_th
(.w3.; ! return !
ref rt_thhead);
procedure init_area
(.w3.; ! return !
w1); ! abs ref area description (call) !
procedure connect
(.w3.; ! return !
ref con_thhead,con_phhead);
procedure disconnect
(.w3.; ! return !
ref dis_thhead,dis_phhead);
procedure find_ph
(.w3.; ! return !
ref fp_psproc,fp_sender;
w1); ! result (return) !
! >0: abs ref ph found !
! =0: ph not found, no free ph !
! <0: ph not found, -abs ref free ph !
procedure unintel
(.w3.; ! return !
w0); ! status (call) !
procedure wait_op
(.w3.; ! return !
w0 ; ! length of operation got !
w1 ; ! abs ref operation got (return) !
w2); ! abs ref area description (call) !
procedure get_op
(.w3.; ! return !
w0 ; ! length of operation got (return) !
w1 ; ! abs ref operation got (return) !
w2); ! abs ref area description (call) !
procedure put_op
(.w3.; ! return !
w0 ; ! length of operation to put (call) !
w1 ; ! abs ref space for operation (return) !
w2); ! abs ref area description (call) !
procedure swop
(.w3.; ! return !
! a segment buffer is made available. !
! the referenced segment is copied to !
! and from bs depending on the mode-bits !
! described below: !
w2 ; ! bit 21 released after use !
! (i.e. next call buffer free) !
! bit 22 the segment is updated !
! (i.e. buffer will be copied to !
! bs before releasing) !
! bit 23 read from bs if segment not is !
! present !
! (call parameter) !
w0 ; ! segment no to swop in (call) !
w1); ! abs ref segment in core (return) !
procedure ph
(.w3.); ! return (pseudo call) !
procedure th
(.w3.); ! return (pseudo call) !
procedure opmess
(.w3.; ! return !
w1); ! abs ref message (call) !
procedure init
(.w3.); ! return !
procedure testout
(.w3.; ! return (call) !
w0 ; ! record length (call) !
w1 ; ! abs ref start of test record (call) !
w2); ! record kind (call) !
label central_wait,wait_next,coru_found,activate,initialize,
interrupt,io,gen_answer;
record message
(ref mess_next,mess_prev,mess_receiver,mess_sender;
byte mess_op,mess_mode;
ref mess_first,mess_last;
word mess_segment);
record controlmess
(ref cm_next,cm_prev,cm_receiver,cm_sender;
byte cm_op,cm_mode;
word cm_localid;
ref cm_tpda;
byte cm_bufs,cm_timers;
text(11) cm_name);
record cm2
(word cm2_1,cm2_2,cm2_3,cm2_4,cm2_5,cm2_6,cm2_7,cm2_8;
byte cm_mask,cm_subst);
record controlanswer
(word ca_status,ca_localid;
ref ca_tpda;
byte ca_bufs,ca_timers;
ref ca_pool;
word ca_recfull,ca_bytesfree,ca_dummy2);
record coroutine
(ref c_next,c_prev,c_mbuf;
word c_w0,c_w1,c_w2;
ref c_ic;
word c_nr,c_ww0,c_ww2,c_ww3;
ref a_recfull, a_bytesfree;
word a_first, a_top, a_firstfull, a_firstfree);
record processhandler
(array (1:!length(coroutine)) ph_c of byte;
ref ph_parent,ph_child,ph_psproc,ph_dummymess,ph_qreserve;
word ph_thincar; ! th.incar.no of current reserver of spoolqueue !
word ph_outcar; ! only used in f8000 links !
! incarn.no of current output link !
byte ph_sensed,ph_inpmode;
word ph_blockused, ph_savew0,ph_savew1);
record terminalhandler
(array (1:!length(coroutine)) th_c of byte;
ref th_parent,th_next,th_buf;
byte th_type; ! 0 = tty multiline 2 = tty singleline !
! 4 termin/termout !
word th_incar,
th_localid,th_timercount,th_timermax,th_maxbuf,th_usedbuf,
th_mask,th_subst,th_blockused;
text(14)th_name;
ref th_procdesc);
record termbufhead
(byte bufm_op,bufm_mode;
ref bufm_first,bufm_last;
word buf_status,buf_bytes,buf_chars,buf_result,buf_incar,
buf_localid,buf_data1);
record semaphore
(ref sem_next,sem_prev;
word sem_value);
record opcom
(byte opop,opmode;
text(5) optext1;
word logstatus;
text(11) optext2);
record name
(double name1,name2);
record spoolrec
(word seg_no,seg_prio,seg_data);
incode
ref current:=0,
event:=0,
activqfst,activqlast,
answerqfst,answerqlast,
waitqfst,waitqlast;
ref segpool_fst, segpool_top; word seg_size;
ref phpool_fst, phpool_top; word ph_size;
ref thpool_fst, thpool_top; word th_size;
ref sempool_fst, sempool_top; word sem_size;
byte testmop:=5,testmode:=0;
ref testmfst,testmlast;
word testsegm:=0,maxtestsegm;
ref cl_descriptor;
double starttime;
word bufl;
word ans_status,ans_bytes,ans_chars,ans4,ans5,ans6,ans7,ans8;
word bl,localid;
byte type, bufs, timers;
ref procdescr;
ref ph_head, th_head;
double xname1, xname2;
byte faultop:=2,faultmode:=1;
text(20) faulttxt:="***fault";
byte spcomop:=2,spcommode:=8'1001;
text(8) spcomtext:="status";
text(14) spoolname:="temspool";
word etx:= 3; ! constant equal to the iso value of etx !
! may be changed for test purposes !
begin
interrupt:
w3:=address(interrupt);
w0:= 0;
monitor(0); ! set interrupt address !
goto initialize;
w1+0; w1+0; w1+0; w1+0; ! fill up interrupt area !
testout(.w3.,w0:=16,w1:=address(interrupt),w2:=15);
opmess(.w3.,w1:=address(faultop));
initialize:
init(.w3.); ! call init for allocating and initializing buffers, !
! descriptors, semaphores etc. !
central_wait:
w2:=0; ! base of event queue !
wait_next:
current:=w3:=cl_descriptor;
monitor(24); ! wait next event !
event:=w2;
(w3).c_w0:=w0;
testout(.w3.,w0:=24,w1:=w2,w2:=6);
w1:= 66;
comment testout(.w3.,w0:=34,w1:=(w1).word,w2:=8);
w2:=event;
w0:=(w3).c_w0;
if w0 = 1 then
begin ! an answer has arrived in event queue !
w1:=address(ans_status);
monitor(18); ! wait answer (take the answer home) !
w1:=answerqfst;
while w3:=address(answerqfst) <> w1 do
begin ! scan answer queue to find corresponding sender !
if w2 = (w1).c_mbuf then
begin ! activate waiting coroutine !
(w1).c_w0:=w0;
goto coru_found;
end;
w1:=(w1).c_next;
end;
w1:=phpool_top;
while w1-!length(processhandler) >= phpool_fst do
begin ! scan process handlers in case of a dummy answer !
if w2 = (w1).ph_dummymess then
begin ! the application is removed, so remove terminal group !
w0:=0;
(w1).ph_dummymess:=w0;
while w2:=(w1).ph_child <> 0 do
begin
disconnect(.w3.,w2,w1);
remove_th(.w3.,w2);
end;
remove_ph(.w3.,w1);
goto central_wait;
end;
end;
goto central_wait;
end ! answer !
else
begin ! message has arrived in event queue !
if w0:=(w2).mess_op = 3 then
begin ! input output !
io:
find_ph(.w3.,w0:=(w2).mess_receiver,w0:=(w2).mess_sender,w1);
if w1<=0 then unintel(.w3.,w0:=-2);
if w0:=(w1).c_mbuf>=0 then goto wait_next;
(w1).c_w2:=w2;
(w1).c_mbuf:= w2;
monitor(26); ! get event !
goto coru_found;
end
else
if w0=5 then goto io
else
if w0=0 then goto io
else
if w0=110 then goto io
else
if w0=9 then
begin ! simulate input !
! compute buf length, avoid trunc errors !
w0:=(w2).mess_first;
-(w0 ashift -1 ashift 1);
w0+(w2).mess_last;
if w0<=0 then unintel(.w3.,w0:=-3);
if w0>=bufl then unintel(.w3.,w0:=-3);
bl:= w0+2;
find_ph(.w3.,w0:=(w2).mess_receiver,w0:=(w2).mess_sender,w1);
if w1<=0 then unintel(.w3.,w0:=-2); ! ph unknown !
ph_head:= w1;
if w1:=(w2).mess_first<=0 then unintel(.w3.,w0:=-3);
w3:= 116; w3:=(w3).word; ! no of storage bytes !
if w3<=(w2).mess_last then unintel(.w3.,w0:=-3); ! buf not inside store !
move(.w3.,w0:=2,w1,w2:= address(localid));
w1:=ph_head.ph_child;
w3:= 0;
while w1>w3 do
begin
w0:= localid-(w1).th_localid;
if w0 or (w1).th_type=0 then ! type=0 and localid ok !
w3:= w1
else
w1:= (w1).th_next;
end;
if w1=0 then unintel(.w3.,w0:=-4); ! th unknown !
procdescr:= w0:= (w1).th_procdescr;
type:= w0:= (w1).th_type;
bufs:= w0:= (w1).th_maxbuf;
timers:= w0:= (w1).th_timermax;
disconnect(.w3.,w1,w0:=ph_head);
remove_th(.w3.,w1);
create_th(.w3.,w1,w3:=procdescr,w3:=type,
w3:=localid,w3,=bufs,w3,=timers,w3:=0,w3:=0);
connect(.w3.,w1,w3:=ph_head);
(w1).th_usedbuf:= w0:= 1;
put_op(.w3.,w0:=bl+!position(buf_localid),w1,w2:=w1);
(w1).bufm_op:= w0:= 9; (w1).bufm_mode:= w0:= 0;
(w1).buf_bytes:= w0:= bl;
w2:= address((w1).buf_localid);
move(.w3.,w0,w1:=event.mess_first,w2);
ans_bytes:= w0;
ans_chars:= w0+(w2:=w0 ashift -1);
end ! simulate input !
else
if w0=90 then
begin ! create pool !
if w0:=(w2).cm_mode<>0 then unintel(.w3.,w0:=-3);
find_ph(.w3.,w0:=-1,w0,w1); ! find free ph !
if w1=0 then unintel(.w3.,w0:=8'0100);
-(w1);
ph_head:= w1;
w1:= address((w2).cm_name);
move(.w3.,w0:=8,w1,w2:=address(xname1));
create_ph(.w3.,w0:=ph_head,w2,w0:=(w2:=event).cm_sender,w0);
if w0=0 then unintel(.w3.,w0:=8'2000);
end ! create pool !
else
if w0=92 then
begin ! remove pool !
if w0:=(w2).cm_mode<>0 then unintel(.w3.,w0:=-3);
move(.w3.,w0:=8,w1:=address((w2).cm_name),w2:=address(xname1));
w2:= event;
w3:= address(xname1);
monitor(4); ! lookup process !
find_ph(.w3.,w0,w0:=(w2).cm_sender,w1);
if w1<=0 then unintel(.w3.,w0:=8'0400);
while w2:=(w1).ph_child<>0 do
begin
disconnect(.w3.,w2,w1);
remove_th(.w3.,w2);
end;
remove_ph(.w3.,w1);
end ! remove pool !
else
if w0=94 then
begin ! lookup pool !
if w0:= (w2).cm_mode<>0 then unintel(.w3.,w0:=-3);
move(.w3.,w0:=8,w1:=address((w2).cm_name),w2:=address(xname1));
w2:= event;
w3:= address(xname1);
monitor(4); ! lookup process !
find_ph(.w3.,w0,w0:=(w2).cm_sender,w1);
if w1<=0 then unintel(.w3.,w0:=8'0400);
w2:= w1;
w1:= address(ans_status);
(w1).ca_recfull:= w0:= (w3:=(w2).a_recfull).sem_value;
(w1).ca_bytesfree:= w0:= (w3:=(w2).a_bytesfree).sem_value;
end ! lookup pool !
else
if w0=100 then
begin ! create link !
if w0:=(w2).cm_mode and 8'7771<>0 then
unintel(.w3.,w0:=-3);
! lookup process description for device !
if w1:=(w2).cm_tpda<=0 then unintel(.w3.,w0:=-3);
if w1>current then unintel(.w3.,w0:=-3); ! address not in monitor !
move(.w3.,w0:=8,w1+2,w2:= address(xname1));
w2:= event;
w3:= address(xname1);
monitor(4);
if w0<>(w2).cm_tpda then unintel(.w3.,w0:=8'0004); ! dev. unknown!
find_ph(.w3.,w0:=(w2).cm_receiver,w0:=(w2).cm_sender,w1);
if w1<=0 then unintel(.w3.,w0:=8'0400); ! ph dont exist !
ph_head:= w1;
! reject if link is known allready or if no free th exist !
w3:= 0;
w1:= thpool_top;
while w1-!length(terminalhandler)>=thpool_fst do
begin
if w0:=(w1).th_procdescr=(w2).cm_tpda then unintel(.w3.,w0:=8'0020);
if w0=0 then w3:= w1 ! free th !
else
begin
if w0:=(w1).th_parent=ph_head then
if w0:=(w1).th_localid=(w2).cm_localid then
unintel(.w3.,w0:=8'1000);
end;
end;
if w3=0 then unintel(.w3.,w0:=8'0040);
! creation is possible !
w0:= w3;
create_th(.w3.,w3,w3:=(w2).cm_tpda,w3:=(w2).cm_mode,
w3:=(w2).cm_localid,w3,=(w2).cm_bufs,w3,=(w2).cm_timers,
w3:=(w2).cm_mask,w3:=(w2).cm_subst);
connect(.w3.,w0,w1:=ph_head);
end ! create link !
else
if w0=102 then
begin ! remove link !
if w0:=(w2).cm_mode ashift -1<>0 then unintel(.w3.,w0:=-3);
find_ph(.w3.,w0:=(w2).cm_receiver,w0:=(w2).cm_sender,w1);
if w1<=0 then unintel(.w3.,w0:=8'0400);
ph_head:= w1;
w1:= (w1).ph_child;
w3:= 0;
while w1>w3 do
begin
if w0:=(w1).th_localid=(w2).cm_localid then
w3:= w1
else
w1:= (w1).th_next;
end;
if w1=0 then unintel(.w3.,w0:=8'0200); ! th unknown !
if w0:=(w2).cm_mode=0 then
begin ! soft remove !
disconnect(.w3.,w1,w0:=ph_head);
put_op(.w3.,w0:=2,w1,w2:=w1);
(w1).bufm_op:= w0:= -1; (w1).bufm_mode:= w0:= 2;
end
else
begin ! hard remove !
disconnect(.w3.,w1,w0:=ph_head);
remove_th(.w3.,w1);
end;
end ! remove link !
else
if w0=104 then
begin ! lookup link !
if w0:=(w2).cm_mode<>0 then unintel(.w3.,w0:=-3);
find_ph(.w3.,w0:=(w2).cm_receiver,w0:=(w2).cm_sender,w1);
if w1<=0 then unintel(.w3.,w0:=8'0400);
w1:= (w1).ph_child;
w3:= 0;
while w1>w3 do
begin
if w0:=(w1).th_localid=(w2).cm_localid then w3:= w1
else w1:=(w1).th_next;
end;
if w1=0 then unintel(.w3.,w0:=8'0200); ! th unknown !
gen_answer:
w3:= w1;
w1:= address(ans_status);
(w1).ca_localid:= w0:= (w3).th_localid;
(w1).ca_tpda:= w0:= (w3).th_procdescr;
(w1).ca_bufs:= w0:= (w3).th_maxbufs;
(w1).ca_timers:= w0:= (w3).th_timermax;
if w2:=(w3).th_parent<>0 then
(w1).ca_pool:= w0:= (w2).ph_psproc;
(w1).ca_recfull:= w0:= (w2:=(w3).a_recfull).sem_value;
(w1).ca_bytesfree:= w0:= (w2:=(w3).a_bytesfree).sem_value;
end ! lookup link !
else
if w0=106 then
begin ! lookup term !
if w0:=(w2).cm_mode<>0 then unintel(.w3.,w0:=-3);
! lookup process description for device !
if w1:=(w2).cm_tpda<=0 then unintel(.w3.,w0:=-3);
if w1>current then unintel(.w3.,w0:=0);
move(.w3.,w0:=8,w1+2,w2:=address(xname1));
w3:=address(xname1);
monitor(4);
w2:= event;
if w0<>(w2).cm_tpda then unintel(.w3.,w0:=8'0004); ! device unknown !
w0:= (w2).cm_tpda;
w1:= thpool_fst;
w3:= thpool_top;
while w1<w3 do
begin
if w0=(w1).th_procdescr then w3:= w1
else w1+!length(terminalhandler);
end;
if w1=thpool_top then unintel(.w3.,w0:=8'0200);
if w0:=(w3:=(w1).th_parent).ph_parent <> (w2).cm_sender then
unintel(.w3.,w0:=8'0020);
goto gen_answer;
end ! lookup term !
else
begin ! operation illegal !
unintel(.w3.,w0:=0);
end;
! normal answer !
w2:= event;
monitor(26); ! get event !
ans_status:= w0:= 0;
w0:= 1;
w1:= address(ans_status);
monitor(22); ! send answer !
testout(.w3.,w0:=6,w1,w2:=61);
goto activate
end; ! message !
coru_found:
link(.w3.,w1,w2:=address(activqfst));
activate:
w1:=address(activqfst);
if w3:=(w1).c_next=w1 then goto central_wait;
current:= w3;
testout(.w3.,w0:=!length(terminalhandler),w1:=current,w2:=11);
w0:= (w3).c_w0;
w1:= (w3).c_w1;
w2:= (w3).c_w2;
call w0 current.c_ic;
end; ! main program !
body of waitmess
begin
incode
ref return;
begin
return:=w3;
w3:=b.current;
(w3).c_w0:=w0;
(w3).c_w1:=w1;
(w3).c_ic:=w0:=return;
w0:= -1; (w3).c_mbuf:= w0;
link(.w3.,w1:=w3,w2:=address(b.waitqfst));
testout(.w3.,w0:=!length(coroutine),w1,w2:=62);
goto b.activate;
end;
end; ! waitmess !
body of sendwait
begin
incode
ref return;
begin
return:=w3;
w3:=b.current;
(w3).c_w1:=w1;
(w3).c_w2:=w2;
w3:=w2;
monitor(16); ! send message !
w1:=b.current;
(w1).c_mbuf:=w2;
(w1).c_ic:=w0:=return;
link(.w3.,w1,w2:=address(b.answerqfst));
testout(.w3.,w0:=6,w1:=(w3).c_w1,w2:=63);
goto b.activate;
end;
end; ! sendwait !
body of open
begin
label exit;
incode
double savef1;
word savew2;
ref return;
begin
savef1:=f1;
savew2:=w2;
return:=w3;
(w2).sem_value:=w0+(w2).sem_value;
while w1:=(w2).sem_next <> w2 do
begin
if w0:=(w1).c_w0 > (w2).sem_value then goto exit;
(w2).sem_value:=w3:=(w2).sem_value-w0;
link(.w3.,w1,w2:=address(b.activqfst));
w2:=savew2;
end;
exit:
f1:=savef1;
if w0 > 0 then testout(.w3.,w0:=6,w1:=savew2,w2:=13);
f1:=savef1;
w2:=savew2;
w3:=b.current;
call w0 return;
end;
end; ! open !
body of lock
begin
incode
ref savew3;
begin
savew3:=w3;
w3:=b.current;
(w3).c_w0:=w0;
(w3).c_w1:=w1;
(w3).c_w2:=w2;
(w3).c_ic:=w0:=savew3;
if w0:=(w3).c_nr < 0 then
begin ! called from central logic !
(w2).sem_value:=w1:=(w2).sem_value-(w3).c_w0;
w1:=(w3).c_w1;
call w0 (w3).c_ic;
end else
begin
link(.w3.,w1:=w3,w2);
testout(.w3.,w0:=6,w1:=w2,w2:=12);
open(.w3.,w0:=0,w2:=w1);
goto b.activate;
end;
end;
end; ! lock !
body of link
begin
incode
double savef1;
word savew2;
ref return;
begin
savef1:=f1;
savew2:=w2;
return:=w3;
! remove queue element from actual queue !
w3:=(w1).c_prev;
(w3).c_next:=w0:=(w1).c_next;
w3:=(w1).c_next;
(w3).c_prev:=w0:=(w1).c_prev;
! link up element as the last element in the queue !
(w1).c_prev:=w3:=(w2).c_prev;
(w1).c_next:=w2;
(w2).c_prev:=w1;
(w3).c_next:=w1;
f1:=savef1;
w2:=savew2;
w3:=b.current;
call w0 return;
end;
end; ! link !
body of move
begin
incode
double savef1;
word savew2;
ref return;
begin
savef1:=f1;
savew2:=w2;
return:=w3;
w3:=w1+w0;
while w1 < w3 do
begin ! move from w1 to w2, one word at a time !
(w2).word:=w0:=(w1).word;
w1+2;
w2+2;
end;
f1:=savef1;
w2:=savew2;
w3:=b.current;
call w0 return;
end;
end; ! move !
body of copy
begin
incode
word savew1,savew2;
ref return;
begin
return:=w3;
savew1:=w1;
savew2:=w2;
w1:=w2;
w3:=w2+w0-2;
w2:=(w2:=b.current).c_mbuf;
monitor(70); ! copy core !
if w0>0 then -(w0) ! no bytes copied !
else w0:=w1; ! w0 = no of bytes copied !
w1:=savew1;
w2:=savew2;
w3:=b.current;
call w0 return;
end;
end; ! copy !
body of unintel
begin
label dumdum;
begin
w2:= b.event;
monitor(26); ! get event !
b.ans_status:= w0;
if w0=0 then w0:= 3
else if w0<0 then -(w0)
else w0:= 1;
w1:= address(b.ans_status);
monitor(22); ! send answer !
testout(.w3.,w0:=2,w1,w2:=60);
goto b.central_wait;
end;
end; ! unintel !
body of testout
begin
label close;
record dump
(word reg0,reg1,reg2,reg3,exreg,instr,cause,sbreg);
record testhead
(byte reclength,reckind;
word time,testref);
incode
word bufrel:=0;
ref return;
double savef1;
word savew2;
byte opcode:=6,opm:=8'1000;
text(8) status:="status";
text(14) testarea:="temtest";
begin
savef1:=f1;
savew2:=w2;
return:=w3;
if w3:=b.testmfst < b.testmlast then
begin ! if testbuffer exists then generate testoutput !
if w0+bufrel+(!length(testhead)+2) > 510 then
begin ! no room for next record so change buffer !
w3+bufrel;
(w3).word:=w0:=-1;
w1:=address(b.testmop);
w3:=address(testarea);
monitor(16); ! send message !
w1:=b.testmfst;
monitor(18); ! wait answer !
if w2:=1 lshift w0 or (w1).word <> 2 then
begin
b.testmlast:=w1:=b.testmfst;
w1:=address(opcode);
(w1).logstatus:=w2;
opmess(.w3.,w1);
end;
if w1:=b.testsegm+1 = b.maxtestsegm then w1:=1;
b.testsegm:=w1;
bufrel:=w0:=0;
end;
f1:=savef1;
w2:=savew2;
w3:=b.testmfst+bufrel;
(w3).reclength:=w0+!length(testhead);
(w3).reckind:=w2;
bufrel:=w1:=bufrel+w0;
w1:=(w1:=b.current).c_nr;
(w3).testref:=w1;
w1:=108;
f1:=(w1).double-b.starttime lshift -7;
(w3).time:=w1;
f1:=savef1;
move(.w3.,w0,w1,w2:=w3+!length(testhead));
end;
w2:=savew2;
if w2=15 then
begin ! internal interrupt !
w3:=(w1).instr-2;
if w0:=(w3).word lshift -18 = 51 ! key store ! then
begin ! reestablish registers and continue !
w0:=(w1).instr;
return:=w0;
w0:=(w1).reg0;
w2:=(w1).reg2;
w3:=(w1).reg3;
w1:=(w1).reg1;
call w0 return;
end else
begin ! output last segment and halt !
close:
(w3:=b.testmfst+bufrel).word:=w0:=-2;
w3:=address(testarea);
w1:=address(b.testmop);
monitor(16); ! send message !
monitor(18); ! wait answer !
monitor(10); ! release process !
end;
end else if w2 = 64 then goto close else;
f1:=savef1;
w2:=savew2;
w3:=b.current;
call w0 return;
end;
end; ! testout !
body of create_ph
begin
label ok, testexistence;
incode
text(14) sendername;
byte dummyop:=-2,dummymode:=0;
double savef2;
ref return;
word savew0;
begin
savef2:=f2;
return:=w3;
w3:=(w3).cp_psname;
monitor(80); ! create pseudo process !
if w0 = 0 then
begin
monitor(4); ! get process description address !
ok:
w1:= return.cp_phhead;
(w1).ph_psproc:=w0;
(w1).ph_inpmode:= w0:= -1; ! no input received yet !
(w1).ph_parent:=w2:=return.cp_sender;
ph(.w3.); ! force process handler into start position !
(w1).c_ic:=w3;
link(.w3.,w1,w2:=address(b.activqfst));
init_area(.w3.,w1);
move(.w3.,w0:=8,w1:=return.cp_sender+2,w2:=address(sendername));
w3:=w2;
w1:=address(dummyop);
monitor(16); ! send dummy message to trap removal of process !
w1:=return.cp_phhead;
(w1).ph_dummymess:= w2;
(w1).ph_thincar:= w0:= 0;
savew0:=w0:=1;
(w2:=(w1).ph_qreserve).sem_value:= w0;
end else
begin ! test why pseudo process was not created !
monitor(4); ! get process description !
if w0 > 0 then
begin ! the name already did describe a process !
w3:= 66;
if w3:=(w3).word=w0 then ! myself ! goto testexistence;
! test whether it is a pseudo process belonging to tem !
w1:= w0;
if w2:=(w1).word=64 then
begin ! it is a pseudo process !
w1+10;
if w3=(w1).word then
begin ! it belongs to tem !
testexistence:
w1:= 1;
w3:= b.phpool_top;
while w3-!length(processhandler)>=b.phpool_fst do
begin
if w0=(w3).ph_psproc then
if w2:=(w3).ph_parent=return.cp_sender then
w1:= 0;
end;
if w1>0 then goto ok;
end;
end;
end;
savew0:=w0:= 0;
end;
testout(.w3.,w0:=!length(processhandler),w1:=return.cp_phhead,w2:=53);
w0:=savew0;
f2:=savef2;
w3:=return;
end;
end; ! create_ph !
body of remove_ph
begin
incode
double savef1;
word savew2;
ref return;
text(11) psname;
begin
savef1:=f1;
savew2:=w2;
return:=w3;
w1:=(w3).rp_phhead;
if w2:=(w1).c_mbuf > 0 then
begin ! answer pending message with result 2 !
w0:=2;
monitor(22); ! send answer !
end;
open(.w3.,w0:=2000,w2:=(w1).ph_qreserve); ! open for all waiting th's !
init_area(.w3.,w1);
w0:=0;
(w1).c_mbuf:=w0;
(w1).ph_parent:=w0;
(w1).ph_child:=w0;
w2:=(w1).ph_psproc;
(w1).ph_psproc:=w0;
(w1).ph_sensed:= w0;
(w1).ph_blockused:= w0;
(w1).ph_outcar:= w0;
if w2 > 0 then
begin ! test whether pseudo process is to be removed !
w1:=b.phpool_top;
while w1-!length(processhandler) >= b.phpool_fst do
begin ! count phs using the same pseudo process !
if w2 = (w1).ph_psproc then w0+1;
end;
if w0 = 0 then
begin ! remove pseudo process !
move(.w3.,w0:=8,w1:=w2+2,w2:=address(psname));
w3:=w2;
monitor(64); ! remove process !
end;
end;
link(.w3.,w1:=return.rp_phhead,w2:=address(b.waitqfst));
if w2:=(w1).ph_dummymess > 0 then
begin ! regret dummy message !
monitor(82); ! regret message !
w0:=0;
(w1).ph_dummymess:=w0;
end;
w3:=b.thpool_top;
while w3-!length(terminalhandler) >= b.thpool_fst do
begin
if w1 = (w3).th_parent then
begin
w0:=0;
(w3).th_parent:=w0;
end;
end;
testout(.w3.,w0:=!length(processhandler),w1,w2:=54);
f1:=savef1;
w2:=savew2;
w3:=return;
end;
end; ! remove_ph !
body of create_th
begin
incode
double savef1;
word incar:= 0, savew2;
ref return;
begin
savef1:=f1;
savew2:=w2;
return:=w3;
w1:=(w3).ct_thhead;
(w1).th_type:= w0:= (w3).ct_type;
! force terminal handler into start position !
th(.w3.);
(w1).c_ic:=w3;
incar:= w0:= incar+1;
(w1).th_incar:= w0;
(w1).th_localid:=w0:=(w3:=return).ct_localid;
(w1).th_maxbuf:=w0:=(w3).ct_bufs;
(w1).th_timermax:=w0:=(w3).ct_timers;
(w1).th_mask:= w0:= (w3).ct_mask;
(w1).th_subst:= w0:= (w3).ct_subst;
(w1).th_procdesc:=w0:=(w3).ct_termproc;
w2:=address((w1).th_name);
w1:=w0+2;
move(.w3.,w0:=8,w1,w2);
if w0:=return.ct_type>=4 then
begin
w3:= w2;
monitor(8); ! reserve !
!test 109;
end;
link(.w3.,w1:=return.ct_thhead,w2:=address(b.activqfst));
init_area(.w3.,w1);
testout(.w3.,w0:=!length(terminalhandler),w1,w2:=55);
f1:=savef1;
w2:=savew2;
w3:=return;
end;
end; ! create_th !
body of remove_th
begin
incode
double savef1,savef3;
begin
savef1:=f1;
savef3:=f3;
w1:=(w3).rt_thhead;
w2:= (w1).th_parent;
if w2>0 then
if w0:=(w1).th_incar=(w2).ph_thincar then
begin ! th reserver of ph's spool queue !
put_op(.w3.,w0:=!length(termbufhead),w1,w2);
(w2).ph_thincar:= w0:= 0;
open(.w3.,w0:=1,w2:=(w2).ph_qreserve);
w0:= 0;
(w1).buf_status:= w0;
(w1).buf_bytes:= w0;
(w1).buf_chars:= w0;
(w1).buf_result:= w0:= 4; ! disconnect !
f3:= savef3;
w2:= (w3).rt_thhead;
w0:= (w2).th_incar;
(w1).buf_incar:= w0;
end;
w1:= (w3).rt_thhead;
w0:= 0;
(w1).c_mbuf:=w0;
(w1).th_parent:=w0;
(w1).th_next:=w0;
(w1).th_incar:= w0;
(w1).th_localid:=w0;
(w1).th_timercount:=w0;
(w1).th_usedbuf:=w0;
(w1).th_blockused:= w0;
(w1).th_procdesc:=w0;
w3:=address((w1).th_name);
monitor(10); ! release terminal !
(w3).word:=w0;
link(.w3.,w1,w2:=address(b.waitqfst));
init_area(.w3.,w1);
testout(.w3.,w0:=!length(terminalhandler),w1,w2:=56);
f1:=savef1;
f3:=savef3;
end;
end; ! remove_th !
body of init_area
begin
incode
double savef1;
word savew2;
ref return;
begin
savef1:=f1;
savew2:=w2;
return:=w3;
(w1).a_firstfull:=w0:=(w1).a_first;
(w1).a_firstfree:=w0;
w2:=(w1).a_bytesfree;
w0:=(w1).a_top-(w1).a_first-(w2).sem_value-512;
open(.w3.,w0,w2); ! release all occupied bytes !
(w2:=(w1).a_recfull).sem_value:=w0:=0;
f1:=savef1;
w2:=savew2;
w3:=return;
end;
end; ! init_area !
body of connect
begin
incode
double savef1,savef3;
begin
savef1:=f1;
savef3:=f3;
w2:=(w3).con_phhead;
w0:=(w2).ph_child;
(w2).ph_child:=w1:=(w3).con_thhead;
(w1).th_next:=w0;
(w1).th_parent:= w2;
if w1:=(w2).c_mbuf>0 then
begin
! answer pending input or sense operation !
if w0:=(w1).mess_op<=3 then
begin
put_op(.w3.,w0:=!position(buf_localid),w1,w2);
(w1).buf_result:= w0:= 1;
(w1).buf_status:= w0:= 0;
(w1).buf_bytes:= w0;
(w1).buf_chars:= w0;
(w1).buf_incar:= w0:= -1; ! end record not existing th !
end;
end;
f3:= savef3;
testout(.w3.,w0:=4,w1:=w3,w2:=57);
f1:=savef1;
f3:=savef3;
end;
end; ! connect !
body of disconnect
begin
label exit;
incode
double savef1,savef3;
begin
savef1:=f1;
savef3:=f3;
w2:=(w3).dis_phhead;
w1:=(w2).ph_child;
if w1 = (w3).dis_thhead then
begin ! disconnect first ph !
(w2).ph_child:=w0:=(w1).th_next;
w0:=0;
(w1).th_next:=w0;
goto exit;
end;
w2:= w1;
while w1:=(w1).th_next<>0 do
begin ! scan th chain to find actual one !
if w1 = (w3).dis_thhead then
begin ! disconnect th !
(w2).th_next:=w0:=(w1).th_next;
w0:=0;
(w1).th_next:=w0;
goto exit;
end;
w2:= w1;
end;
exit:
testout(.w3.,w0:=4,w1:=w3,w2:=58);
f1:=savef1;
f3:=savef3;
end;
end; ! disconnect !
body of find_ph
begin
label found;
incode
word savew0,savew2,freeph;
ref return;
begin
savew0:=w0;
savew2:=w2;
return:=w3;
if w2:=(w3).fp_psproc < 0 then -(w2);
freeph:=w0:=0;
w1:=b.phpool_top;
while w1-!length(processhandler) >= b.phpool_fst do
begin
if w0:=(w1).ph_parent = (w3).fp_sender then
begin
if w2 = (w1).ph_psproc then goto found;
end
else
begin
if w0 = 0 then freeph:=w1;
end;
end;
-(w1:=freeph);
found:
w0:=savew0;
w2:=savew2;
w3:=return;
end;
end; ! find_ph !
body of wait_op
begin
incode
ref return;
begin
w1:= b.current;
(w1).c_ww2:= w2;
(w1).c_ww3:= w3;
lock(.w3.,w0:=1,w2:=(w2).a_recfull);
open(.w3.,w0,w2);
w3:= (w3).c_ww2;
swop(.w3.,w2:=1,w0:=(w3).a_firstfull ashift -9,w1);
w2:= (w3).c_ww2;
w0:= (w2).a_firstfull extract 9;
w1+w0;
testout(.w3.,w0:=20,w1,w2:=66);
w0:= (w1).word-2;
w1+2;
w2:= (w3).c_ww3;
return:= w2;
w2:= (w3).c_ww2;
call w0 return;
end;
end; ! wait_op !
body of get_op
begin
incode
ref return;
begin
w1:= b.current;
(w1).c_ww2:= w2;
(w1).c_ww3:= w3;
lock(.w3.,w0:=1,w2:=(w2).a_recfull);
if w2:=(w2).sem_value=0 then w2:=5 ! swop in and release !
else w2:= 1; ! swop in !
w3:= (w3).c_ww2;
swop(.w3.,w2,w0:=(w3).a_firstfull ashift -9, w1);
w2:= (w2:=b.current).c_ww2;
w0:= (w2).a_firstfull extract 9;
w1+w0;
! compute new firstfull, if area is empty set firstfull !
! and firstfree to start of current segment !
w0:= (w2).a_firstfull + (w1).word;
if w0<>(w2).a_firstfree then
begin
w3:= w1+(w1).word;
if w3:= (w3).word = -1 then
begin ! last record on segment !
w0+512 ashift -9 ashift 9;
if w0>=(w2).a_top then w0:= (w2).a_first;
(w2).a_firstfull:=w0;
open(.w3.,w0:=512,w2:=(w2).a_bytesfree);
w2:= (w3).c_ww2;
end else
(w2).a_firstfull:= w0;
end
else
begin
(w2).a_firstfull:= w0 ashift -9 ashift 9;
(w2).a_firstfree:= w0;
end;
testout(.w3.,w0:=2,w1,w2:=50);
w0:= (w1).word - 2;
w1+2;
w2:= (w3).c_ww3;
return:= w2;
w2:= (w3).c_ww2;
call w0 return;
end;
end; ! get_op !
body of put_op
begin
incode
ref return;
begin
w1:= b.current;
(w1).c_ww0:= w0;
(w1).c_ww2:= w2;
(w1).c_ww3:= w3;
lock(.w3.,w0:=512,w2:=(w2).a_bytesfree);
w0:=(w1).c_ww0;
w2:=(w1).c_ww2;
begin ! operation buffer ready !
! change segment if claim > rest on current segment !
! else release segment !
w0+2;
w1:= (w2).a_firstfree + w0 ashift -9 ashift 9;
if w1>(w2).a_firstfree then
begin
if w1>=(w2).a_top then w1:= (w2).a_first;
(w2).a_firstfree:= w1;
end
else
begin
open(.w3.,w0:=512,w2:=(w2).a_bytesfree);
end;
w2:= (w3).c_ww2;
if w2:=(w2).a_firstfree extract 9=0 then w2:=2 ! dont swop in !
else w2:= 3;
swop(.w3.,w2,w0:=w1 ashift -9,w1);
w2:= (w3).c_ww2;
w0:= (w2).a_firstfree extract 9;
w1+w0;
(w1).word:= w0:= (w3).c_ww0 + 2;
w3:=w1+w0;
(w2).a_firstfree:= w0 + (w2).a_firstfree;
(w3).word:=w0:=-1;
open(.w3.,w0:=1,w2:=(w2).a_recfull);
end;
testout(.w3.,w0:=2,w1,w2:=51);
w2:= (w3).c_ww3;
return:= w2;
w0:= (w3).c_ww0;
w1+2;
w2:= (w3).c_ww2;
call w0 return;
end;
end; ! put_op !
body of swop
begin
procedure transport(.w3.;
w1); ! message address (call) !
incode
word savew2;
word found;
ref wictim, return;
byte op, mode;
ref first, last;
word s_no;
word bitmask:= 8'20000000;
begin
savew2:= w2; return:= w3;
found:= w1:= -1;
wictim:= w1:= b.segpool_fst;
while w1<b.segpool_top do
begin
w3:= (w1).seg_no extract 22;
if w0=w3 then found:= w1;
if w3:=(w1).seg_prio<wictim.seg_prio then wictim:= w1;
(w1).seg_prio:= w3-1;
w1+b.seg_size;
end;
if w1:= found=-1 then
begin ! segment not present !
w1:= address (op);
w2:= wictim;
first:= w3:= address((w2).seg_data);
w3+510;
last:= w3;
if w3:= (w2).seg_no onemask bitmask then
begin ! segment updated, swop out !
op:= w3:= 5;
s_no:= w3:= (w2).seg_no extract 22;
transport(.w3.,w1);
end;
if w3:=savew2 onemask 1 then
begin ! swop in !
op:= w3:= 3;
s_no:= w0;
transport(.w3.,w1);
end;
w1:= wictim;
(w1).seg_no:= w0;
end;
(w1).seg_prio:= w3:= 0;
if w3:=savew2 onemask 4 then
begin ! release buffer !
(w1).seg_no:= w3:= 8'17777777; ! +infinite !
(w1).seg_prio:= -(w3); ! -infinite !
end
else
if w3:=savew2 onemask 2 then
begin ! set update-segment-mark !
(w1).seg_no:= w3:= bitmask or (w1).seg_no;
end else;
w1+!position(seg_data);
w2:= savew2;
w3:= b.current;
call w0 return;
end;
body of transport
begin
incode
word status, bytes, chars, a4, a5, a6, a7, a8;
double savef1, savef3;
begin
savef1:= f1;
savef3:= f3;
testout(.w3.,w0:=8,w1,w2:=52);
w3:= address (b.spoolname);
monitor(16);
w1:= address(status);
monitor(18);
if w2:=1 lshift w0 or (w1).word <> 2 then
begin
w1:=address(b.spcomop);
(w1).logstatus:=w2;
testout(.w3.,w0:=16,w1,w2:=64);
opmess(.w3.,w1);
end;
f1:= savef1; f3:= savef3;
end;
end; ! transport !
end; ! swop !
body of ph
begin
label unint,disconnect,stopped,ans_sense,zero_answer,no_input,
loop,loop_stin,nextth;
incode
ref return;
word status, bytes, chars, a4:= 0, a5:= 0, a6:= 0, a7:= 0, a8:= 0;
word loc_id,outcar,thmask;
begin
return:= w3; call w3 return; ! initial lock !
while w1=w1 do
begin
waitmess(.w3.,w2);
if w0:=(w2).mess_op=0 then
begin
if w0:=(w2).mess_mode=0 then
begin ! sense !
ans_sense:
w0:= 1;
zero_answer:
status:= w1:= 0;
bytes:= w1;
chars:= w1;
w1:= address(status);
end
else
if w0=2 then
begin ! sense ready !
(w3).ph_sensed:= w0:= 1;
if w0:=(w3).ph_inpmode=-1 then (w3).ph_inpmode:= w0:= 0;
w2:=(w3).ph_child;
while w2>0 do
begin ! send input operations to all free input !
! buffers owned by ph's childs !
if w0:=(w2).th_usedbuf<(w2).th_maxbuf then
begin
put_op(.w3.,w0:=!position(buf_chars),w1,w2);
(w1).bufm_op:= w0:= 3;
(w1).bufm_mode:= w0:= (w3).ph_inpmode;
(w1).buf_bytes:= w0:= b.bufl;
(w2).th_usedbuf:= w0:= (w2).th_usedbuf+1;
end
else
w2:= (w2).th_next;
end;
(w3).ph_sensed:= w0:= 1;
wait_op(.w3.,w0,w1,w2:=w3);
if w0:=(w1).buf_bytes=0 then
begin ! status error or stopped !
get_op(.w3.,w0,w1,w2);
w3:= (w3).ph_child;
while w3>0 do
begin
if w0:=(w3).th_incar=(w1).buf_incar then
begin ! release buffer !
(w3).th_usedbuf:= w0:= (w3).th_usedbuf-1;
w3:= 0;
end
else
w3:= (w3).th_next;
end;
w0:= (w1).buf_result;
status:= w1:= (w1).buf_status;
w1:= address(status);
end
else
begin ! data ready !
goto ans_sense;
end;
end ! sense ready !
else goto unint;
end ! operation = 0 !
else
if w0=3 then
begin ! input !
if w0:=(w3).ph_inpmode=-1 then (w3).ph_inpmode:= w0:= (w2).mess_mode;
if w0:=(w1:=(w3).a_recfull).sem_value -(w3).ph_sensed=-1 then
begin ! no data ,sense read protocol used !
no_input:
(w3).ph_sensed:= w0:= 0;
goto ans_sense;
end
else
begin
w2:= (w3).ph_child;
while w2>0 do
begin ! send input operations to all free th buffers !
if w0:=(w2).th_usedbuf<(w2).th_maxbuf then
begin
put_op(.w3.,w0:=!position(buf_chars),w1,w2);
(w1).bufm_op:= w0:= 3;
(w1).bufm_mode:= w0:= (w3).ph_inpmode;
(w1).buf_bytes:= w0:= b.bufl;
(w2).th_usedbuf:= w0:= (w2).th_usedbuf+1;
end
else
w2:= (w2).th_next;
end;
wait_op(.w3.,w0,w1,w2:=w3);
(w3).ph_savew0:= w0:= (w1).buf_bytes-(w3).ph_blockused;
if w0=0 then
begin
if w2:=(w3).ph_sensed=1 then goto no_input;
end
else
copy(.w3.,w0,w2:=address((w1).buf_localid)+(w3).ph_blockused);
if w0=-2 then goto stopped;
if w0=-3 then goto unint;
loc_id:= w1; ! save temporary !
testout(.w3.,w0,w1:=w2,w2:=0);
w1:= loc_id;
if w0=(w3).ph_savew0 then ! last of block copied into ph-owner !
begin
!test 508;
get_op(.w3.,w0,w1,w2:=w3);
w3:= (w3).ph_child;
if w0:=(w1).buf_incar >0 then ! last block in record !
while w3>0 do
begin
if w0=(w3).th_incar then
begin ! th found !
(w3).th_usedbuf:= w0:= (w3).th_usedbuf-1;
!test 510;
w3:= 0;
end
else
w3:= (w3).th_next;
end;
w3:= b.current;
bytes:= w0:= (w3).ph_savew0;
w2:= (w3).ph_blockused+(w0:=w2 ashift -1);
chars:= w0:= (w1).buf_chars-w2;
(w3).ph_blockused:= w0:= 0;
end
else
begin
bytes:= w0;
chars:= w0+(w2:=w0 ashift -1);
(w3).ph_blockused:= w0:= bytes+(w3).ph_blockused;
end;
status:= w0:= (w1).buf_status;
w0:= (w1).buf_result;
w1:= address(status);
end;
end ! input !
else
if w0=5 then
begin ! output !
! compute blength avoid trunc errors !
w0:= (w2).mess_first;
-(w0 ashift -1 ashift 1);
w0+(w2).mess_last;
if w0 < 0 then goto unint;
if w0>=450 then w0:= 450
else w0+2;
(w3).ph_savew0:= w0;
outcar:= w0:= (w3).ph_outcar;
if w0=0 then
begin
copy(.w3.,w0:=2,w2:=address(loc_id));
if w0=-2 then goto stopped;
if w0=-3 then goto unint;
end;
w1:= (w3).ph_child;
loop:
if w1<=0 then goto disconnect; ! receiver unknown !
if w0:=outcar<>0 then
begin
!test 305;
if w0<>(w1).th_incar then goto nextth;
end
else
if w0:=(w1).th_type=0 then
begin
!test 306;
if w0:=loc_id<>(w1).th_localid then goto nextth;
end
else
if w0>=4 then
begin
if w0:= loc_id lshift -16 and (w1).th_mask<>(w1).th_subst then
begin
nextth:
!test 307;
w1:= (w1).th_next;
goto loop;
end;
end else;
put_op(.w3.,w0:=(w3).ph_savew0+!position(buf_localid),w1,
w2:=w1);
thmask:= w0:= 0;
if w0:=(w2).th_type=4 then
begin
if w0:= (w3).ph_outcar=0 then
begin
thmask:= w0:= (w2).th_mask lshift 16;
(w3).ph_outcar:= w0:= (w2).th_incar;
end;
end;
w2:= (w3).c_mbuf;
(w1).bufm_op:= w0:= 5; (w1).bufm_mode:= w0:= (w2).mess_mode;
w0:= (w3).ph_savew0;
copy(.w3.,w0,w2:=address((w1).buf_localid));
(w1).buf_bytes:= w0; ! if no bytes copied the 'putted' operation is changed !
if w0=-2 then goto stopped;
if w0=-3 then goto unint;
w3:= -1; w3 xor thmask;
(w1).buf_localid:= w3 and (w1).buf_localid;
testout(.w3.,w0,w1:=w2,w2:=0);
status:= w2:= 0;
bytes:= w0;
chars:= w0+(w2:=w0 ashift -1);
if w0:=(w3).ph_outcar<>0 then
begin ! test end of record !
w1+bytes-2;
w1:= (w1).word;
while w1<>0 do
begin
w0:= 0;
f1 lshift 8;
if w0=b.etx then w1:= 0;
!test 311;
end;
if w0=b.etx then (w3).ph_outcar:= w0:= 0;
end;
w0:= 1; w1:= address(status);
end ! output !
else
if w0=110 then
begin ! start input !
w1:= (w3).ph_child;
loop_stin:
if w1<=0 then goto disconnect; ! receiver unknown !
if w0:=(w1).th_type=0 then w0:= (w2).cm_localid
else if w0=2 then w0:= 0
else w0:= (w2).cm_localid lshift -16 lshift 16;
if w0<>(w1).th_localid then
begin
w1:= (w1).th_next;
goto loop_stin;
end;
if w0:=(w3).ph_inpmode=-1 then (w3).ph_inpmode:= w0:= (w2).mess_mode;
(w3).ph_savew0:= w0:= (w2).cm_bufs;
w2:= w1;
while w0:=(w3).ph_savew0>0 do
begin
(w3).ph_savew0:= w0-1;
put_op(.w3.,w0:=!position(buf_chars),w1,w2);
(w1).bufm_op:= w0:= 3;
(w1).bufm_mode:= w0:= (w3).ph_inpmode;
(w1).buf_bytes:= w0:= b.bufl;
(w2).th_usedbuf:= w0:= (w2).th_usedbuf+1;
end;
goto ans_sense;
end
else
if w0=w0 then
begin
unint:
w0:= 3; goto zero_answer;
end
else
if w0=w0 then
begin
stopped:
w0:= 1; goto zero_answer;
end
else
begin
disconnect:
w0:= 4; goto zero_answer;
end;
! send answer !
w2:= (w3:=b.current).c_mbuf;
monitor(22);
w0:= 0;
(w3).c_mbuf:= w0; ! clear operation !
testout(.w3.,w0:=6,w1,w2:=61);
end; ! for ever !
end;
end; ! ph !
body of th
begin
label ttyloop, next, terminsense, terminput, terminanswer;
incode
ref return;
word nl:= 4'002200000000,sense:=0,senseready:=2,help;
begin
return:= w3; call w3 return;
! synchronize with terminal (wait untill previous io has terminated) !
sendwait(.w3.,w0,w1:=address(sense),w2:=address((w3).th_name));
while w1=w1 do
begin
wait_op(.w3.,w0,w1,w2:=w3);
if w0:=(w1).bufm_op = 3 then
begin ! input !
get_op(.w3.,w0,w1,w2);
move(.w3.,w0,w1,w2:=(w3).th_buf);
w1:= w2;
w0:= (w1).buf_bytes;
(w1).bufm_first:= w2:= address((w1).buf_localid);
w2+w0-2;
(w1).bufm_last:= w2;
if w2:=(w3).th_type<=2 then ! tty !
begin
w0:= (w1).buf_bytes;
if w2:=(w3).th_type=0 then
begin ! tty multiline, make room for localid and nl !
(w1).bufm_first:= w2:= address((w1).buf_data1);
w2:= (w1).bufm_last; w2-2;
(w1).bufm_last:= w2;
(w1).buf_localid:= w0:= (w3).th_localid;
end;
(w3).th_timercount:= w0:= 0;
ttyloop:
! send and wait, repeat evt. on timer status !
sendwait(.w3.,w0,w1,w2:= address((w3).th_name));
(w1).buf_result:= w0;
if w0<>1 then b.ans_bytes:= w2:= 0;
(w1).bufm_first:= w2:= (w1).bufm_first + b.ans_bytes;
if w0 or b.ans_status = 2097153 then
if w2<=(w1).bufm_last then
if w0:=(w3).th_parent>0 then
if w0:=(w3).th_timercount+1 <= (w3).th_timermax then
begin
(w3).th_timercount:= w0;
goto ttyloop;
end;
if w0:=(w3).th_type=0 then
begin
w2-2; ! terminate datablock with nl !
w0:= (w2).word;
if w0=0 then w0:= 1;
w1:= 0;
next: f1 lshift -8;
if w1=0 then goto next;
if w1<>nl then
begin
w2+2;
(w2).word:= w1:= nl;
end;
w1:= (w3).th_buf;
w2+2;
end;
(w1).buf_status:= w0:= b.ans_status;
w0:= address((w1).buf_localid) - w2;;
(w1).buf_bytes:= -(w0);
(w1).buf_chars:= w2:= w0 ashift -1 + w0;
(w1).buf_incar:= w2:= (w3).th_incar;
end
else
begin
goto terminput;
terminsense:
sendwait(.w3.,w0,w1:=address(senseready),w2:=address((w3).th_name));
if w0<>1 then goto terminput;
if w2:=b.ans_status=8'10000000 ! timer ! then
if w2:=(w3).th_parent>0 then
begin
if w2:=(w3).th_timercount+1<=(w3).th_timermax then
begin
(w3).th_timermax:= w2;
goto terminsense;
end else goto terminanswer;
end;
terminput:
sendwait(.w3.,w0,w1:=(w3).th_buf,w2:=address((w3).th_name));
terminanswer:
w1:= (w3).th_buf;
(w1).buf_result:= w0;
if w0<>1 then
begin
b.ans_status:= w0:= 0;
b.ans_bytes:= w0;
b.ans_chars:= w0;
end;
if w0 or b.ans_status<>1 then
(w1).buf_incar:= w0:= (w3).th_incar
else
begin
if w0:=b.ans_bytes=0 then goto terminsense;
! test presense of etx !
(w1).buf_incar:= w0:= (w3).th_incar;
w2:= (w1).bufm_first;
w2+b.ans_bytes-2;
w0:= (w2).word;
while w0<>0 do
begin
w3:= 0;
f0 lshift 8;
if w3=b.etx then w0:= 0;
end;
if w3<>b.etx then (w1).buf_incar:= w0; ! block not end record !
w3:= b.current;
end;
(w1).buf_status:= w0:= b.ans_status;
(w1).buf_bytes:= w0:= b.ans_bytes;
(w1).buf_chars:= w2:= b.ans_chars;
end;
if w2:=(w3).th_parent>0 then
begin
w1:= w0; ! save temporary !
if w0:= (w2).ph_thincar<>(w3).th_incar then
begin
lock(.w3.,w0:=1,w2:=(w2).ph_qreserve);
if w0:=(w3).th_type=4 then
begin
w2:= (w3).th_buf;
(w2).buf_localid:= w0:= (w3).th_subst lshift 16 or (w2).buf_localid;
end;
end;
w2:= (w3).th_parent;
if w2>0 then
begin
(w2).ph_thincar:= w0:= (w3).th_incar;
put_op(.w3.,w0:=w1+!position(buf_localid),w1,w2);
w2:= w1;
move(.w3.,w0,w1:=(w3).th_buf,w2);
if w2:= (w1).buf_incar=0 then ! not end record ! goto terminput
else
if w2:=(w3).th_parent>0 then
begin
(w2).ph_thincar:= w0:= 0;
open(.w3.,w0:=1,w2:=(w2).ph_qreserve)
end
else;
end;
end;
end
else
if w0=5 then
begin ! output !
move(.w3.,w0:=!position(buf_chars),w1,w2:=(w3).th_buf);
help:= w0:= 0;
if w0:=(w3).th_type=0 then w0:= -2
else w0:= 0;
w1:= address((w1).buf_localid)-w0;
w0+ (w2).buf_bytes-(w3).th_blockused;
if w0>b.bufl then ! not last portion of block !
help:= w0:= b.bufl;
move(.w3.,w0,w1+(w3).th_blockused,
w2:=address((w2).buf_localid));
w1:= (w3).th_buf;
(w1).bufm_first:= w2;
w2+w0-2;
(w1).bufm_last:= w2;
if w2:=help=0 then
begin ! last portion of block !
(w3).th_blockused:= w2;
get_op(.w3.,w0,w1,w2:=w3);
end
else
(w3).th_blockused:= w0+(w3).th_blockused;
sendwait(.w3.,w0,w1:=(w3).th_buf,w2:= address((w3).th_name));
end
else
if w0=9 then
begin ! simulate input !
get_op(.w3.,w0,w1,w2);
move(.w3.,w0,w1,w2:=(w3).th_buf);
w1:= (w3).th_buf;
(w1).buf_status:= w2:= 0;
w2:= (w1).buf_bytes;
(w1).buf_chars:= w2 ashift -1 + (w1).buf_bytes;
(w1).buf_incar:= w2:= (w3).th_incar;
(w1).buf_result:= w2:= 1;
if w2:= (w3).th_parent > 0 then
begin
w1:= w0;
lock(.w3.,w0:=1,w2:=(w2).ph_qreserve);
w2:= (w3).th_parent;
if w2>0 then
begin
(w2).ph_thincar:= w0:= (w3).th_incar;
put_op(.w3.,w0:=w1,w1,w2);
w2:=w1;
move(.w3.,w0,w1:=(w3).th_buf,w2);
if w2:=(w3).th_parent>0 then
begin
(w2).ph_thincar:= w0:= 0;
end;
open(.w3.,w0:=1,w2:=(w2).ph_qreserve);
end;
end;
end
else
begin ! give up !
remove_th(.w3.,w3);
goto b.activate;
end
end ! for ever !
end
end; ! th !
body of opmess
begin
incode
double savef1,savef3;
text(14) parent;
begin
savef1:=f1;
savef3:=f3;
w1:=66;
w1:=(w1).word+50;
move(.w3.,w0:=8,w1:=(w1).word+2,w2:=address(parent));
w3:=w2;
f1:=savef1;
monitor(16); ! send message to parent !
w1:=address(b.ans_status);
monitor(18); ! wait answer !
f1:=savef1;
f3:=savef3;
end;
end; ! opmess !
body of init
begin
label allocate,initbufs;
incode
text(14)testarea:="temtest",spoolarea:="temspool";
byte op3:= 16, mode3:= 8'0140;
text(14) verstext:=
! *** tem *** ! "release: 2.1";
word
! date of version ! version := 800104,
comment ===trimstart;
! date of options ! options := 0,
! number of active terminals ! thcount := 10,
! number of terminal groups ! phcount := 4,
! size of terminal buffer (halfwords) ! termbufsize := 104,
! number of segments in each ph spool area ! phspoolsegm := 8,
! number of segments in each th spool area ! thspoolsegm := 8,
! number of spool segment buffers in core ! spoolbufs := 2,
! size of testoutput area ! testsegmnts := 168,
comment ===trimfinis;
corucount,spoolpointer:=0;
array(1:10) tail of word;
ref return, termbufref, semref;
byte op1:=16,mode1:=8'40;
word alarm;
text(14) resource;
word stdvalue,margin,bufclaim,stop:=0;
text(14)size := "size",
area := "area",
buf := "buf";
text(20)inittr:=" ***init troubles";
byte op2:=16,mode2:=0;
text(20) started:="started";
begin
return:=w3;
goto allocate;
initbufs:
f1 lshift -100;
for w2:=b.cl_descriptor step 4 upto b.sempool_top do (w2).double:= f1;
(w1:=b.cl_descriptor).c_nr:=w0:=-1;
w1:= b.phpool_fst;
for w3:=1 step 1 upto phcount do
begin
(w1).c_next:=w1;
(w1).c_prev:=w1;
(w1).c_nr:=w2:=w3+100;
(w1).a_recfull:=w2:=semref;
(w2).sem_next:=w2;
(w2).sem_prev:=w2;
w2+!length(semaphore);
(w1).a_bytesfree:=w2;
(w2).sem_next:=w2;
(w2).sem_prev:=w2;
(w2).sem_value:=w0:=phspoolsegm lshift 9;
w2+!length(semaphore);
(w1).ph_qreserve:= w2;
(w2).sem_next:= w2;
(w2).sem_prev:= w2;
(w2).sem_value:= w0:= 1;
w2+!length(semaphore);
semref:=w2;
(w1).a_first:=w0:=spoolpointer;
(w1).a_firstfull:=w0;
(w1).a_firstfree:=w0;
(w1).a_top:=w0+(w2:=phspoolsegm+1 lshift 9);
spoolpointer:=w0;
w1+!length(processhandler);
end;
w1:= b.thpool_fst;
for w3:=1 step 1 upto thcount do
begin
(w1).c_next:=w1;
(w1).c_prev:=w1;
(w1).c_nr:=w2:=w3+200;
(w1).th_buf:=w2:=termbufref;
w2+termbufsize+(!length(termbufhead)-4);
termbufref:=w2;
(w1).a_recfull:=w2:=semref;
(w2).sem_next:=w2;
(w2).sem_prev:=w2;
w2+!length(semaphore);
(w1).a_bytesfree:=w2;
(w2).sem_next:=w2;
(w2).sem_prev:=w2;
(w2).sem_value:=w0:=thspoolsegm lshift 9;
w2+!length(semaphore);
semref:=w2;
(w1).a_first:=w0:=spoolpointer;
(w1).a_firstfree:=w0;
(w1).a_firstfull:=w0;
(w1).a_top:=w0+(w2:=thspoolsegm+1 lshift 9);
spoolpointer:=w0;
w1+!length(terminalhandler);
end;
testout(.w3.,w0:=20,w1:=address(version),w2:=69);
w1:=66;
testout(.w3.,w0:=150,w1:=(w1).word-4,w2:=8);
w0:= 8'17777777; ! segm not updated , segm.no = +infinite !;
w1:=0;
w2:=b.segpool_top;
while w2-516 >= b.segpool_fst do (w2).double:=f1;
call w0 return;
allocate:
opmess(.w3.,w1:=address(op3));
corucount:=w0:=thcount+phcount;
b.activqfst:=w0:=address(b.activqfst);
b.activqlast:=w0;
b.answerqfst:=w0:=address(b.answerqfst);
b.answerqlast:=w0;
b.waitqfst:=w0:=address(b.waitqfst);
b.waitqlast:=w0;
b.segpool_fst:=w1:=address(testarea);
b.seg_size:=w0:=516;
w0*spoolbufs;
w1+w0;
b.segpool_top:=w1;
termbufref:=w1;
b.bufl:=w0:=termbufsize;
w0:=(!length(termbufhead)-4)+termbufsize;
w0*thcount;
w1+w0;
b.cl_descriptor:= w1;
w1+!length(coroutine);
b.phpool_fst:= w1;
b.ph_size:=w0:=!length(processhandler);
w0*phcount;
w1+w0;
b.phpool_top:= w1;
b.thpool_fst:= w1;
b.th_size:=w0:=!length(terminalhandler);
w0*thcount;
w1+w0;
b.thpool_top:= w1;
b.sempool_fst:=w1;
semref:=w1;
b.sem_size:=w0:=!length(semaphore);
w0 lshift 1 * corucount;
w1+w0;
w0:= !length(semaphore);
w0*phcount;
w1+w0;
b.sempool_top:=w1;
w3:=66;
w3:=(w3).word+22;
f3:=(w3).double;
w3-2;
w0:= address(b.phpool_fst);
(w3).word:= w0;
b.testmlast:=w3;
if w0:=testsegmnts > 0 then w3-512;
b.testmfst:=w3;
margin:=w3-w1;
if w3 <> 0 then
begin
w0:=b.testmlast+2;
stdvalue:=w0-w2-margin;
move(.w3.,w0:=8,w1:=address(size),w2:=address(resource));
if w3:=margin < 0 then
begin
alarm:=w2:=2763306; ! "***" !
stop:=w2;
end else alarm:=w2:=2105376; ! " " !
opmess(.w3.,w1:=address(op1));
end;
w3:=66;
w3:=(w3).word+26;
bufclaim:=w1:=(w3).byte;
w3+1;
w1:=(w3).byte;
margin:=w1-phcount-2;
if w1 <> 0 then
begin
stdvalue:=w1:=phcount+2;
move(.w3.,w0:=8,w1:=address(area),w2:=address(resource));
if w3:=margin < 0 then
begin
alarm:=w2:=2763306; ! "***" !
stop:=w2;
end else alarm:=w2:=2105376; ! " " !
opmess(.w3.,w1:=address(op1));
end;
margin:=w1:=bufclaim-(w2:=phcount lshift 1 + thcount+2);
if w1 <> 0 then
begin
stdvalue:=w2;
move(.w3.,w0:=8,w1:=address(buf),w2:=address(resource));
if w3:=margin < 0 then
begin
alarm:=w2:=2763306; ! "***" !
stop:=w2;
end else alarm:=w2:=2105376; ! " " !
opmess(.w3.,w1:=address(op1));
end;
w3:=address(spoolarea);
monitor(48); ! remove entry !
w2:=thspoolsegm+1*thcount;
w1:=phspoolsegm+1*phcount;
w2+w1;
(tail(w1:=1)).word:=w2;
monitor(40); ! create spool area !
w1:=3;
monitor(50); ! permanent entry !
monitor(52); ! create area process !
monitor(8); ! reserve area process !
if w0 <> 0 then
begin
stdvalue:=w2;
move(.w3.,w0:=8,w1:=address(spoolarea),w2:=address(resource));
alarm:=w2:=2763306;
stop:=w2;
opmess(.w3.,w1:=address(op1));
end;
w3:=address(testarea);
monitor(48); ! remove entry !
(tail(w1:=1)).word:=w2:=testsegmnts;
b.maxtestsegm:=w2;
if w2 > 0 then
begin
monitor(40); ! create testoutput area !
w1:=3;
monitor(50); ! permanent entry !
monitor(52); ! create area process !
monitor(8); ! reserve area process !
if w0 <> 0 then
begin
stdvalue:=w2;
move(.w3.,w0:=8,w1:=address(testarea),w2:=address(resource));
alarm:=w2:=2763306;
stop:=w2;
opmess(.w3.,w1:=address(op1));
end;
end;
if w0:=stop <> 0 then
begin ! the resources are not available for start up !
mode1:=w0:=1;
op1:=w0:=2;
move(.w3.,w0:=14,w1:=address(inittr),w2:=address(alarm));
opmess(.w3.,w1:=address(op1));
end;
opmess(.w3.,w1:=address(op2));
w1:=108;
b.starttime:=f1:=(w1).double;
goto initbufs;
end;
end; ! init !
end.
▶EOF◀