|
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: 245040 (0x3bd30)
Types: TextFile
Notes: flxfile
Names: »s18100:1.tprimo main «, »tprimo main «
└─⟦045fbac2b⟧ Bits:30004128/s18100.imd SW8100 MIPS/TS release 7.0
└─⟦b985b9444⟧
└─⟦this⟧
! *** tprimo ***
;
;
; niels møller jørgensen, june 1978.
; revision 2, feb. 1979.
; revision 2.1, nov. 1979. knud christensen
; revision 2.2, sep. 1981. knud christensen, edith rosenberg
; revision 2.3, mar. 1982. flemming biggas
; revision 3.0, sep. 1982. flemming biggas
; revision 4.0, apr. 1983. flemming biggas
; revision 4.1, aug. 1984. flemming biggas
; revision 5.0, aug. 1985. flemming biggas (mp + adp3270 release).
; revision 6.0 sep. 1986 flemming biggas (RC8000 Compact release).
!
printermodule
begin
!fp.no;
!branch 2,11;
!sections 70;
procedure waitmess
(.w3.; ! abs ref curr corout (return) !
w2); ! abs ref message buffer (return) !
procedure wait_status
(.w3.; ! wait for status (input operation) f8000 !
w0); ! max no of minutes to wait !
procedure sendwait
(.w3.; ! abs ref curr corout (return) !
w0 ; ! result (return) !
w1 ; ! abs ref message (call) !
w2); ! abs ref process name (call) !
procedure link
(.w3.; ! abs ref curr corout (return) !
w1 ; ! abs ref queue element (call) !
w2); ! abs ref queue head (call) !
procedure move
(.w3.; ! abs ref curr corout (return) !
w0 ; ! number of halfwords to move (call) !
w1 ; ! abs ref first halfword to move (call) !
w2); ! abs ref destination (call) !
procedure opmess
(.w3.;
w1); ! abs ref message (call) !
procedure get_branches
(.w3.; ! abs ref curr corout (return) !
w0); ! coroutine number !
procedure copyanswer
(.w3.;
w0; ! first of data area (call) !
! result from copy core (return) !
w1; ! last of data area (call) !
! no of bytes copied (return) !
w2); ! message buffer (call) !
procedure push
(.w3.; ! return:current !
w0); ! call:push element !
procedure pop
(.w3.; ! return:current !
w0); ! return:pop element !
procedure compare
(.w3.; ! abs ref curr corout (return) !
w0 ; ! no of bytes to compare (call) !
! =0 the bytes are equal !
w1 ; ! abs ref 1. string !
w2); ! abs ref 2. string !
procedure outtime
(.w3.; ! return (call) !
w2); ! abs ref string (call) !
! all registers unchanged !
procedure testout
(.w3.; ! return (call) !
w0 ; ! record length (call) !
w1 ; ! abs ref start of test record (call) !
w2); ! record kind (call) !
procedure create_tc
(.w3.;
ref ct_tc,
ct_devname; ! device name from entry !
word ct_hostno,ct_hostid;
ref ct_procref); ! abs ref ext. process descr. !
procedure remove_tc
(.w3.;
ref rt_tc);
procedure find_tc
(.w3.;
ref ft_devname;
word ft_hostno,ft_hostid;
word ft_kind; ! kind of device !
w1); ! result (return) !
! >0: abs ref tc found !
! =0: tc not found, no free tc !
! <0: tc not found, -abs ref free tc !
procedure looktransport
(.w3.; ! abs ref curr corout (return) !
w1 ; ! name of transport (call) !
w2); ! abs ref core address !
! -1 if name illegal !
! 0 if unknown (return) !
procedure puttransport
(.w3.;
w1); ! name of transport !
procedure ioworkarea
(.w3.;
w1); ! message address (call) !
procedure alloc_ifp
(.w3.; ! allocates a device (ifp) process !
word ifp_kind; ! process kind i.e. 14=printer !
word ifp_main; ! main process (f.ex."ifpmain1") device no. !
w0; ! return value from main process (return) !
w1; ! device no. ifp process (return) !
w2); ! process description address (return) !
procedure dealloc_ifp
(.w3.; ! deallocates a device (ifp) process !
word ifp_dev; ! device number of process !
word ifp_mainp); ! main process (f.ex."ifpmain1") device no. !
procedure linkupremote
(.w3.;
word lur_kind;
word lur_hostno, lur_hostid; ref lur_deviname;
w0 ; ! return value from host proc (return) !
w2); ! ref proc descr adr (return) !
procedure writeinteger
(.w3.; ! current (return) !
w0 ; ! value (call/return) !
w1 ; ! string reference (call/return) !
w2); ! radix shift 16 + positions shift 8 + fill !
procedure addtxt
(.w3.; ! current (return) !
w0 ; ! no of halfwords to merge(call/return) !
w1 ; ! ref source (call/return) !
w2); ! ref object (call/return) !
procedure outmain
(.w3.; ! current (return) !
w1 ; ! message buffer (call/return) !
w2); ! status (return) !
procedure display
(.w3.; ! current (return) !
w0 ; ! function (call) !
w1); ! device (call) !
procedure init
(.w3.); ! abs ref curr corout (return) !
procedure freetransport
(.w3.;
w1; ! name of transport (return) !
w2); ! abs ref core address !
! 0 if no free transport (return) !
procedure deftr_semantic
(.w3.; ! abs ref curr corout (return) !
w0 ; ! result , internal value (return) !
w1 ; ! abs ref transport coroutine (return) !
w2); ! abs ref transport desc. in core (call) !
procedure appl_interface
(.w3.);
procedure editout
(.w3. ; ! return: current !
w0 ; ! call:replace chars,return: result(0=ok)!
w1 ; ! call: ref out-name ret: unchd !
w2) ; ! call: ref res-name ret: unchd !
procedure create_fpr
(.w3. ; ! return: *obs obs NOT current !
ref cfpr_outdevice, ! name of gac(out)-device !
cfpr_indevice; ! name of gac(in)-device !
word cfpr_hno, ! hostno of gac host !
cfpr_hid; ! hostident of gac host !
w0 ; ! return: result (ok=0) !
w1); ! call:return: ref(free coroutine descr!
procedure remove_fpr
(.w3.; ! return: current coroutine !
w1); ! call:return: ref (fpr-coroutine) !
procedure nextchar
(.w3.;
word stp; ! abs ref word next to last input word !
w0 ; ! next char (return) !
w1 ; ! partial word (call,return) !
w2); ! abs ref next input word (call,return) !
procedure getparams
(.w3.;
ref paramtype,paramarea; ! call ref. descr param area !
word bufpntr,stoppntr; ! call ref. buffer start end !
w0); ! return comno < 12 + params !
procedure lookupremote
(.w3.;
ref lur_function, ! 2=lookup process, 3= lookup !
lur_procnameref, lur_devname;
w0; ! return value from host proc (return) !
w1; ! kind !
w2); ! abs ref area to put host address: !
! dhlinkno<12+hostno, hostid !
procedure terminalid
(.w3.; ! abs ref curr corout (return) !
w0; ! device host link no (call) !
w2); ! abs ref area to put device name (call) !
procedure find_consoldevice
(.w3.; ! abs ref curr corout (return) !
w0; ! 1= local 2= remote (call) !
w1; ! abs ref console name (call) !
! return: !
! >0 abs ref transp. corout !
! =0 not found !
! <0 removed but signed up by operator !
w2); ! abs ref device name (call) !
procedure operator
(.w3.); ! return (pseudo call) !
procedure get_block
(.w3.; ! abs ref curr corout (return) !
w0; ! max no of hwords in block (call) !
! no of hword in block (return) !
w1; ! abs ref buffer first !
w2); ! status (return) !
procedure put_block
(.w3.; ! abs ref curr corout (return ) !
w0; ! no of hwords in block (call) !
! no of hwords actually put (return) !
w1; ! abs ref buffer (call) !
w2); ! status (return) !
procedure closebs
(.w3.); ! abs ref curr corout (return) !
procedure openbs
(.w3.); ! abs ref curr corout (return) !
procedure hold
(.w3. ; ! abs ref curr corout (return) !
w0); ! if<>0 then alternate return used if tchold = 0 !
procedure oproutput
(.w3.; ! abs ref curr corout (return) !
w0 ; ! call !
! = 1 pending output !
! = 2 error output !
! return: undefined !
w1 ; ! call: text code !
! return: undefined !
w2); ! call: status !
! return: console status !
procedure updatetransport
(.w3.); ! abs ref curr corout (return) !
procedure check_devicestatus
(.w3.; ! abs ref curr corout (return) !
w0; ! answer result from monitor (call) !
w1; ! abs ref answer (call) !
w2); ! modified status (algol manner) (return) !
procedure conn_csp
(.w3.; ! makes a connection from a csp printer process
to the specified printer !
w0 ; ! result (return) !
w2); ! process description address !
procedure disconn_csp
(.w3.); ! disconnects the printer from the printer process !
procedure prcause (.w3.;w0);
procedure prlistid
(.w3.; ! abs ref curr corout (return) !
w0); ! no of halfwords in block (return) !
procedure prlistdate
(.w3.; ! abs ref curr corout(return) !
w0); ! no of halfwords in block (return) !
procedure pr
(.w3.); ! return (pseudo call) !
procedure pc
(.w3.); ! pseudo call !
procedure rd
(.w3.); ! pseudo call !
procedure tw
(.w3.); ! pseudo call !
procedure getlines
(.w3.;
w0 ; ! return: size of output buffer !
w2); ! return: status !
procedure connect_3270
(.w3.); ! connect's and reserves printer !
procedure disc_3270
(.w3.); ! disconnect's and releases printer !
procedure fpr
(.w3.); ! pseudo call !
procedure fpr_in
(.w3.); ! pseudo call !
label central_wait,wait_next,coru_found,activate,initialize,
interrupt,unin;
record controlmess
(ref cm_next,cm_prev,cm_receiver,cm_sender;
byte cm_op,cm_mode);
record coroutine
(ref c_next,c_prev,c_mbuf;
word c_w0,c_w1,c_w2;
ref c_ic;
word c_nr;
ref c_stack;
array (1:10) c_stackfill of word);
record transpcorout
(array(1:!length(coroutine)) tc_fill of byte;
ref tc_nexttc; ! static link to next transport coroutine !
byte tc_created, ! = 0 if the coroutine is idle !
tc_kind; ! kind of slow device !
word tc_hold,tc_held; ! <>0 if coroutine is waiting for operator cmd. !
ref tc_nexttr,tc_prevtr; ! queue head of transport queue !
ref tc_buf;
word tc_bufsize;
word tc_hostno,tc_hostid;
word tc_devno; ! device no. - only used by csp conn. devices !
text(11) tc_devname; ! device name ( defined in entry ) !
text(14) tc_name; ! name of external process !
text(14) tc_console; ! process name of opr. console !
word tc_ohno, ! operator host no spec. !
tc_ohid; ! operator host id spec. !
text(11) tc_devcons; ! device name of operator if remote !
word tc_ointervent; ! = 0 no intervention from operator or appl. !
! <>0 <free param> shift +<command> !
word tc_aintervent; ! = 0 no intervention from appl. !
! <> 0 intervention from appl. !
byte tc_state,tc_cause;
word tc_status;
word tc_retry;
byte tc_mode;
word tc_csegno;
ref tc_bsbuf;
word tc_bsl,tc_bsu;
text(14) tc_bsname;
word tc_areaproc; ! area process description address !
text(11) tc_qgroup,tc_qname;
word tc_transno;
word tc_workffs, tc_worknls;
double tc_bsptr;
ref tc_saveic);
record prcorout
(array (1:!length(transpcorout)) pr_fill of byte;
word pr_inpstate;
ref pr_queref;
word pr_headtrail,pr_drain,pr_select;
word pr_partial;
double pr_workptr,pr_workstartptr);
record pccorout
(array(1:!length(transpcorout)) pc_fill of byte;
word pc_inpstate);
record rdcorout
(array(1:!length(transpcorout)) rd_fill of byte;
word rd_inpstate);
record twcorout
(array(1:!length(transpcorout)) tw_fill of byte;
word tw_inpstate);
record fprincorout ! coroutin describing gac- !
! processes and links and !
! handling status (input op's !
! for the output (fpr) corouts!
(array (1:!length(coroutine)) fprinfill of byte;
ref fpr_next, ! when waiting for status the !
fpr_previous; ! fpr is linked up to fprin !
text (11) fpr_gacout, ! name of gac(out)-device !
fpr_gacin; ! name of gac(in)-device !
text (14) fpr_procout, ! name of link(out)-process !
fpr_procin; ! name of link(in)-process !
word fpr_hostid, ! hostid for gac process !
fpr_wait, ! no of coroutines waiting !
fpr_count; ! no of coroutines handling !
! printers via this gac(pair) !
! when zero the process may !
! be released/possibly removed!
word fpr_indata, ! status input buffer !
fpr_dat1); ! " -- " !
record fprcorout
(array (1:!length(transpcorout)) fpr_fill of byte;
word fpr_inpstate;
word fpr_timer;
word fpr_usedblock;
word fpr_partial;
word fpr_spartial;
ref fpr_convert; ! conversion table start !
word fpr_startsegment;
double fpr_sbsptr;
word fpr_llcudev; ! logical "line,cu,device" !
word fpr_plcudev; ! physical "line,cu,device" !
word fpr_transid; ! print head: "cu,dev,esc" !
ref fpr_stcorout; ! ref to status handling coroutine !
word fpr_status; ! status word from input or sense ready !
word fpr_devstatus); ! status bytes s1,s2 from print operation !
! please notice that "tc_devname" and "tc_name" in this !
! coroutine only are used for identification purposes !
! as they may refer to a number of devices further ident!
! -fied by "cu"(control unit) and "dev"(device number). !
! As a consequence "tc_devname" and "tc_name" are gene !
! -rated on the basis of docname(from entry) where the !
! the substring "out" is replaced by a substring (3chs.)!
! composed by: ch1=(cu+48),ch2=(dev//10+48),ch3=(dev mod 10+48)!
record oprcorout
(array(1:!length(coroutine)) opr_fill of byte;
ref opr_buf;
byte opr_dhlinkno,opr_hostno;
word opr_hostid;
word opr_savew1;
text(11) opr_devcons;
text(14) opr_console);
record tr_descr
(text(11) tr_name,tr_user,tr_sname,tr_rname,tr_bsarea;
byte tr_mode, tr_kind;
word tr_basel,tr_baseu;
double tr_bsstartptr; ! start position in bs area !
text(11) tr_qgroup, tr_qname;
ref tr_corou; ! abs ref core adr of transport coroutine !
word tr_state,tr_cause,tr_status;
double tr_charposition;
ref tr_waitmess;
word tr_removetime); ! 8388607 transport not terminated !
! 8388606 transp. not terminated, release descr. when finished !
! <8388606 transport terminated, the value indi- !
! cates when the descr is free again !
! unit=clock shift -20 = shortclock shift -1 !
record bufhead
(byte buf_op,buf_mode;
ref buf_first,buf_last;
word buf_data1);
record queuerec ! structure of element in transport coroutine queue !
(ref tq_next,tq_prev;
double tq_suspend;
word tq_transno);
record opcom
(byte opop,opmode;
text(5) optext1;
word logstatus;
text(11) optext2);
incode
word primo; ! process description address of primo !
word event_res;
ref current:=0,
event:=0,
activqfst,activqlast,
answerqfst,answerqlast,
waitqfst,waitqlast,
holdqfst,holdqlast,
tqfreefst,tqfreelast; ! head of idle transport queue elements !
ref apl_fst;
ref opr_fst, opr_top;
ref tcpool_fst, tcpool_top;
word trans_first,trans_top; ! position of transport descriptions on bs !
word trans_old:= -1; ! position on description area of last last free transp. !
word testmtop,testbuf:=0,base_event:=0;
byte testmop:=5,testmode:=0;
ref testmfst:=0,testmlast:=0;
word testsegm:=0,maxtestsegm;
double starttime;
text(14) spoolname;
byte bs_op,bs_mode;
ref bs_first,bs_last;
word bs_segno;
word waitbufs;
double trsaveperiod; ! period to save transp.descr after termination of !
! transport operation !
byte prheadtrail, ! = 0 no header and trailer page on printer lists !
! <>0 header and trailer page on printer lists !
oprtdetails; ! <>0 output details to operator !
word prlpage; ! max number of lines pr printer page !
word ans_status,ans_bytes,ans_chars,ans4,ans5,ans6,ans7,ans8;
byte faultop:=4,faultmode:=1;
text(20) faulttxt:="***fault";
byte spcomop:=2,spcommode:=8'1001;
text(8) spcomtext:="status";
byte tstcomop:= 2, tstcommode:= 8'1000;
text(8) tstcomtext:="status";
text(14) testname;
byte proc_dhlinkno, proc_hno;
word proc_hid;
text (11) proc_devname;
text (11) primo_id:= "primo'0'";
text (14) main_operator;
text (17) no_link:= " no link ";
word accept; ! when <> 0 accept transports to nonexisting device hosts !
ref firstfree,procconsole,gac_table,gac_top;
word oprt_bufl:= 104;
ref curropr, freeopr; ! work variables used by central logic !
byte strttable:= 0, strtsize:= 0; ! conversion entry inp: 0, size: 0 !
word endtable:= 0,dendt:=0; ! end of conversion table !
begin
primo:= w3; ! save primo process description address !
procconsole:= w2;
firstfree:= w1;
move(.w3.,w0:=8,w1:=w2+2,w2:=address(main_operator));
lookupremote(.w3.,w3:=2,w3:=address(main_operator),w3:=address(main_operator),
w0,w1:=8,w2:=address(proc_dhlinkno));
if w0 = 0 then
move (.w3.,w0:=8,w1:=address(main_operator),w2:=address(proc_devname)) else
terminalid(.w3.,w0:=proc_dhlinkno,w2:=address(proc_devname));
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 !
comment terminate last operation to spool area;
w1:= address(bs_op);
w3:= address(spoolname);
monitor(16); ! send message !
w1:= address(ans_status);
monitor(18); ! wait answer !
testout(.w3.,w0:=16,w1:=address(interrupt),w2:=15);
opmess(.w3.,w1:=address(faultop));
initialize:
!get 2;
init(.w3.); ! call init for allocating and initializing buffers, !
! descriptors, semaphores etc. !
goto activate;
central_wait:
w2:= base_event; ! base of event queue !
wait_next:
w3:= 0;
current:= w3;
monitor(24); ! wait next event !
if w2=testbuf then
begin
base_event:= w2;
goto wait_next;
end;
event:=w2;
event_res:= w0;
testout(.w3.,w0:=26,w1:=w2-2,w2:=6);
w2:=event;
if w0 := event_res = 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;
goto central_wait;
end ! answer !
else
begin ! message has arrived in event queue !
if w0:= (w2).cm_op = 7 then
begin ! control message !
w1:= apl_fst;
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=0 then
begin ! att message !
w0:= 0; freeopr:= w0;
if w2:=(w2).cm_sender<=0 then goto unin;
w2+2;
w1:= opr_top;
while w1-!length(oprcorout)>=opr_fst do
begin
curropr:= w1;
if w0:=(w1).c_mbuf<0 then
freeopr:= w1
else
begin ! reject if a session is allready going on !
compare(.w3.,w0:=8,w1:=address((w1).opr_console),w2);
if w0=0 ! match ! then goto unin;
end;
w1:= curropr;
end;
if w3:=freeopr=0 then goto unin;
move(.w3.,w0:=8,w1:=w2,w2:=address((w3).opr_console));
w1:= freeopr;
w2:= event;
(w1).c_w2:= w2;
(w1).c_mbuf:= w2;
monitor(26); ! get event !
goto coru_found;
end
else
begin ! operation illegal !
unin:
ans_status:= w0:= 0;
ans_bytes:= w0;
ans_chars:= w0;
w0:= 3;
w1:= address(ans_status);
w2:=event;
monitor(22); ! send answer !
testout(.w3.,w0:=2,w1,w2:=60);
goto central_wait;
end;
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;
get_branches(.w3.,w0:=(w3).c_nr);
testout(.w3.,w0:=!length(prcorout),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;
w2:=(w2:=b.current).c_nr; ! message flag = c_nr !
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:=8,w1:=(w3).c_w1,w2:=63);
goto b.activate;
end;
end; ! sendwait !
body of wait_status
begin comment link calling (fpr) coroutine to it's status
server ;
incode
double time:= 8'0000000001777777;
word wait;
ref return;
begin
return:= w3;
wait:= w0;
(w1:=b.current).c_ic:= w0:= return;
link(.w3.,w1,w2:=address((w2:=(w1).fpr_stcorout).fpr_next));
w1:= (w3).fpr_stcorout;
(w1).fpr_wait:= w0:= (w1).fpr_wait+1;
f1:= (w1:=108).double;
f1+time;
f1 lshift -19;
w1+wait;
(w3).fpr_timer:= w1;
goto b.activate;
end;
end; ! end wait_status !
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 opmess
begin
incode
double savef1,savef3;
text(14) parent;
begin
savef1:=f1;
savef3:=f3;
w1:=b.primo+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 get_branches
comment get overlay code necessary to execute coroutine;
begin
label discerror;
incode
double savef1;
word savew2; ref return;
word lastcorutype:= -1, currcorutype;
byte op:= 2, mode:= 8'1001;
text(6) t_status:= "status";
word status;
text(11) t_progname;
begin
savef1:= f1; savew2:= w2; return:= w3;
w3:= 0; f0//100;
currcorutype:= w0;
if w0<>lastcorutype then
begin
if w0>=2 then ! dev corout !
if w0:=lastcorutype<2 then
begin ! transport coroutine procedures !
!get 5;
if w0<>1 then goto discerror;
end;
case w1:= currcorutype+1 of
begin
!get 3; ! apl interface !
!get 4; ! opr interface !
!get 6; ! printer !
!get 7; ! punch !
!get 8; ! reader !
!get 8; ! cardr. , uses reader corout !
!get 9; ! tty !
!get 10; ! format printer !
end;
!test 11;
if w0<>1 then goto discerror;
lastcorutype:= w0:= currcorutype;
end;
if w2:=b.current>0 then
if w0:=(w2).c_ic=0 then
begin
case w1:= currcorutype+1 of
begin
appl_interface(.w3.);
operator(.w3.);
pr(.w3.);
pc(.w3.);
rd(.w3.);
rd(.w3.);
tw(.w3.);
begin
if w0:=(w2).c_nr<751 then fpr(.w3.) else
fpr_in(.w3.);
end;
end;
(w2).c_ic:= w3;
!test 12;
end;
f1:= savef1;
w2:= savew2;
w3:= b.current;
call w0 return;
discerror:
status:= w0;
move(.w3.,w0:=8,w1:=w3,w2:=address(t_progname));
w1:= address(op);
opmess(.w3.,w1);
end;
end; ! get branches !
body of copyanswer
comment answer operation:
copy data area into sender
send answer ;
begin
incode
word resw0, savew0,savew2;
ref return;
! general copy params !
word gc_func:= 13; ! from me to sender !
ref gc_first, gc_last;
word gc_rel:= 0;
begin
savew0:= w0; savew2:= w2; return:= w3;
gc_first:= w0; gc_last:= w1;
w1:= address(gc_func);
monitor(84); ! general copy !
resw0:= w0;
if w0=2 then
begin ! stopped !
b.ans_status:= w0:= 8'00000400;
w0:= 1;
end
else
if w0=3 then
begin ! unintel, param error !
end
else
begin
b.ans_status:= w0:= 0;
b.ans_bytes:= w1;
w0:= w1;
b.ans_chars:= w1 ashift -1 + w0;
testout(.w3.,w0,w1:=savew0,w2:=66);
w0:= 1;
end;
w1:= address(b.ans_status);
w2:= savew2;
monitor(22); ! send answer !
testout(.w3.,w0:=6,w1,w2:=61);
w0:= resw0; w1:= b.ans_bytes;
w2:= savew2; w3:= b.current;
call w0 return;
end;
end; ! copy answer !
body of outtime
begin
record timetext(word hourtxt,minutetxt);
incode
word daysize:=1687500,hoursize:=70313,minutesize:=1172;
ref return,bufref;
double savef1;
begin
savef1:=f1;
bufref:=w2;
return:=w3;
f3:=(w3:=108).double lshift -9 // daysize; ! w3:=dayno !
f1 lshift -100; ! 0 !
f2 // hoursize; ! w2:=hour !
f1 // minutesize; ! w1:=minute !
w0:=0;
f1 // 10;
bufref.minutetxt:=w1 + 48 lshift 8 + w0 + 48 lshift 8 + 32;
w1:=0;
f2 // 10;
bufref.hourtxt:=w2 + 48 lshift 8 + w1 + 48 lshift 8 + 46;
f1:=savef1;
w2:=bufref;
w3:=return;
end;
end;
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;
array (1:8) testansw of word;
word savew2;
begin
savef1:=f1;
if w0>500 then w0:= 500;
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;
if w2:= b.testbuf<>0 then
begin
b.testbuf:= w1:= 0;
b.base_event:= w1;
testansw(w1:=1);
monitor(18); ! wait answer !
if w2:=1 lshift w0 or (w1).word <> 2 then
begin
b.testmlast:=w1:=b.testmfst;
w1:= address(b.tstcomop);
(w1).logstatus:=w2;
opmess(.w3.,w1);
end;
end;
w1:= address(b.testmop);
w3:= address(b.testname);
monitor(16); ! send message !
b.testbuf:= w2; ! save buffer address !
if w1:=b.testsegm+1 = b.maxtestsegm then w1:=1;
b.testsegm:=w1;
bufrel:=w0:=0;
w1:= b.testmfst;w1+512;
if w1>=b.testmtop then w1-1024;
b.testmfst:= w1;
w1+510;b.testmlast:= w1;
end;
f1:=savef1;
if w0>500 then w0:= 500;
w2:=savew2;
w3:=b.testmfst+bufrel;
(w3).reclength:=w0+!length(testhead);
(w3).reckind:=w2;
bufrel:= w1:= bufrel+w0;
w1:= b.current;
if w1<>0 then w1:=(w1).c_nr;
(w3).testref:=w1;
w1:=108;
f1:=(w1).double-b.starttime lshift -7;
(w3).time:=w1;
f1:=savef1;
if w0>500 then w0:= 500;
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:
if w2:= b.testbuf<>0 then
begin
testansw(w1:=1);
monitor(18);
b.testbuf:= w2:= 0;
end;
(w3:=b.testmfst+bufrel).word:=w0:=-2;
w3:=address(b.testname);
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 push
begin
incode
ref return;
double savef2;
begin
return:= w3;
savef2:= f2;
w3:=b.current;
w1:=address((w3).c_stack);
w2:=(w1).word+2;
(w2).word:=w0;
(w1).word:=w2;
f2:=savef2;
call w0 return;
end;
end; ! end push !
body of pop
begin
incode
ref return;
double savef2;
begin
return:=w3;
savef2:=f2;
w3:=b.current;
w1:=address((w3).c_stack);
w2:=(w1).word;
w0:=(w2).word;
(w1).word:=w2-2;
f2:=savef2;
call w0 return;
end;
end; ! end pop !
body of compare
begin
incode
word savew1, savew2;
ref return;
begin
savew1:= w1; savew2:= w2; return:= w3;
w3:= w1+w0;
w0:= 0;
while w1<w3 do
begin
w0:= (w1).word;
w0-(w2).word;
w1+2;
w2+2;
if w0<>0 then w1:= w3;
end;
w1:= savew1;
w2:= savew2;
w3:= b.current;
call w0 return;
end;
end; ! compare !
body of create_tc
begin
incode
double savef1;
word savew2;
ref return;
begin
savef1:= f1;
savew2:= w2;
return:= w3;
w1:= (w3).ct_tc;
w0:= 0;
(w1).c_ic:= w0;
(w1).tc_created:= w0:= 1;
(w1).tc_hostno:= w0:= (w3).ct_hostno;
(w1).tc_hostid:= w0:= (w3).ct_hostid;
w2:= address((w1).tc_devname);
move(.w3.,w0:=8,w1:=return.ct_devname,w2);
w1:= return.ct_tc; w2:= address((w1).tc_name);
w1:= return.ct_procref; w1+2;
move(.w3.,w0,w1,w2);
w1:= return.ct_tc;
w2:= address((w1).tc_console);
if w0:=(w2).word=0 then ! no operator !
begin
w3:= address((w1).tc_qgroup);
(w3).word:= w0;
if w0:=(w1).tc_kind=8 ! tty ! then
begin
move(.w3.,w0:=8,w1:=address((w1).tc_name),w2);
end;
end;
link(.w3.,w1:=return.ct_tc,w2:=address(b.activqfst));
testout(.w3.,w0:=!length(transpcorout),w1,w2:=53);
f1:= savef1;
w2:= savew2;
w3:= return;
end;
end; ! create_ct !
body of remove_tc
begin
incode
double savef1;
text (11) zero := "'0''0''0'";
word savew2;
ref return;
begin
savef1:= f1;
savew2:= w2;
return:= w3;
w0:=-8388607;w1:=8388605;
w3:= address(zero);
monitor(72); ! set catalog base !
w3:= return;
w1:= (w3).rt_tc;
w0:= 0;
(w1).c_mbuf:= w0;
(w1).tc_created:= w0;
w3:= address((w1).tc_name);
if w0:=(w1).tc_kind<>15 then monitor(10); ! release !
if w2:= (w1).tc_hostno<>0 then
begin ! remote !
monitor(64); ! remove process !
!test 30;
end;
if w0:=(w1).tc_kind=8 ! tty ! then
begin ! remove operator !
w2:= address((w1).tc_console);
(w2).word:= w0:= 0;
w2:= address((w1).tc_devcons);
(w2).word:= w0;
end;
link(.w3.,w1,w2:=address(b.waitqfst));
testout(.w3.,w0:=!length(prcorout),w1,w2:=54);
f1:=savef1;
w2:= savew2;
w3:= return;
end;
end; ! remove_tc !
body of remove_fpr
begin comment this procedure decreases the acces count
of the associated gac_access_entry. - if the
count becomes zero the format printer processes
(gac's) are released/possibly removed and the
status handling coroutine is made free;
incode
ref return,fpr_ref;
word savew0,savew2;
begin
return := w3;
fpr_ref:= w1;
savew0 := w0;
savew2 := w2;
comment decrease count;
w2 := (w1).fpr_stcorout;
(w2).fpr_count := w0 := (w2).fpr_count -1;
if w0 < 1 then
begin comment release/remove entries and free
status handling coroutine;
link(.w3.,w1:=w2,w2:=address(b.waitqfst));
w2:=w1;w1:=fpr_ref;
w0 := (w1).tc_hostid;
if w0=0 then
begin comment local device - release processes;
w3:=address((w2).fpr_procin);
monitor(10);
w3:=address((w2).fpr_procout);
monitor(10);
end else
begin comment remote device - remove processes;
w3:=address((w2).fpr_procin);
monitor(64);
w3:=address((w2).fpr_procout);
monitor(64);
end;
w3:= address((w2).fpr_gacout);
(w3).word:= w0:= 0;
end;
testout(.w3.,w0:=!length(fprincorout),w1:=w2,w2:=54);
w0:= savew0;
w2:= savew2;
w1:= fpr_ref;
w3:= b.current;
call w0 return;
end;
end; ! end remove_fpr !
body of find_tc
begin
label found;
incode
word savew0, savew2, freetc;
ref return;
begin
savew0:= w0;
savew2:= w2;
return:= w3;
freetc:= w0:= 0;
w1:= b.tcpool_fst;
while w1<b.tcpool_top do
begin
if w0:=(w1).tc_kind=return.ft_kind then
begin
w0:=(w1).tc_hostid - return.ft_hostid;
if w0 = 0 then w0:= (w1).tc_hostno - return.ft_hostno;
if w0 = 0 then
begin
compare(.w3.,w0:=8,w1+!position(tc_devname),w2:=return.ft_devname);
w1-!position(tc_devname);
if w0=0 then goto found;
end;
if w0:=freetc=0 then
if w0:=(w1).tc_created=0 ! not created ! then
begin
w2:= address((w1).tc_console);
if w0:=(w2).word=0 then freetc:= w1; ! no operator logged in !
end;
end;
w1:= (w1).tc_nexttc;
end;
w1:= freetc;
found:
if w0:=(w1).tc_created=0 then -(w1);
w0:= savew0;
w2:= savew2;
w3:= return; ! w3 not equal to current corout++++++ !
!test 70;
end;
end; ! find_tc !
body of looktransport
begin
incode
word savew0, savew1;
ref return;
begin
savew0:= w0; savew1:= w1; return:= w3;
! check legality of transport name !
w2:= 1;
if w1<b.trans_first then w2:= -1;
if w1>=b.trans_top then w2:= -1;
w1 extract 9;
while w1>0 do w1-!length(tr_descr);
if w1<>0 then w2:= -1;
if w2>0 then
begin
w1:=savew1 ashift -9;
if w1<>b.bs_segno then
begin
if w0:=b.bs_op=5 then
begin comment output segment;
ioworkarea(.w3.,w1:=address(b.bs_op));
end;
comment now input wanted segment;
b.bs_op:=w0:=3;
b.bs_segno:=w1:= savew1 ashift -9;
ioworkarea(.w3.,w1:=address(b.bs_op));
end;
w2:=savew1 extract 9;w2+b.bs_first;
w1:=108;
f1:=(w1).double lshift -20;
if w0:=(w2).tr_waitmess=0 then
if w0:=(w2).tr_removetime<w1 then
w2:=0; ! entry free !
end;
w0:=savew0;
w1:=savew1;
w3:=b.current;
!test 305;
call w0 return;
end;
end; ! end looktransport !
body of puttransport
begin
incode
ref return;
word savew0, savew1, savew2;
begin
savew0:= w0; savew1:= w1; savew2:= w2; return:= w3;
b.bs_op:= w0:= 5;
w1:= savew1 extract 9; w1+b.bs_first;
testout(.w3.,w0:=!length(tr_descr),w1,w2:=68);
w0:= savew0;
w1:= savew1;
w2:= savew2;
w3:= b.current;
call w0 return;
end;
end; ! puttransport !
body of ioworkarea
comment
transport a segment to or from the spool area
;
begin
incode
word status, bytes, chars, a4, a5, a6, a7, a8;
double savef1;
ref savew2, return;
begin
savef1:= f1;
savew2:= w2;
return:= w3;
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; w2:= savew2;
w3:= b.current;
call w0 return;
end;
end; ! ioworkarea !
body of alloc_ifp
begin comment please refer to: RCSL No. 991 10228 ,
RC8000/IFP Main Process , Reference Manual
page 8.ff. (connect operation).;
incode
word zero:= 0;
word ifp_m0:= 24576, ifp_m2, ifp_m4:= 255, ifp_m6:= -1, ifp_m8:= 8192;
text (11) ifpmain;
word ifpnta, result;
word ifp_a0, ifp_a2, ifp_a4, ifp_a6, ifp_a8, ifp_a10, ifp_a12, ifp_a14;
ref return, ifp_ref;
word ifpdev;
begin
return:= w3;
ifpdev:= w0:= -1;
result:= w0:= 3;
w0:= 0;ifp_ref:= w0;
if w0:= return.ifp_kind = 14 ! printer ! then
begin
w1:= (w2:=74).word;
w1 + return.ifp_main + return.ifp_main;
if w0:= (w1:=(w1).word).word = 26 ! ifp main process ! then
begin
move (.w3.,w0:= 8, w1+2, w2:= address(ifpmain));
ifpnta:= w0:= 0;
ifp_m2:= w0:= 8; ! device type := printer !
w3:= address(zero);
w0:= -8388607;w1:= 8388605;
monitor (72); ! set catalog base !
w1:= address (ifp_m0);
testout (.w3.,w0:=16, w1, w2:= 9);
w3:= address (ifpmain);
monitor (16); ! send message !
w1:= address (ifp_a0);
monitor (18); ! wait answer !
result:= w0;
testout (.w3., w0:= 10, w1:= address(result), w2:= 67);
if w0:= result = 1 then
begin
if w0:= ifp_a0 = 0 ! status ! then
begin comment ok;
result:= w0;
ifpdev:= w0:= ifp_a2; ! ifp device no !
w1:= (w2:=74).word;
w1 + ifp_a2 + ifp_a2;
w2:= (w1).word;
ifp_ref:= w2; ! process description address !
end;
end;
end;
end;
w0:= result;
w1:= ifpdev; ! device number of ifp process !
w2:= ifp_ref; ! process description address of ifp process !
w3:= return;
end;
end; ! end alloc ifp !
body of dealloc_ifp
begin comment please refer to: RCSL No. 991 10228 ,
RC8000/IFP Main Process , Reference Manual
page 8.ff. (disconnect operation).;
incode
word ifp_m0:= 40960, ifp_m2;
text (11) ifpmain;
word ifpnta;
word ifp_a0, ifp_a2, ifp_a4, ifp_a6, ifp_a8, ifp_a10, ifp_a12, ifp_a14;
ref return;
word savew0, savew1, savew2;
begin
return:= w3;
savew0:= w0;savew1:= w1;savew2:= w2;
w1:= (w2:=74).word;
w1 + return.ifp_mainp + return.ifp_mainp;
if w0:= (w1:=(w1).word).word = 26 ! ifp main process ! then
begin
move (.w3.,w0:= 8, w1+2, w2:= address(ifpmain));
ifpnta:= w0:= 0;
ifp_m2:= w0:= return.ifp_dev;
w1:= address (ifp_m0);
w3:= address (ifpmain);
monitor (8); ! reserve process - *** to removed later *** !
w2:= 1; ! appl. interface coroutine !
monitor (16); ! send message !
w1:= address (ifp_a0);
monitor (18); ! wait answer !
monitor (10); ! release process - *** to be removed later *** !
end;
w0:= savew0;
w1:= savew1;
w2:= savew2;
w3:= return;
end;
end; ! end dealloc ifp !
body of linkupremote
begin
incode
word savew1, return;
text(14) host:= "host";
! operation message !
word om_op:= 2'000000000001000000001100;
ref om_first, om_last;
byte om_unu1, om_hostno;
word om_hostid;
byte om_homereg:= 0, om_netid:= 0;
! operation output !
word oo_modekind,
oo_timeoutsbuffers:= 0,
oo_bufsize:= 0;
text(11) oo_deviname;
word oo_unu1;
word oo_net1:= 0, oo_net2:= 0, oo_unu2;
! operation answer !
word oa_return,oa_bytes,oa_chars,oa_net1,oa_net2,oa_net3,oa_d1,oa_d2;
! operation input !
word oi_kind,oi_bufs,oi_bufsize;
text(11) oi_deviname;
word oi_net1,oi_net2,oi_net3;
ref oi_procdescr;
begin
savew1:= w1; return:= w3;
om_hostno:= w0:= (w3).lur_hostno;
om_hostid:= w0:= (w3).lur_hostid;
oo_modekind:= w0:= (w3).lur_kind;
move(.w3.,w0:=8,w1:=(w3).lur_deviname,w2:=address(oo_deviname));
! move output to input area !
move(.w3.,w0:=22,w1:=address(oo_modekind),w2:=address(oi_kind));
om_first:= w2;
w2+20;
om_last:= w2;
testout(.w3.,w0:=22,w1,w2:=66);
w1:= address(om_op);
testout(.w3.,w0:=12,w1,w2:=2);
w3:= address(host);
monitor(16); ! send message !
w1:= address(oa_return);
monitor(18); ! wait answer !
if w0<>1 then oa_return:= w0:= 1; ! a little bit dirty !
testout(.w3.,w0:=12,w1,w2:=67);
testout(.w3.,w0:=22,w1:=address(oi_kind),w2:=66);
w0:= oa_return;
w2:= oi_procdescr;
w1:= savew1;
w3:= return;
end;
end; ! link up remote !
body of addtxt
begin
incode
double savef1;
word savew2;
ref return;
begin
savef1:= f1;
savew2:= w2;
return:= w3;
w3:= w1+w0;
while w1<w3 do
begin
w0:= (w1).word;
(w2).word:= w0 or (w2).word;
w1+2;w2+2;
end;
f1:= savef1;
w2:= savew2;
w3:= b.current;
call w0 return;
end;
end; ! end addtxt !
body of lookupremote
begin
label exit;
incode
word savew1, savew2;
ref return;
text(14) host:= "host";
! operation message !
word om_op;
ref om_first, om_last;
ref om_procref;
word om_hostid,
om_netid;
! operation output !
word oo_modekind:=14,
oo_timeoutsbuffers:= 0,
oo_bufsize:= 0;
text(11) oo_deviname;
word oo_unu1;
word oo_net1:= 0, oo_net2:= 0, oo_unu2, devtop;
! operation answer !
word oa_return,oa_bytes,oa_chars,oa_net1,oa_net2,oa_net3,oa_d1,oa_d2;
! operation input !
word oi_kind,oi_bufs,oi_bufsize;
text(11) oi_deviname;
word oi_net1,oi_net2,oi_net3;
ref oi_procdescr;
begin
savew1:= w1; savew2:= w2; return:= w3;
w0:= 0; om_procref:= w0;
if w0:=(w3).lur_function=4 then
begin
w3:=(w3).lur_procnameref;
w0:= (w3).word;
om_procref:= w0;
om_hostid:=w0:= (w3+2).word;
om_netid:= w0:= 0;
if w0:= om_hostid = 0 then
begin
if w0:= om_procref <> 0 then
begin comment csp device;
w2:= (w2:=(w2:=74).word + w0 + w0).word;
if w0:= (w2).word = 26 then
begin comment ifpmain process;
oa_return:= w0:= 0;
w0:= om_procref; ! hostno = ifpmain device no !
oa_net1:= w0;
oa_net2:= w0:= 0; ! hostid = 0 !
goto exit;
end;
end;
end;
w0:= 2'000000000001000000000110;
w3:=return;
end else
if w0=2 then w0:= 2'000000000001000000000101 else
w0:= 2'000000000001000000000111;
om_op:= w0;
w3:= (w3).lur_procnameref;
monitor(4); ! get process description !
if w0<>0 then om_procref:= w0;
move(.w3.,w0:=8,w1:=return.lur_devname,w2:=address(oo_deviname));
! move output to input area !
move(.w3.,w0:=22,w1:=address(oo_modekind),w2:=address(oi_kind));
om_first:= w2;
w2+20;
om_last:= w2;
testout(.w3.,w0:=22,w1,w2:=66);
w1:= address(om_op);
testout(.w3.,w0:=12,w1,w2:=2);
w3:= address(host);
monitor(16); ! send message !
w1:= address(oa_return);
monitor(18); ! wait answer !
if w0<>1 then oa_return:= w0:= 1; ! a little bit dirty !
testout(.w3.,w0:=12,w1,w2:=67);
testout(.w3.,w0:=22,w1:=address(oi_kind),w2:=66);
w0:= oa_return;
if w0 zeromask 12288 ! local/remote link present ! then
begin comment link is not known to ncp, try csp;
if w1:= om_procref > 0 then
begin comment try csp;
w0:= (w1).word;
if w0 = 8 then w0:= 28;
if w0 = 28 then
begin comment csp device process;
w2:= (w1+10).word; ! w2 = proc. descr. addr. of ifp main proc. !
w1:= (w1:=76).word;
devtop:= w1;
w1:= (w1:=74).word; ! w1 = nta of device 0 !
w3:= 0; ! i:= 0 !
while w1 < devtop do
begin
if w0:= (w1).word = w2 then w1:= devtop else
begin
w1+2;
w3+1; ! i:= i + 1 !
end;
end;
! w3 is now device no of ifp main proc. !
oa_net1:= w3; ! job host linkno := ifp main devno. !
oa_net2:= w3:= 0; ! device host id:= 0 !
oa_return:= w3;
testout (.w3.,w0:=10,w1:=address(oa_return),w2:=68);
end;
end;
end;
exit: w0:= oa_return;
w1:= oi_kind;
w2:= savew2;
(w2).word:= w3:= oa_net1;
w2+2;
(w2).word:= w3:= oa_net2;
w2:= savew2;
w3:= return;
end;
end; ! look up remote !
body of terminalid
comment convert devicehost linkno to the corresponding devicename.
+++++++ This procedure exists only because the host procedure
+++++++ lookup link is not implemented yet. the procedure is very dirty
+++++++ because it uses an implementational detail in the device
+++++++ host ;
begin
incode
double savef1;
word savew2;
ref return;
text(11) terminal:= "terminal";
begin
savef1:= f1; savew2:= w2; return:= w3;
w0+1; ! devicename = "terminal" concat text(devicehost linkno + 1) !
w3:= 0;
f0//10;
w2:= address(terminal);
w2+4;
if w0=0 then
begin
(w2).word:= w1:= (w2).word lshift -8 lshift 8 + 48 + w3;
w2+2;
(w2).word:= w1:= 0;
end
else
begin
(w2).word:= w1:= (w2).word lshift -8 lshift 8 + 48 + w0;
w2+2;
(w2).word:= w1:= w3+48 lshift 16;
end;
move(.w3.,w0:=8,w1:=address(terminal),w2:=savew2);
f1:= savef1; w3:= b.current;
call w0 return;
end;
end;
body of writeinteger
begin comment
w3: current (return)
w0: value (call/return)
w1: ref. string (call/return)
w2: radix shift 16 + positions shift 8 + fill char (call/return);
incode
ref return,
txtref;
word savew2;
word savew0;
word fill;
word radix;
word posit;
word index;
word sign;
array (1:24) digit of byte;
begin
return:= w3;
savew2:= w2;
txtref:= w1;
savew0:= w0;
fill:= w2 extract 8;
posit:= w2:=savew2 lshift -8 extract 8;
radix:= w2:=savew2 lshift -16 extract 8;
if w2:=radix=10 then
begin
if w0<0 then
begin
w1:= 45;
-(w0);
end else w1:= fill;
end else w1:= fill;
sign:= w1;
for w2:= posit step 1 downto 1 do
begin
index:= w2;
w3:= 0;
f0//radix;
if w3=0 then
begin
if w0=0 then
begin
if w2=posit then w3:=48 else
begin
w3:=sign;
sign:= w1:= fill;
end;
end else w3:= 48;
end else if w3>9 then w3+55 else w3+48;
(digit(w2)).byte:= w3;
w2:= index;
end;
if w0<>0 then (digit(w2:=1)).byte:= w0:=42;
w1:= txtref-2;
for w3:= 1 step 1 upto posit do
begin
index:= w3;
w0:= (digit(w3)).byte;
w3:= index;
w2:=0;
f3//3;
case w2+1 of
begin
(w1).word:= w0+(w1).word;
(w1+2).word:= w0 lshift 16;
(w1).word:= w0 lshift 8+(w1).word;
end;
w3:= index;
end;
w3:=0;w0:=posit;
f0//3;
if w3=0 then (w1+2).word:= w3;
w0:=savew0;
w2:=savew2;
w1:= txtref;
w3:= b.current;
call w0 return;
end;
end; ! writeinteger !
body of outmain
begin
label rep_main;
incode
ref return,
bufref;
word size, status;
byte main_op:= 5, main_md:= 0; ! output operation !
word main_fs, ! first address !
main_ls; ! last address !
begin
if w0:= b.oprtdetails zeromask 2'010 then
begin comment no output to main operator;
return:= w3;
w3:= b.current;
(w3).tc_hold:= w0:= 0; ! dont hold !
w2:= 2; ! normal answer !
call w0 return;
end;
return:= w3;
bufref:= w1;
rep_main:
push(.w3.,w0:=return); ! save return !
push(.w3.,w0:=bufref); ! save bufref !
move(.w3.,w0:=6,w1:=bufref,w2:=address(main_op));
size:= w0:= main_ls-main_fs+2;
push(.w3.,w0:=size);
w2:=address(b.main_operator);
sendwait(.w3.,w0,w1:=address(main_op),w2);
w1:= 1 lshift w0;
if w1=2 then w1 or b.ans_status;
status:= w1;
pop(.w3.,w0);size:= w0;
pop(.w3.,w0);bufref:=w0;
pop(.w3.,w0);return:=w0;
if w1 and 2<>0 ! normal answer ! then w0:= b.ans_bytes else w0:=-1;
if w0<size then
begin
if w1:= status and 2'110000<>0 ! does not exist, dicconnected ! then
begin
linkupremote(.w3.,w0:=8,w0:=b.proc_hno,w0:=b.proc_hid,
w0:=address(b.proc_devname),w0,w2);
if w0=4096 ! created ! then
begin
move(.w3.,w0:=8,w1:=w2+2,w2:=address(b.main_operator));
goto rep_main;
end;
end else
begin
if w0>=0 then goto rep_main;
end;
end;
w0:=size;
w2:=status;
w1:=bufref;
w3:=b.current;
call w0 return;
end;
end; ! end outmain !
!branch 1,2;
body of init
begin
label allocate,initbufs;
incode
ref return;
byte opversion:=16,modeversion:= 8'0140;
text(14) textversion:=
! *** primo *** ! "release: 6.0"
;
word
! date of version ! verdate:= 860901,
comment ===trimstart;
! date of options ! options := 0,
! number of printer coroutines ! prcount := 3,
! size of printer buffer (halfwords) ! prbufsize := 128,
! leading and trailing page on printer lists ! prltpage := 1,
! max lines pr printer page ! prlinepage := 100,
! number of punch coroutines ! pccount := 1,
! size of punch buffer (halfwords) ! pcbufsize := 128,
! number of reader coroutines ! rdcount := 1,
! size of reader buffer (halfwords) ! rdbufsize := 128,
! number of cardreader coroutines ! cdcount := 1,
! size of cardreader buffer (halfwords) ! cdbufsize := 108,
! number of tty coroutines (halfwords) ! twcount := 1,
! size of tty buffer ! twbufsize := 104,
! no of format printer coroutines ! fprcount := 1,
! size of fpr buf incl. 10 hlw. hd/tr ! fprbufsize := 172,
! no of operator coroutines ! oprcount := 2,
! no of transport description segmnts ! trsegm := 100,
! size of testoutput area ! testsegmnts := 42,
! transport description save period ! trsaveminut := 60,
! no of waiting transports ( total ) ! waittrans := 50,
! no of pending wait operations ! waitops := 5,
! operator output specification: ! oprdetails := 2,
! bit 23: output information concerning transport termination. !
! bit 22: route output to main operator if not signed up or trouble!
! accept transports to nonexisting dev. host ! taccept := 0,
comment ===trimfinis;
spoolpointer:=0;
text(11) testarea:= "primotest", spoolarea:= "primospool",
pseudoname:= "primosys";
array(1:10) tail of word := 0 0 0 0 0 0 0 0 0 0;
ref queuefst,queuetop;
ref tcbufref, oprbufref;
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";
byte funcop:= 16, funcmode:= 0;
text(21) functext:="***function 1,2,3,4,5";
byte inittrop:= 2, inittrmode:= 1;
text(20)inittr:=" ***init troubles";
byte op2:=16,mode2:=0;
text(20) started:="started";
word pos_nine:= 9, neg_nine:= -9;
begin
return:=w3;
goto allocate;
initbufs:
w0:= 0;
w2:= b.gac_top;
for w2-2 step 2 downto b.bs_first do (w2).word:= w0;
w1:= queuefst;
w2:= address(b.tqfreefst);
while w1<queuetop do
begin
(w1).tq_next:= w1;
(w1).tq_prev:= w1;
link(.w3.,w1,w2);
w1+!length(queuerec);
end;
! init appl. interface corout !
w1:= b.apl_fst;
(w1).c_next:= w1;
(w1).c_prev:= w1;
(w1).c_nr:= w0:= 1;
link(.w3.,w1,w2:=address(b.activqfst));
! init opr. interface !
w1:= b.opr_fst;
if w0:=oprcount>0 then
for w0:=1 step 1 upto oprcount do
begin
(w1).c_next:= w1;
(w1).c_prev:= w1;
(w1).c_nr:= w3:= w0+100;
(w1).c_stack:= w3:= address((w1).c_stack);
(w1).opr_buf:= w2:= oprbufref;
w2+b.oprt_bufl+(!length(bufhead)-2);
oprbufref:= w2;
link(.w3.,w1,w2:=address(b.activqfst));
w1+!length(oprcorout);
end;
w1:= b.tcpool_fst;
if w3:=prcount>0 then
for w3:=1 step 1 upto prcount do
begin
(w1).c_next:=w1;
(w1).c_prev:=w1;
(w1).c_nr:=w2:=w3+200;
(w1).pr_headtrail:= w0:= prltpage;
(w1).tc_kind:= w0:= 14;
(w1).tc_nexttr:= w0:= address((w1).tc_nexttr);
(w1).tc_prevtr:= w0;
(w1).tc_buf:=w2:=tcbufref;
(w1).c_stack:=w0:=address((w1).c_stack);
w2+prbufsize+(!length(bufhead)-2);
(w1).tc_bsbuf:=w2;
w2+512;
tcbufref:= w2;
(w1).tc_bufsize:= w0:= prbufsize;
w0:= w1+!length(prcorout);
(w1).tc_nexttc:= w0;
w1:= w0;
end;
if w3:=pccount>0 then
for w3:= 1 step 1 upto pccount do
begin
(w1).c_next:=w1;
(w1).c_prev:=w1;
(w1).c_nr:=w2:=w3+300;
(w1).tc_kind:= w0:= 12;
(w1).tc_nexttr:= w0:= address((w1).tc_nexttr);
(w1).tc_prevtr:= w0;
(w1).tc_buf:=w2:=tcbufref;
(w1).c_stack:=w0:=address((w1).c_stack);
w2+pcbufsize+(!length(bufhead)-2);
(w1).tc_bsbuf:=w2;
w2+512;
tcbufref:= w2;
(w1).tc_bufsize:= w0:= pcbufsize;
w0:= w1+!length(pccorout);
(w1).tc_nexttc:= w0;
w1:= w0;
end;
if w3:=rdcount>0 then
for w3:=1 step 1 upto rdcount do
begin
(w1).c_next:=w1;
(w1).c_prev:=w1;
(w1).c_nr:=w2:=w3+400;
(w1).tc_kind:= w0:= 10;
(w1).tc_nexttr:= w0:= address((w1).tc_nexttr);
(w1).tc_prevtr:= w0;
(w1).tc_buf:=w2:=tcbufref;
(w1).c_stack:=w0:=address((w1).c_stack);
w2+rdbufsize+(!length(bufhead)-2);
(w1).tc_bsbuf:=w2;
w2+512;
tcbufref:= w2;
(w1).tc_bufsize:= w0:= rdbufsize;
w0:= w1+!length(rdcorout);
(w1).tc_nexttc:= w0;
w1:= w0;
end;
if w3:=cdcount>0 then
for w3:= 1 step 1 upto cdcount do
begin ! use reader corout !
(w1).c_next:= w1;
(w1).c_prev:= w1;
(w1).c_nr:= w2:= w3+500;
(w1).tc_kind:= w0:= 16;
(w1).tc_nexttr:= w0:= address((w1).tc_nexttr);
(w1).tc_prevtr:= w0;
(w1).tc_buf:= w2:= tcbufref;
(w1).c_stack:=w0:=address((w1).c_stack);
w2+cdbufsize+(!length(bufhead)-2);
(w1).tc_bsbuf:=w2;
w2+512;
tcbufref:= w2;
(w1).tc_bufsize:= w0:= cdbufsize;
w0:= w1+!length(rdcorout);
(w1).tc_nexttc:= w0;
w1:= w0;
end;
if w3:=twcount>0 then
for w3:= 1 step 1 upto twcount do
begin
(w1).c_next:= w1;
(w1).c_prev:= w1;
(w1).c_nr:= w2:= w3+600;
(w1).tc_kind:= w0:= 8;
(w1).tc_nexttr:= w0:= address((w1).tc_nexttr);
(w1).tc_prevtr:= w0;
(w1).tc_buf:= w2:= tcbufref;
(w1).c_stack:=w0:=address((w1).c_stack);
w2+twbufsize+(!length(bufhead)-2);
(w1).tc_bsbuf:=w2;
w2+512;
tcbufref:= w2;
(w1).tc_bufsize:= w0:= twbufsize;
w0:= w1+!length(twcorout);
(w1).tc_nexttc:= w0;
w1:= w0;
end;
if w3:=fprcount>0 then
for w3:=1 step 1 upto fprcount do
begin
(w1).c_next:=w1;
(w1).c_prev:=w1;
(w1).c_nr:=w2:=w3+700;
(w1).tc_kind:=w0:=15; ! to avoid confusion with printer processes!
(w1).tc_nexttr:= w0:= address((w1).tc_nexttr);
(w1).tc_prevtr:= w0;
(w1).c_stack:= w0:= address((w1).c_stack);
(w1).tc_buf:=w2:=tcbufref;
w2+fprbufsize+(!length(bufhead)-2);
(w1).tc_bsbuf:= w2;
w2+512;
tcbufref:= w2;
(w1).tc_bufsize := w0 := fprbufsize-8; ! - ( size of header and evnt. trail )!
w0:=w1+!length(fprcorout);
(w1).tc_nexttc:= w0;
w1:=w0;
end;
if w3:=fprcount>0 then
for w3:=1 step 1 upto fprcount do
begin
(w1).c_next:=w1;
(w1).c_prev:=w1;
(w1).c_nr:=w2:=w3+750;
(w1).fpr_next:= w0:= address((w1).fpr_next); ! queuehed for waiting fpr coroutines !
(w1).fpr_previous:= w0;
w0:= !length(fprincoroutine);
w1+w0;
end;
testout(.w3.,w0:=50,w1:=address(verdate),w2:=69);
testout(.w3.,w0:= 150,w1:=b.primo-4,w2:=8);
b.bs_op:= w0:= 5; ! clear work area !
w1:= address(b.bs_op);
w2:= b.trans_top ashift neg_nine;
for w2-1 step 1 downto 0 do
begin
b.bs_segno:= w2;
ioworkarea(.w3.,w1);
end;
b.bs_segno:= w0:= -1;
b.bs_op:= w0:= 3;
call w0 return;
allocate:
opmess(.w3.,w1:=address(opversion));
w3:= b.primo+29; ! test function mask !
if w0:=(w3).byte onemask 8'3700 then
else
begin
stop:= w0:= 1;
opmess(.w3.,w1:=address(funcop));
end;
w1:= 108;
b.starttime:= f1:= (w1).double;
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.holdqfst:= w0:= address(b.holdqfst);
b.holdqlast:= w0;
b.tqfreefst:= w0:= address(b.tqfreefst);
b.tqfreelast:= w0;
b.bs_first:= w1:= b.firstfree;
w1+510;
b.bs_last := w1;
w1+2;
oprbufref:= w1; ! buffer for operator !
w0:=(!length(bufhead)-2)+b.oprt_bufl;
w0*oprcount;
w1+w0;
tcbufref:=w1;
w0:=(!length(bufhead)-2)+prbufsize+512;
w0*prcount;
w1+w0;
w0:=(!length(bufhead)-2)+pcbufsize+512;
w0*pccount;
w1+w0;
w0:=(!length(bufhead)-2)+rdbufsize+512;
w0*rdcount;
w1+w0;
w0:=(!length(bufhead)-2)+cdbufsize+512;
w0*cdcount;
w1+w0;
w0:=(!length(bufhead)-2)+twbufsize+512;
w0*twcount;
w1+w0;
w0:= (!length(bufhead)-2)+fprbufsize+512;
w0*fprcount;
w1+w0;
queuefst:= w1;
w0:= !length(queuerec);
w0*waittrans;
w1+w0;
queuetop:= w1;
b.apl_fst:= w1;
w1+!length(coroutine);
b.opr_fst:= w1;
w0:= !length(oprcorout)*oprcount;
w1+w0;
b.opr_top:= w1;
b.tcpool_fst:= w1;
w0:= !length(prcorout)*prcount;
w1+w0;
w0:=!length(pccorout)*pccount;
w1+w0;
w0:=!length(rdcorout)*rdcount;
w1+w0;
w0:=!length(rdcorout)*cdcount;
w1+w0;
w0:=!length(twcorout)*twcount;
w1+w0;
w0:= !length(fprcorout)*fprcount;
w1+w0;
b.tcpool_top:= w1;
b.gac_table := w1;
w0 := !length(fprincorout)*fprcount;
w1+w0;
b.gac_top := w1;
w3:=b.primo+22;
f3:=(w3).double;
w3-2;
b.testmtop:=w3;
if w0:= testsegmnts>0 then
begin
w3-512;
b.testmlast:= w3;
w3-510;
b.testmfst:= w3;
end else
begin
b.testmlast:= w3;
b.testmfst:= w3;
end;
margin:=w3-w1;
if w3 <> 0 then
begin
w0:=b.testmtop+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:=b.primo+26;
bufclaim:=w1:=(w3).byte;
w3+1;
w1:=(w3).byte;
! area process claim +3 primospool primotest primosys (pseudo) !
margin:= w1-(w2:= prcount+pccount+rdcount+cdcount+twcount+fprcount+3);
if w1 <> 0 then
begin
stdvalue:=w2 + 1 ! one for program area process ! ;
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:= 1+prcount+pccount+rdcount+cdcount+twcount+
fprcount+fprcount+oprcount + 1 ! testoutput ! +waitops);
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 !
f2:= b.starttime; f2 lshift -19;
(tail(w1:=6)).word:= w2;
b.trans_first:= w2:= 0;
w2:= trsegm;
b.trans_top:= w2 ashift 9;
w2 ashift -9;
(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;
move(.w3.,w0:=8,w1:=address(spoolarea),w2:=address(b.spoolname));
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;
move(.w3.,w0:=8,w1:=address(testarea),w2:=address(b.testname));
end;
if w0:=stop <> 0 then
begin ! the resources are not available for start up !
opmess(.w3.,w1:=address(inittrop));
end;
opmess(.w3.,w1:=address(op2));
b.prheadtrail:= w0:= prltpage;
b.oprtdetails:= w0:= oprdetails;
b.accept:= w0:= taccept;
b.prlpage:= w0:= prlinepage;
w0:= 0;
w1:= trsaveminut*(60*1000*10);
b.trsaveperiod:= f1;
b.waitbufs:= w0:= waitops;
w3:=address(pseudoname);
monitor(80);
comment compute primo identification, used in communication
with adp3270 - primo_id ::= 'primoxxxx', where "xxxx" is
the host number of rc8000.;
w0:= 0;w1:= (w1:=1186).word; ! w1 = host id !
f1//1000;
w3:= address (b.primo_id)+2;
(w3).word:= w1+48+(w3).word;
w1:= w0;w0:= 0;
f1//100;
w2:= w1+48; w2 lshift 8;
w1:= w0;w0:= 0;
f1//10;
w2:= w2+w1+48;w2 lshift 8;
w2:= w2+w0+48;
(w3+2).word:= w2;
comment end primo_id;
goto initbufs;
end;
end; ! init !
!branch 1,3;
body of freetransport
comment find a free transport description if possible, and
make the description available in core;
begin
label exit;
incode
ref return;
begin
return:= w3;
if w1:= b.trans_old<0 then
begin
b.trans_old:= w1:= b.trans_first;
end;
w2:= 0;
while w2=0 do
begin
w3:= w1+(!length(tr_descr)+!length(tr_descr)-2) ashift -9 ashift 9;
if w3>w1 then
begin ! change segment !
if w3=b.trans_top then w1:=b.trans_first else w1:= w3;
end
else w1+!length(tr_descr);
looktransport(.w3.,w1,w2);
if w2>0 then w2:= 0
else
begin
w2:= w1 extract 9; w2+b.bs_first;
end;
if w1=b.trans_old then goto exit;
end;
exit:
b.trans_old:= w1;
w3:= b.current;
!test 311;
call w0 return;
end;
end; ! freetransport !
body of deftr_semantic
comment execute define transport operation.
called from application interface coroutine to avoid breaking
address limit ;
begin
label l_resources, l_ent, l_dev, l_devslow, exit;
incode
word savew2;
ref return;
ref transref, procref, tc_ref;
word hostno, hostid;
byte line,cu,dev;
word cu_dev;
ref out_process,in_process;
text (11) indevice;
text (11) formatprinter;
text(11) docname;
! file descriptor !
word ent_mk;
text(11) ent_docname;
word ent_6,ent_7,ent_8,ent_9,ent_10;
word sender_receiver,bs_dev; ! help vars used to look up sender/receiver entries !
word zero:= 0;
begin
return:= w3;
transref:= w2;
cu_dev:= w0:=0;
w2:= b.event;
w3:= (w2).cm_sender;
if w3<=0 then -(w3);
! get sender cat base and check that it is contained in my std base !
w3+68;
w2:= b.primo+76;
transref.tr_basel:= w0:= (w3).word;
if w0<(w2).word then goto l_resources;
w3+2; w2+2;
transref.tr_baseu:= w1:= (w3).word;
if w1>(w2).word then goto l_resources;
w3:= address(zero);
monitor(72); ! set cat base !
!test 91;
! test sender and receiver entry !
sender_receiver:= w0:= 0;
bs_dev:= w0; ! bs area not found yet !
while w0:=sender_receiver+1<=2 do
begin
sender_receiver:= w0;
w1:= address(ent_mk);
if w0=1 then w3:= address((w3:=transref).tr_sname)
else w3:= address((w3:=transref).tr_rname);
monitor(42); ! look up entry !
!test 92;
if w0<>0 then goto l_ent;
if w0:= ent_mk<0 then
begin ! file descriptor !
if w0 extract 12=4 then
begin ! bs descriptor !
w3:=0;
w0:=ent_8;
transref.tr_bsstartptr:=f0 ashift 9;
move(.w3.,w0:=8,w1:=address(ent_docname),
w2:=address((w2:=transref).tr_bsarea));
w1:= address(ent_mk);
w3:= address(ent_docname);
monitor(42); ! look up entry !
!test 94;
if w0<>0 then goto l_dev;
if w0:= ent_mk<0 then goto l_dev;
bs_dev:= w0:= sender_receiver;
end
else
begin
if w2:=sender_receiver=1 then
begin
!test 95;
if w0=8 then ! typewriter !
else
if w0=10 then ! reader !
else
if w0=16 then ! cardr !
else
goto l_ent;
end
else
begin
!test 96;
if w0=12 then ! punch !
else
if w0=14 then cu_dev := w0 := ent_10 ! printer !
else
goto l_ent;
end;
transref.tr_kind:= w0:= ent_mk;
transref.tr_mode:= w0 lshift 1 lshift -13;
hostno:= w0:= ent_7;
hostid:= w0:= ent_8;
if w0:= cu_dev <> 0 then
begin
! compute format printer names based
on ent_docname !
comment set kind to 15;
transref.tr_kind := w3 := transref.tr_kind + 1;
w0:= cu_dev lshift -16 extract 5;
if w0>9 then w0+87 else w0+48;
line:= w0;
w0:= cu_dev lshift -8 extract 5;
if w0>9 then w0+87 else w0+48;
cu:= w0;
w0:= cu_dev extract 5;
if w0>9 then w0+87 else w0+48;
dev:= w0;
w0:= line lshift 8 + cu lshift 8 + dev;
! gout3 => gxyz3 : (x=line,y=cu,z=dev)
x,y,z ::= (0..9a..u) i.e. (0..31) !
editout (.w3.,w0,w1:=address(ent_docname),w2:=address(docname));
if w0 = 0 then
editout (.w3.,w0:=6909440! "in"!,w1:=address(ent_docname),
w2:=address(indevice)) else
goto l_ent;
move (.w3.,w0:=8,w1:=address(ent_docname),w2:=address(formatprinter));
end else
move(.w3.,w0:=8,w1:=address(ent_docname),w2:=address(docname));
end;
end ! file descriptor !
else
begin
!test 97;
bs_dev:= w0:= sender_receiver;
move(.w3.,w0:=8,w1:=w3,
w2:=address((w2:=transref).tr_bsarea));
end;
end;
if w0:= bs_dev=0 then goto l_ent; ! bs_area not found !
w1:= address(b.tqfreefst);
if w0:=(w1).tq_next=w1 then goto l_resources; ! no free queue element !
find_tc(.w3.,w0:=address(docname),w0:=hostno,w0:=hostid,w0:=transref.tr_kind,
w1);
!test 98;
tc_ref:= w1;
if w1=0 then
begin ! no free coroutine !
goto l_resources;
end
else
if w1>0 then
begin ! exist allready !
end
else
begin ! dont exist !
-(w1);tc_ref := w1;
if w0:= cu_dev<>0 then (w1).fpr_plcudev:= w0;
if w0:=hostno=0 then
begin comment local device;
if w0:=cu_dev <> 0 then
begin comment format printer;
create_fpr (.w3.,w0:=address(formatprinter),
w0:=address(indevice),
w0:=hostno,w0:=hostid,w0,w1:=tc_ref);
if w0<>0 then
begin
remove_fpr(.w3.,w1);
goto l_devslow;
end;
procref:= w0:= address((w1:=(w1:=tc_ref).fpr_stcorout).fpr_procout)-2;
end else
begin
w3 := address(docname);
monitor(4);
if w0=0 then goto l_devslow;
procref := w0;
end;
end else
begin comment remote device;
w1:= (w2:=74).word; ! first device !
w2:= (w2:=76).word; ! last device !
w3:=w1+hostno+hostno; ! w3=name table address of hostno !
if w3>=w2 then goto l_ent; ! if outside device part of name table then error !
w0:= (w3:=(w3).word).word; ! w0 := kind(hostno); !
if w0 <> 26 ! 26 = kind (ifpmain) ! then
begin
if w0 <> 82 ! 82 = kind (subhost) ! then goto l_ent;
end;
if w0 = 26 then
begin
if w0:= transref.tr_kind <> 14 then goto l_devslow;
w0:= address (docname)-2;
procref:= w0;
w0:= 0;
hostid:= w0;
end else
begin
linkupremote(.w3.,w0:=transref.tr_kind,w0:=hostno,w0:=hostid,
w0:=address(docname),w0,w2);
if w0<>4096 then
if w0<>4103 then
if w0:=b.accept<>0 then w2:=address(b.no_link) else goto l_devslow;
procref:=w2;
end;
end;
w1:=tc_ref;
create_tc(.w3.,w1,w0:=address(docname),w0:=hostno,w0:=hostid,w0:=procref);
if w0 := cu_dev <> 0 then
else
begin
w3:=address((w1:=tc_ref).tc_name);
monitor(8);
w2:=procref;
comment if w0:=(w2+36).byte <> transref.trkind then goto l_devslow;
end;
end;
w0:= 0;
exit:
w1:= tc_ref;
w2:= transref;
w3:= b.current;
call w0 return;
l_resources : w0:= 2; goto exit;
l_ent : if w0:=sender_receiver=1 then w0:= 3 else w0:= 5; goto exit;
l_dev : if w0:= sender_receiver=1 then w0:= 4 else w0:= 6; goto exit;
l_devslow : if w0:=bs_dev=1 then w0:= 6 else w0:= 4; goto exit;
end;
end; ! deftr_semantic !
body of appl_interface
comment application interface coroutine;
begin
label wait_m,
rdt_resources,rdt_syntax,rdt_sent,rdt_sdev,rdt_rent,rdt_rdev,
rgt, rgt_syntax, rgt_unknown, rgt_resources, tr_finished,
rrt, rrt_syntax, rrt_unknown,
rkt, rkt_syntax, rkt_unknown,repkill,
stopped,unint,reject;
record def_transport
(word dth_op,dth_trname;
text(11) dt_trname;
word dth_user;
text(11) dt_user;
word dth_sub,dth_sender,dth_sname;
text(11) dt_sname;
word dth_receiver,dth_rname;
text(11) dt_rname;
word dth_queues,dth_qgroup;
text(11) dt_qgroup;
word dth_qname;
text(11) dt_qname);
record getst_transport
(word gth_op,gth_no;
word gt_no);
record relea_transport
(word rth_op,rth_no;
word rt_no);
record kill_transport
(word kth_op,kth_no;
word kt_no);
incode
! answer define transport !
byte adt_1:= 3, adt_2:= 0,
adt_3:= 1, adt_4:= 4'010010;
text(11) adt_trname;
byte adt_5:= 2, adt_6:= 4'010010;
text(11) adt_user;
byte adt_7:= 3, adt_8:= 4'010001;
word adt_no;
byte adt_9:= 4, adt_10:= 4'010000,
adt_11:=1, adt_12:= 4'020001;
word adt_rcode;
byte adt_13, adt_14:= 4'020002; ! device troubles params !
word adt_cause, adt_status:= 0;
! answer get state !
byte agt_1, agt_2:= 0,
agt_3:= 4, agt_4:= 4'010000,
agt_5:= 1, agt_6:= 4'020001;
word agt_rcode;
byte agt_7:= 1, agt_8:= 4'010010;
text(11) agt_trname;
byte agt_9:= 3, agt_10:= 4'010001;
word agt_no;
byte agt_11:= 1000, agt_12:= 4'010000,
agt_13:= 3, agt_14:= 4'020000,
agt_15:= 4, agt_16:= 4'030001;
word agt_state;
byte agt_19:= 7, agt_20:= 4'030002;
word agt_ptr1, agt_ptr2;
byte agt_17:= 6, agt_18:= 4'030002;
word agt_cause, agt_status;
! answer release descr !
byte art_1:= 9, art_2:= 0,
art_3:= 4, art_4:= 4'010000,
art_5:= 1, art_6:= 4'020001;
word art_rcode;
! answer kill transport !
byte akt_1:= 11, akt_2:= 0,
akt_3:= 4, akt_4:= 4'010000,
akt_5:= 1, akt_6:= 4'020001;
word akt_rcode;
! work area for control operation data !
array(1:(!length(def_transport)+2)) cont_data of byte;
! data area for control operation data, longer than longest data area !
! general copy params !
word gc_func:= 4; ! copy from sender to me !
ref gc_first, gc_last;
word gc_rel:= 0;
word bytesmoved;
ref transref, tc_ref;
word transno; ! used by kill !
ref return;
begin
return:= w3; call w3 return; ! pseudo call !
wait_m:
waitmess(.w3.,w2);
cont_data(w1:=1);
w3:= w1+!length(def_transport);
gc_first:= w1;
gc_last:= w3;
w1:= address(gc_func);
monitor(84); ! general copy core !
if w0=2 then goto stopped;
if w0=3 then goto unint;
if w1<=0 then goto unint; ! no data !
bytesmoved:= w1;
cont_data(w1:=1);
testout(.w3.,w0:=bytesmoved,w1,w2:=66);
if w0:=(w1).word=4'2000000 then
begin ! define transport !
if w0:=bytesmoved<>!position(dth_queues) then
if w0<>!length(def_transport) then
goto unint; ! length of data illegal !
freetransport(.w3.,w1,w2);
if w2=0 then goto rdt_resources;
adt_no:= w1;
transref:= w2;
w1:= w2+!length(tr_descr)-2;
w0:= 0;
for w1 step 2 downto transref do (w1).word:= w0;
cont_data(w1:=1);
if w0:=(w1).dth_trname<>4'1010010 then goto rdt_syntax;
!test 52;
move(.w3.,w0:=8,w1:=address((w1).dt_trname),w2:=address(adt_trname));
move(.w3.,w0,w1,w2:=address((w2:=transref).tr_name));
cont_data(w1:=1);
if w0:=(w1).dth_user<>4'2010010 then goto rdt_syntax;
move(.w3.,w0:=8,w1:=address((w1).dt_user),w2:=address(adt_user));
move(.w3.,w0,w1,w2:=address((w2:=transref).tr_user));
cont_data(w1:=1);
if w0:=(w1).dth_sub<>(1000*4096+4'010000) then goto rdt_syntax;
if w0:=(w1).dth_sender<>4'1020000 then goto rdt_syntax;
if w0:=(w1).dth_sname<>4'2030010 then goto rdt_syntax;
move(.w3.,w0:=8,w1:=address((w1).dt_sname),w2:=address((w2:=transref).tr_sname));
cont_data(w1:=1);
if w0:=(w1).dth_receiver<>4'2020000 then goto rdt_syntax;
if w0:=(w1).dth_rname<>4'2030010 then goto rdt_syntax;
!test 58;
move(.w3.,w0:=8,w1:=address((w1).dt_rname),w2:=address((w2:=transref).tr_rname));
if w1:=bytesmoved=!length(def_transport) then
begin ! queue fields present !
cont_data(w1:=1);
if w0:=(w1).dth_queues<>4'3030000 then goto rdt_syntax;
if w0:=(w1).dth_qgroup<>4'1100010 then goto rdt_syntax;
move(.w3.,w0:=8,w1:=address((w1).dt_qgroup),w2:=address((w2:=transref).tr_qgroup));
cont_data(w1:=1);
if w0:=(w1).dth_qname<>4'3100010 then goto rdt_syntax;
!test 60;
move(.w3.,w0:=8,w1:=address((w1).dt_qname),w2:=address((w2:=transref).tr_qname));
end;
deftr_semantic(.w3.,w0,w1,w2:=transref);
!test 61;
tc_ref:= w1;
case w1:= w0 of ! w1=0 transport defined, no action !
begin
rdt_syntax : w1:= 1;
rdt_resources : w1:= 3;
rdt_sent : begin
adt_13:= w1:= 3; adt_cause:= w1:= 1; w1:= 5;
end;
rdt_sdev : begin
adt_13:= w1:= 3; adt_cause:= w1:= 2; w1:= 5;
end;
rdt_rent : begin
adt_13:= w1:= 4; adt_cause:= w1:= 1; w1:= 6;
end;
rdt_rdev : begin
adt_13:= w1:= 4; adt_cause:= w1:= 2; w1:= 6;
end;
end;
adt_rcode:= w1;
if w1>=5 ! device troubles ! then w1:= address(adt_status)
else w1:= address(adt_rcode);
copyanswer(.w3.,w0:=address(adt_1),w1,w2:=b.event);
if w0=0 then ! data copied to sender !
if w0:=adt_rcode=0 then
begin ! operation accepted, initialize transport !
w2:= transref;
(w2).tr_corou:= w0:= tc_ref;
(w2).tr_state:= w0:= 0;
(w2).tr_removetime:= w0:= 8'37777777;
puttransport(.w3.,w1:=adt_no);
link(.w3.,w1:=b.tqfreefst,w2:=address(tc_ref.tc_nexttr));
(w1).tq_transno:= w0:= adt_no;
f0 lshift 100;
(w1).tq_suspend:= f0;
w3:=b.current;
end;
end ! define transport !
else
if w0=4'10000000 then
begin ! get state of subtransport !
if w0:=bytesmoved<>!length(getst_transport) then
goto unint; ! length of data illegal !
agt_1:= w0:= 5; ! ans get state !
cont_data(w1:=1);
if w0:=(w1).gth_no<>4'3010001 then goto rgt_syntax;
looktransport(.w3.,w1:=(w1).gt_no,w2);
agt_no:= w1;
if w2<=0 then goto rgt_unknown;
transref:= w2;
if w0:=(w2).tr_state=0 then
begin ! not finished !
w1:= (w2).tr_corou;
if w0:=(w1).tc_transno<>agt_no then agt_state:= w0:= 2 ! waiting !
else
begin ! executing or hold state !
agt_state:= w0:= 3; ! executing !
w2:= b.holdqfst;
while w3:=address(b.holdqfst)<>w2 do
begin
if w1=w2 then agt_state:= w0:= 4; ! hold !
w2:= (w2).c_next;
end;
end;
end
else
begin ! finished !
tr_finished:
agt_state:= w0:= (w2).tr_state;
agt_cause:= w0:= (w2).tr_cause;
agt_status:= w0:= (w2).tr_status;
f1:=(w2).tr_charposition;
agt_ptr1:=w0;
agt_ptr2:=w1;
end;
w0:= 0;
rgt:
! reply get transport !
agt_rcode:= w0;
move(.w3.,w0:=8,w1:=address((w1:=transref).tr_name),
w2:=address(agt_trname));
if w1:=agt_state=5 then w1:= address(agt_ptr2)
else
if w1=6 then w1:= address(agt_status)
else w1:= address(agt_state);
copyanswer(.w3.,w0:=address(agt_1),w1,w2:=b.event);
if w0<>w0 then
begin ! operation not accepted !
rgt_syntax : w0:= 1; goto rgt;
rgt_unknown : w0:= 2; goto rgt;
rgt_resources: w0:= 3; goto rgt;
end;
end ! get state of transport !
else
if w0=4'12000000 then
begin ! wait and get state of subtransport !
if w0:=bytesmoved<>!length(getst_transport) then
goto unint; ! length of data illegal !
agt_1:= w0:= 7; ! answer waitget transport !
cont_data(w1:=1);
if w0:=(w1).gth_no<>4'3010001 then goto rgt_syntax;
looktransport(.w3.,w1:=(w1).gt_no,w2);
agt_no:= w1;
if w2<=0 then goto rgt_unknown;
transref:= w2;
if w0:=(w2).tr_state=0 then
begin ! not finished !
if w0:=(w2).tr_waitmess>0 then goto reject;
if w0:=b.waitbufs<=0 then goto rgt_resources;
b.waitbufs:= w0-1;
transref.tr_waitmess:= w2:= b.event;
puttransport(.w3.,w1:=agt_no);
end
else
begin ! finished !
goto tr_finished;
end;
end ! wait and get state of transport !
else
if w0=4'20000000 then
begin ! release description !
if w0:=bytesmoved<>!length(relea_transport) then
goto unint; ! length of data illegal !
cont_data(w1:=1);
if w0:=(w1).rth_no<>4'3010001 then goto rrt_syntax;
looktransport(.w3.,w1:=(w1).rt_no,w2);
if w2<=0 then goto rrt_unknown;
if w0:=(w2).tr_removetime>=8'37777776 then w0:= 8'37777776
else w0:= 0;
(w2).tr_removetime:= w0;
w0:= 0;
rrt: ! reply release transport !
art_rcode:= w0;
copyanswer(.w3.,w0:=address(art_1),w1:=address(art_rcode),w2:=b.event);
cont_data(w1:=1);
if w0=0 then ! data copied to sender !
if w0:=art_rcode=0 then ! operation accepted !
puttransport(.w3.,w1:=(w1).rt_no);
if w0<>w0 then
begin ! operation not accepted !
rrt_syntax : w0:= 1; goto rrt;
rrt_unknown : w0:= 2; goto rrt;
end;
end ! release description !
else
if w0=4'22000000 then
begin ! kill !
if w0:=bytesmoved<>!length(kill_transport) then
goto unint; ! length of data illegal !
cont_data(w1:=1);
if w0:=(w1).kth_no<>4'3010001 then goto rkt_syntax;
looktransport(.w3.,w1:=(w1).kt_no,w2);
if w2<=0 then goto rkt_unknown;
transref:= w2;
transno:= w1;
w0:= 0;
if w0<>w0 then
begin ! operation not accepted !
rkt_syntax : w0:= 1; goto rkt;
rkt_unknown : w0:= 2;
end;
rkt: ! reply kill transport !
akt_rcode:= w0;
copyanswer(.w3.,w0:=address(akt_1),w1:=address(akt_rcode),w2:=b.event);
if w0 or akt_rcode=0 then
begin ! data copied to sender and operation accepted !
w2:= transref;
if w0:=(w2).tr_state=0 then
begin ! not finished !
w1:= (w2).tr_corou;
if w0:=(w1).tc_transno<>transno then
begin ! waiting !
w1:= address((w1).tc_nexttr);
repkill:
w1:= (w1).tq_next;
if w0:=(w1).tq_transno<>transno then goto repkill;
link(.w3.,w1,w2:=address(b.tqfreefst));
w2:= transref;
if w0:=(w2).tr_removetime=8'37777776 ! released ! then w0:= 0
else
begin
w1:= 108;
f1:= (w1).double+b.trsaveperiod lshift -20;
end;
(w2).tr_removetime:= w1;
(w2).tr_state:= w0:= 8; ! killed by appl !
w0:= (w2).tr_waitmess;
w1:= 0; (w2).tr_waitmess:= w1;
puttransport(.w3.,w1:=transno);
if w0>0 then
begin
b.event:= w0; ! very dirty !
agt_1:= w0:= 7;
goto tr_finished;
end;
end
else
begin ! set coroutine flag !
(w1).tc_aintervent:= w0:= 1;
end;
end; ! not finished !
end; ! data copied to sender !
end ! kill !
else
begin
reject:
w0:= 2;
if w0<>w0 then
begin
unint:
w0:= 3;
end;
b.ans_status:= w1:= 0;
if w1<>w1 then
begin
stopped:
w0:= 1;
b.ans_status:= w1:= 8'400;
end;
b.ans_bytes:= w1:= 0;
b.ans_chars:= w1;
w1:= address(b.ans_status);
w2:=b.event;
monitor(22); ! send answer !
testout(.w3.,w0:=2,w1,w2:=61);
end;
w0:= 0;
(w3).c_mbuf:= w0;
goto wait_m;
end;
end; ! appl_interface !
body of create_fpr
begin
incode
ref return,fpr_ref,table_ref,help;
word lcudev, result,savew2;
begin
return := w3;
fpr_ref:= w1;
savew2 := w2;
w0:= - 1;table_ref := w0;
w1 := return.cfpr_outdevice;
w2:= b.gac_table;
while w0:=table_ref<0 do
begin comment find status coroutine coresponding
to actual transport and increase count by one,
or create a new status handling coroutine;
help:= w2;
compare (.w3.,w0:=8,w1,w2:=address((w2).fpr_gacout));
w2:= help;
if w0=0 then w0:= (w2).fpr_hostid-return.cfpr_hid;
if w0<>0 then w2+!length(fprincoroutine) else table_ref:=w2;
if w2>=b.gac_top then
begin comment no status coroutine matches current transport
create status- coroutine and possibly link;
comment find free entry;
result:= w0:= - 1;
w2 := b.gac_table;
w0 := (w2).fpr_count;
while w0>0 do
begin comment find free entry;
w2+!length(fprincoroutine);
w0:=(w2).fpr_count;
end;
table_ref:=w2;
move(.w3.,w0:=8,w1:=return.cfpr_outdevice,
w2:=address((w3:=table_ref).fpr_gacout));
move(.w3.,w0:=8,w1:=return.cfpr_indevice,
w2:=address((w3:=table_ref).fpr_gacin));
(w2:=table_ref).fpr_hostid := w0 := return.cfpr_hid;
(w2).fpr_count := w0 := 0;
if w0:=return.cfpr_hid=0 then
begin comment local device;
w3:=return.cfpr_outdevice;
comment lookup process;
monitor(4);
if w0<>0 then
begin comment process found;
w1:=w0+2;
move(.w3.,w0:=8,w1,w2:=address((w3:=table_ref).fpr_procout));
w3 := address((w2:=table_ref).fpr_procout);
comment reserve device;
monitor(8);
if w0=0 then
begin
w3:=return.cfpr_indevice;
comment lookup process (gacin);
monitor(4);
if w0 <> 0 then
begin
w1:=w0+2;
move(.w3.,w0:=8,w1,w2:=address((w3:=table_ref).fpr_procin));
w3 := address((w2:=table_ref).fpr_procin);
comment reserve process(gacin);
monitor(8);
comment set result;
result:=w0;
end;
end;
end;
end else
begin comment remote device;
linkupremote(.w3.,w0:=14,w0:=return.cfpr_hno,w0:=return.cfpr_hid,
w0:=return.cfpr_outdevice,w0,w2);
if w0=4096 then w0:=4103;
if w0=4103 then
begin comment link created;
move(.w3.,w0:=8,w1:=w2+2,w2:=address((w3:=table_ref).fpr_procout));
w3:=address((w2:=table_ref).fpr_procout);
monitor(8);
if w0=0 then
begin comment then in device;
linkupremote(.w3.,w0:=10,w0:=return.cfpr_hno,w0:=return.cfpr_hid,
w0:=return.cfpr_indevice,w0,w2);
if w0=4096 then w0:=4103;
if w0=4103 then
begin comment reserve indevice;
move(.w3.,w0:=8,w1:=w2+2,w2:=address((w3:=table_ref).fpr_procin));
w3:=address((w2:=table_ref).fpr_procin);
monitor(8);
comment set result;
result:=w0;
end;
end;
end;
end;
if w0:=result=0 then
begin comment prepare status server;
link(.w3.,w1:=table_ref,w2:=address(b.activqfst));
w0:=0;
table_ref.c_ic:= w0;
table_ref.fpr_wait:= w0;
end;
end else result:= w0:= 0; ! end create status coroutine !
end; ! end status coroutine search !
comment increase gac-access count;
fpr_ref.fpr_stcorout:=w0:=table_ref;
table_ref.fpr_count := w0 := table_ref.fpr_count + 1;
testout(.w3.,w0:=!length(fprincorout),w1:=table_ref,w2:=53);
comment return;
w2:=savew2;
w1:=fpr_ref;
w0 := result;
w3 := return;
end;
end; ! end create_fpr !
body of editout
begin comment this procedure generates a name on the basis of
a name containing the substring "out". in the specified
name the substring "out" is replaced by the substring
(max 3 chars) contained in w0. the call is follows:
w0:call: (max 3) replacement chars - return: result(0=ok)
w1:call: address ("out"-name) - return: unchngd
w2:call: address ("result"-name) - return: unchngd
w3:call: return address - return: b.current ;
incode
ref return,
outdev,
resdev;
word state;
word cptr;
array (1:14) char of byte;
text (15) source := "";
byte rcar1,rcar2,rcar3;
begin
return := w3;
outdev := w1;
resdev := w2;
w3:= 0; f0 lshift 8; rcar1:= w3;
w3:= 0; f0 lshift 8; rcar2:= w3;
w3:= 0; f0 lshift 8; rcar3:= w3;
w1:=address(source);
(w1).word := w0 := 0;
move(.w3.,w0:=8,w1,w2:=w1+2);
move(.w3.,w0:=8,w1,w2:=resdev);
move(.w3.,w0:=8,w1:=outdev,w2:=address(source));
w0:= 0;
for w3 := 1 step 1 upto 12 do
(char(w2:=w3)).byte:=w0;
! w1 = address(outdevice) !
cptr := w0:= 1;
state:= w0;
while w2:=cptr < 12 do
begin
w0:=(w1).word;
if w0 = 0 then cptr := w2 := 12;
while w0 <> 0 do
begin
w3 := 0;
f0 lshift 8;
case w2:=state of
begin
if w3=111 ! '0' ! then state:=w2:=2 else
begin
(char(w2:=cptr)).byte := w3;
cptr:= w2:= cptr+1;
end;
if w3=117 ! 'u' ! then state:= w2:= 3 else
begin
(char(w2:=cptr+1)).byte := w3;
(char(w2:=cptr)).byte := w3 := 111;
cptr := w2 := cptr+2;
state := w3 := 1;
end;
if w3=116 ! 't' ! then
begin
w2 := cptr;
w3 := rcar1; if w3 <> 0 then
begin
(char(w2)).byte := w3;
cptr := w2 := cptr + 1;
end;
w3 := rcar2; if w3 <> 0 then
begin
(char(w2)).byte := w3;
cptr := w2 := cptr + 1;
end;
w3 := rcar3; if w3 <> 0 then
begin
(char(w2)).byte := w3;
cptr := w2 := cptr + 1;
end;
state := w3 := 4;
end else
begin
(char(w2:=cptr+2)).byte := w3;
(char(w2:=cptr+1)).byte := w3 := 117;
(char(w2:=cptr)).byte:= w3 := 111;
cptr := w2 := cptr +3;
state := w3 := 1;
end;
begin
(char(w2:=cptr)).byte := w3;
cptr:= w2:= cptr+1;
end;
end; ! end case !
end;
w1+2;
end;
w3 := 16;
w1 := resdev ; ! w1 = address (result name) !
cptr := w2 := 1;
if w0 := state=4 then
while w2 < 13 do
begin
w0:=(char(w2)).byte;
w0 lshift w3;
(w1).word := w0+(w1).word;
w3-8;
if w3<0 then
begin
w3:=16;
w1+2;
end;
cptr:=w2:=cptr+1;
w0 extract 8;
end;
w1 := outdev;
w2 := resdev;
w3 := b.current;
w0 := state;
w0-4;
call w0 return;
end;
end;
!branch 1,4;
body of nextchar
begin
incode
ref return;
begin
return:= w3;
if w1=0 then
if w2=(w3).stp then w1:= 10 ashift 16
else
begin
w1:= (w2).word;
w2+2;
end;
w0:= 0;
f1 lshift 8;
w3:= return;
end;
end; ! nextchar !
body of find_consoldevice
comment find a transport coroutine with the console name and device name
given as parameters;
begin
label found;
incode
word savew0, savew1, savew2, result;
ref return;
byte dhlinkno, hostno;
word hostid;
text(11) workname;
begin
savew0:= w0; savew1:= w1; savew2:= w2;
return:= w3;
if w0:= (w2).word = 0 then
begin comment no device specification;
w1:= 0;
call w0 return;
end;
lookupremote(.w3.,w3:=2,w1,w2,w0,w1,w2:=address(dhlinkno));
w2:=address((w2:=b.current).opr_devcons);
if w0 = 0 ! csp terminal ! then move (.w3.,w0:=8,w1:=savew1,w2) else
begin comment ncp terminal;
if w0 extract 12 = 0 then terminalid (.w3.,w0:=dhlinkno,w2) else
(w2).word:= w0:= -1;
end;
if w0:= savew0 = 1 then w0:= 2;
if w0<>2 ! must be startup terminal ! then
begin
compare(.w3.,w0:=4,w1:=address(dhlinkno),w2:=address(b.proc_dhlinkno));
if w0<>0 then w0:= -1;
end else w0:= 0;
result:= w0;
w1:= b.tcpool_fst;
while w1<b.tcpool_top do
begin
compare(.w3.,w0:=8,w1+!position(tc_devname),w2:=savew2);
w1-!position(tc_devname);
if w0=0 then
begin
if w0:=savew0>4999 then
begin comment w0=hostident , ignore tc_devcons;
if w0=(w1).tc_hostid then goto found;
end
else
if w0:=savew0 > 2 then
begin comment w0=hostno , csp device;
if w0 = (w1).tc_hostno then goto found;
end
else
if w0:=savew0=1 ! local device ! then
begin
if w0:=(w1).tc_hostno=0 then goto found;
end
else
begin
if w0:= (w1).tc_hostno <> 0 then
begin comment remote device;
if w0:= (w1).tc_hostid = 0 then
begin comment csp device;
w0:= hostno;
w0 - (w1).tc_hostno;
end else
begin comment ncp device;
w0:= hostid - (w1).tc_hostid;
end;
if w0=0 then
begin
w1+!position(tc_devcons);
w2:= address((w2:=b.current).opr_devcons);
compare (.w3.,w0:=8, w1, w2);
w1-!position(tc_devcons);
if w0=0 then goto found;
end;
end;
end;
end;
w1:= (w1).tc_nexttc;
end;
w1:= 0;
found:
if w0:=(w1).tc_created=0 then -(w1);
w0:= result; w2:= savew2;
w3:= b.current;
call w0 return;
end;
end;
body of getparams
begin
procedure idcommand (.w3.;
w0 ; ! return: command no !
w1 ; ! call: ref. command !
w2); ! call: ref. cmdtable!
procedure delivercmd (.w3.;
ref param,
paramdesc,
stackp,
stdesc);
incode
double savef2;
ref cmdref;
word sep, type;
word txt1,txt2,txt3,txt4;
double value;
byte command, params;
word sign, remote;
byte state, action;
word char,
stop_a,
partial;
ref buf_a,
stack,
parmstack;
text (6)
start := "start",
skip := "skip",
repeat:= "repea",
restar:= "resta",
stop := "stop",
kill := "kill",
suspen:= "suspe",
drain := "drain",
reques:= "reque",
signup:= "signu",
signof:= "signo",
select:= "selec",
route := "route",
triang:= "trian",
displa:= "displ",
emptyc:= "";
array (1:250) cmdtable of byte :=
! delimeter: 0=nothing follows; 4=space; 8=puntuation !
! parameter: 2=uns.int;3=neg.int.;4=name;5='64'name !
! first delimeter is allways a space................................ !
! :<-------------------------------------- command number.......... !
! :<----------------------------------- number of params........ !
! :<------------------------------- alt spec. exist ?....... !
! :<---------------------------- 1st parameter........... !
! :<------------------------ 2nd delimeter........... !
! :<--------------------- 2nd parameter........... !
! :<----------------- 3rd delimeter........... !
! :<-------------- 3rd parameter........... !
! :<---------- 4th delimeter........... !
! :<------- 4th parameter........... !
! :<--- 5th delimeter........... !
! :< 5th parameter........... !
1 3 1 5 8 2 8 2 0 0 0 0 ! START <dev>.hno.hid !
1 4 0 5 8 2 8 2 4 2 0 0 ! START <dev>.hno.hid n !
2 4 0 5 8 2 8 2 4 2 0 0 ! SKIP <dev>.hno.hid n !
3 4 0 5 8 2 8 2 4 2 0 0 ! REAPEAT <dev>.hno.hid n !
4 3 0 5 8 2 8 2 0 0 0 0 ! RESTART <dev>.hno.hid !
5 3 0 5 8 2 8 2 0 0 0 0 ! STOP <dev>.hno.hid !
6 3 0 5 8 2 8 2 0 0 0 0 ! KILL <dev>.hno.hid !
7 3 0 5 8 2 8 2 0 0 0 0 ! SUSPEND <dev>.hno.hid !
8 3 0 5 8 2 8 2 0 0 0 0 ! DRAIN <dev>.hno.hid !
9 0 1 0 0 0 0 0 0 0 0 0 ! REQUEST !
9 3 0 5 8 2 8 2 0 0 0 0 ! REQUEST(dev.hno.hid/all !
10 4 0 5 8 2 8 2 4 2 0 0 ! SIGNUP <dev>.hno.hid n !
11 3 0 5 8 2 8 2 0 0 0 0 ! SIGNOFF <dev>.hno.hid !
12 3 1 5 8 2 8 2 0 0 0 0 ! SELECT <dev>.hno.hid !
12 4 1 5 8 2 8 2 4 4 0 0 ! SELECT <dev>.hno.hid <ps>!
12 5 0 5 8 2 8 2 4 4 8 4 ! SEL <dev>.hn.hid <gr>.<q>!
13 4 0 5 8 2 8 2 4 4 0 0 ! ROUTE <dev>.hno.hid <ent>!
14 4 0 5 8 2 8 2 4 4 0 0 ! TRIANG <dev>.hno.hid <b> !
15 0 0 0 0 0 0 0 0 0 0 0 ! DISPLAY !
-1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1;! end syntax table. !
array (1:128) state_action of byte :=
! st/class ns act ns act ns act ns act ns act ns act ns act ns act
space sign "." "@" digit alfa newline illegal !
! 1.begin ! 1 1 2 11 3 11 4 11 5 11 2 2 0 6 8 11
! 2.in name! 4 3 2 11 5 4 4 11 2 5 2 5 0 6 8 11
! 3.in numb! 4 3 2 11 5 4 4 11 3 9 6 11 0 6 8 11
! 4.aft spc! 4 1 6 10 5 4 7 8 3 7 2 2 0 6 8 11
! 5.aft "."! 5 11 6 10 3 11 7 8 3 7 2 2 7 11 8 11
! 6.aft sgn! 6 11 2 11 3 11 4 11 3 7 6 11 7 11 8 11
! 7.aft "@"! 1 11 2 11 3 11 4 11 5 11 2 2 7 11 8 11 ;
begin
cmdref := w3;
savef2 := f2;
w0 := cmdref.stoppntr;
stop_a := w0;
w0 := cmdref.bufpntr;
buf_a := w0;
stack := w0 := cmdref.paramarea;
parmstack := w0 := cmdref.paramtype;
w0 := 0;
type := w0;
sep := w0;
remote := w0;
sign := w0;
partial := w0;
command:= w0 := - 1;
params := w0 := - 1;
state := w1 := 1;
while w1 > 0 do
begin
w0 := 0;
while w0 = 0 do
begin
nextchar (.w3.,w3:=stop_a,w0,w1:=partial,w2:=buf_a);
partial := w1;
buf_a := w2;
char := w0;
end;
w2 := char;
if w2 > 96 then if w2 < 126 then w1 := 6 ! alfa !
else w1 := 8 else
if w2 = 64 then w1 := 4 ! "@" !
else
if w2 > 47 then if w2 < 58 then w1 := 5 ! digit !
else w1 := 8 else
if w2 = 32 then w1 := 1 ! space !
else
if w2 = 45 then w1 := 2 ! sign !
else
if w2 = 43 then w1 := 2 ! sign !
else
if w2 = 46 then w1 := 3 ! pkt. !
else
if w2 = 10 then w1 := 7 ! nline !
else w1 := 8;! error !
! w2 = char value !
! w1 = char class !
char := w2;
w1-1;w1 lshift 1;w1 + 1;
w3 := state ;
w3-1; ! state_action := !
w3 lshift 4 ; ! state_action ( state,class); !
w1 + w3 ;
state := w0 := (state_action(w3:=w1)).byte;
action:= w0 := (state_action(w3:=w1+1)).byte;
case w1 := action of
begin
begin end; ! empty action !
begin comment start name - action = 2;
type := w0 := 4;
w2 lshift 16;
txt1 := w2;
w0 := 0;
txt2 := w0; txt3 := w0; txt4 := w0;
params := w0 := params + 1;
end; ! end start name - action = 2!
begin comment end with space - action = 3;
if w0 := params = 0 then
begin
idcommand(.w3.,w0,w1:=address(txt1),w2:=address(start));
command := w0;
if w0 = 0 then state := w0;
end else
if w0 := params < 6 then
begin
w3 := sep;
w3 lshift 12;
w0 := type ;
w0 or remote; w0 or sign;
if w0 >= 4 then w1 := address (txt1) else
w1 := address (value) + 2;
w0+w3;
delivercmd (.w3.,w3:=w1,w3:=w0,w3:=address(stack),w3:=address(parmstack));
if w0:= params=1 then
begin comment add hostno, hostid;
w1:= (w3:=b.current).opr_hostno;
w0:=0;
value:= f1;
delivercmd(.w3.,w3:=address(value)+2,w3:=8 lshift 12 + 2,
w3:= address(stack),w3:= address(parmstack));
w1:= (w3:=b.current).opr_hostid;
w0:=0;
value:= f1;
delivercmd(.w3.,w3:= address(value)+2,w3:=8 lshift 12+2,
w3:= address(stack),w3:= address(parmstack));
params:= w0:= 3;
end; ! end add hostspec to command !
sep := w0 := 4;
end else
begin
command := w0 := - 2;
state := w0 := 0;
end;
type := w0 := 0;
remote := w0;
sign := w0;
end; ! end end with space - action = 3!
begin comment end with punctuation - action = 4;
if w0 := params > 0 then
begin
if w0 < 5 then
begin
w3 := sep;
w3 lshift 12;
w0 := type;
w0 or remote;
w0 or sign;
if w0 >= 4 then w1 := address(txt1) else
w1 := address(value) + 2;
w0+w3;
delivercmd(.w3.,w3:=w1,w3:=w0,w3:=address(stack),w3:=address(parmstack));
if w0:= params=1 then
begin
if w0<>remote then
begin
command:= w0:= -1;
state:= w0:= 0;
end;
end;
end else
begin
command := w0 := - 2;
state := w0 := 0;
end;
end else state := w0 := 8;
sep := w0 := 8;
w0 := 0;
type := w0;
remote := w0;
sign := w0;
end; ! end end with punctuation - action = 4 !
begin comment build name - action = 5;
w1 := 1;
while w1 > 0 do
begin
case w1 of
begin
w0:=txt1;
w0:=txt2;
w0:=txt3;
w0:=txt4;
end;
if w0 = 0 then w3 := 16 else
if w0 zeromask 8192 then w3 := 8 else
if w0 zeromask 32 then w3 := 0 else
w3 := -1;
if w3 > -1 then
begin
w2 lshift w3;
w0 or w2;
case w1 of
begin
txt1 := w0;
txt2 := w0;
txt3 := w0;
if w3 = 0 then state := w0 := 8 else txt4 := w0;
end;
w1 := - 1;
end;
w1+1;
end;
end; ! end build name - action = 5 !
begin comment end with newline - action = 6;
if w0 := params < 0 then command := w0 := -4 else
if w0 := params = 0 then
begin comment identify command;
idcommand(.w3.,w0,w1:=address(txt1),w2:=address(start));
command := w0;
if w0 > 0 then params := w0 := 0;
end else
begin
if w0 := type > 0 then
begin
if w0 := params < 6 then
begin
w3 := sep;
w3 lshift 12;
w0 := type; w0 or remote; w0 or sign;
if w0 >= 4 then w1 := address(txt1) else
w1 := address(value) + 2;
w0 + w3;
delivercmd (.w3.,w3:=w1,w3:=w0,w3:=address(stack),w3:=address(parmstack));
if w0:= params=1 then
begin comment add hostno and hostid;
w1:=(w3:=b.current).opr_hostno;
w0:=0;value:= f1;
delivercmd(.w3.,w3:=address(value)+2,w3:=8 lshift 12+2,
w3:=address(stack),w3:=address(parmstack));
w1:=(w3:=b.current).opr_hostid;
w0:=0;value:= f1;
delivercmd(.w3.,w3:=address(value)+2,w3:=8 lshift 12+2,
w3:=address(stack),w3:=address(parmstack));
params:= w0:= 3;
end;
end else state := w0 := 8;
end;
end;
cmdtable (w2:=1);
w0 := 0;
if w1 := command > 0 then
while w0 = 0 do
begin
w1 := address(command);
w0 := (w2).word -(w1).word;
if w0 < 0 then -(w0);
if w0 < 4 then
begin comment maybe found;
if w0 = 0 then
begin comment found;
w3:=0;
w2+2;
w1 := cmdref.paramtype;
while w0 = 0 do
begin comment check params;
w0 := (w2).word - (w1).word;
if w0 = 4096 then w0 := 0 else
if w0 = 4097 then w0 := 0 else
if w0 = 1 then w0 := 0 else;
w0:=w0;w1+2;w2+2;
w3+1;
end;
if w3 > 5 then w0 := 1 else
state := w0 := 8;
end else
begin comment try if alternate descriptor;
w3 := w2;
w0 := (w3+2).word;
w0 lshift -12;
if w0 <> 0 then
begin comment alternative exists;
w0 := 0;
w2+12;
end else
begin
w0 := (w2).word -(w1).word;
if w0 < 0 then w0 := - 2 ! plus param !
else w0 := - 3; ! minus param!
command := w0;
end;
end;
end else
begin comment next param;
w2+12;
w0 := (w2).word;
if w0 > 0 then w0 := 0;
end;
end else; ! end while !
end; ! end end with newline - action = 6 !
begin comment start integer - action = 7;
type := w0 := 2;
w2 - 48;
w1 := 0;
value := f2;
params := w0 := params + 1;
end;
begin comment remote := true;
remote := w0 := 1;
end;
begin comment build integer - action = 9;
w2 - 48;
f1 := value;
w1 * 10;
w3 := w2 ; w2 := 0;
f1 ++ f3;
w3 := sign; -(w3);
if w3 <> 0 then w2 := - 1 else w2 := 0;
f3 ++ f1;
if w3 < 0 then state := w3 := 8 else;
value := f1;
end; ! end build integer - action = 9!
begin comment set sign - action = 10;
if w2 = 45 then w0 := 1 else w0 := 0;
sign := w0;
end; ! end set sign - action = 10 !
begin comment syntax error - action = 11;
state := w0 := 8;
end; ! end syntax error - action = 11!
end; ! end state case !
w1 := state;
w1 extract 3;
end;
if w0 := state > 0 then
command := w0 := - 1;
w1 := address (command);
w0 := (w1).word;
f2 := savef2;
w3 := cmdref;
end;
body of delivercmd
begin
incode
double savef1;
word savew2;
ref return;
begin
savef1 := f1;
savew2 := w2;
return := w3;
w1 := return.param;
w2 := return.stackp;
w2 := (w2).word;
w3 := return.stdesc;
w3 := (w3).word;
w0 := return.paramdesc;
(w3).word := w0;
w0 extract 12;
if w0 >= 4 then move (.w3.,w0:=8,w1,w2)
else move (.w3.,w0:=2,w1,w2);
w3 := return.stackp;
(w3).word := w0 + (w3).word;
w3 := return.stdesc;
(w3).word := w0 := (w3).word + 2;
f1 := savef1;
w2 := savew2;
w3 := return;
end;
end;
body of idcommand
begin
record rcmd ( double cmd );
incode
word result, start;
ref return;
begin
return := w3;
start := w2;
result := w0 := - 1;
while w0 := result < 0 do
begin
w0 := (w2).word;
if w0 <> 0 then
begin comment not end of table yet;
f0 := (w1).cmd - (w2).cmd;
if w3 = 0 then
begin
if w0 zeromask -256 then
begin
w2+4-start;w2 lshift -2;
result := w2;
end;
end;
end else result := w0;
w2+4;
end; ! end while !
w0 := result;
w3 := return;
end;
end; ! idcommand !
end;
body of operator
comment operator coroutine;
begin
label outloop1,outloop2,outtext,
w_syntax,w_comm,w_plusparam,w_minusparam,w_unknown,
w_stateill,w_notallow,w_nores,w_recentry,w_recdevice,w_applkill;
incode
text(2) oproutput:= "=";
word char, partial;
ref bufpointer, stopbuf;
ref devcorout,transref;
byte kind, dummy;
array (1:10) tail of word;
text(11) destname;
ref destref,procref;
array (-4:16) comm_table of word :=
-4 ! empty line !
-3 ! - param !
-2 ! + param !
-1 ! syntax !
0 ! unknown !
1 ! start !
1 ! skip !
1 ! repeat !
1 ! restart !
1 ! stop !
1 ! kill !
1 ! suspend !
2 ! drain !
3 ! request !
4 ! signup !
5 ! signoff !
6 ! select !
7 ! route !
8 ! triang !
9 ! display !
0 ! end commands!;
! reply texts !
text(27) t_ready := "ready",
t_syntax := "***syntax",
t_comm := "***command unknown",
t_plusparam := "***command +param",
t_minusparam:= "***command -param",
t_unknown := "***device unknown",
t_stateill := "***state illegal",
t_notallow := "***not allowed",
t_nores := "***no resources",
t_recentry := "***receiver entry troubles",
t_recdevice := "***receiver device trouble",
t_applkill := "***killed by application";
! reply output format !
text(11) connecting:= "connecting";
text(3) zero:= "'0''0''0'";
ref return;
word
comno,paramno,param1type,freeparam;
byte
params1,paramt1,
shno ,thno,
shid ,thid,
params2,paramt2,
params3,paramt3;
text (11)
devname;
byte
dhlinkno, hostno;
word
hostid;
text (27)
parameters;
begin
return:= w3; call w3 return; ! pseudo call !
while w1=w1 do
begin
waitmess(.w3.,w2);
w0:= 1;
w1:= address(b.ans_status);
monitor(22); ! send answer !
w2:=address((w3).opr_console);
lookupremote(.w3.,w0:=2,w2,w0,w0,w1,w2:=address((w3).opr_dhlinkno));
move(.w3.,w0:=48,w1:=address(zero),w2:=address(zero)+2);
w1:= (w3).opr_buf; w2:= address((w1).buf_data1);
move(.w3.,w0:=2,w1:=address(oproutput),w2);
w1:= (w3).opr_buf;
(w1).buf_op:= w0:= 5;
(w1).buf_first:= w0:= address((w1).buf_data1);
(w1).buf_last:= w0:= w0;
w1:= (w3).opr_buf;
sendwait(.w3.,w0,w1,w2:=address((w3).opr_console));
(w1).buf_op:= w0:= 3;
w0:= (w1).buf_first;
w0+b.oprt_bufl-2;
(w1).buf_last:= w0;
sendwait(.w3.,w0,w1,w2);
! input received interpret command !
if w0<>1 then w0:= 0 else w0:= b.ans_bytes;
w1:= (w1).buf_first;
testout(.w3.,w0,w1,w2:=0);
bufpointer:= w1;
w1+w0; stopbuf:= w1;
getparams (.w3.,w3:=address(params1),w3:=address(devname),
w3:=bufpointer,w3:=stopbuf,w0);
w2 := w0;
w2 ashift -12;
comno := w2;
w0 extract 12;
paramno := w0;
if w0:= hostid=(w3:=b.current).opr_hostid then
w0 := paramt1;
if w0 = 0 then w0 := hostno else if w0 = 5 then w0 := 2 else if w0 = 4 then w0 := 1 else w0:=w0;
param1type := w0;
w0 := (w1:=address(parameters)).word;
w1 := paramt2 ;
if w1 = 3 then -(w0);
freeparam := w0;
testout(.w3.,w0:=48,w1:=address(comno),w2:=65);
if w0:=comno>0 then
begin
find_consoledevice(.w3.,w0:=param1type,w1:=address((w3).opr_console),
w2:=address(devname));
if w0<0 then goto w_notallow;
end;
devcorout:=w1;
case w1:=(comm_table(w2:=comno)).word + 5 of
begin
begin comment empty line;
end;
goto w_minusparam;
goto w_plusparam;
goto w_syntax;
goto w_comm;
begin ! put command into corou. descr. !
w1:=devcorout;
if w1=0 then goto w_unknown else
if w1<0 then goto w_stateill else
w1:=b.holdqfst;
w2:=address(b.holdqfst);
w0:=0; ! flag for found !
while w1<>w2 do
begin
if w1=devcorout then
begin
w0:=1;
w2:=w1;
end else w1:=(w1).c_next;
end;
w1:=devcorout;
case w2:=comno of
begin
begin comment start action;
if w0=0 then goto w_stateill;
if w0:=paramno=4 then
begin
w0:=(w1).tc_kind;
if w0=16 then w0:=10;
if w0<>10 then goto w_notallow; ! only for (card)reader !
w0:=freeparam;w0 lshift 12;
comno:=w0+comno;
end;
end;
begin comment skip action;
if w2:=(w1).tc_kind<>14 then goto w_notallow;
if w0=0 then goto w_stateill;
(w1).tc_workffs := w0 := freeparam;
end;
begin comment repeat action;
if w2:=(w1).tc_kind and 4094<>14 then goto w_notallow;
if w0=0 then goto w_stateill;
(w1).tc_workffs := w0 := freeparam;
end;
begin comment restart action;
w2:=(w1).tc_kind;
w2 and 4094;
if w2=12 then w2:=14;
if w2<>14 then goto w_notallow;
if w0=0 then goto w_unknown;
end;
begin comment stop action;
if w0<>0 then goto w_stateill;
end;
begin comment kill action;
if w0=0 then goto w_stateill;
end;
begin comment suspend action;
if w2:=(w1).tc_kind<>14 then goto w_notallow;
if w0=0 then goto w_stateill;
end;
end; ! end case !
(w1).tc_ointervent := w0 := comno;
if w0<>5 then
begin comment link to active queue;
link(.w3.,w1,w2:=address(b.activqfst));
end;
end; ! end start skip repeat restart stop kill suspend !
begin comment drain action;
w1:=devcorout;
if w1=0 then goto w_unknown;
if w1<0 then -(w1);
if w0:=(w1).tc_kind<>14 then goto w_notallow;
(w1).pr_drain := w0 := -1;
end;
begin comment request;
if w0:= paramno=0 then display(.w3.,w0:=1,w1) ! REQUEST ! else
if w1:= devcorout > 0 then display(.w3.,w0:=2,w1) ! REQUEST <device> ! else
if w0:= (w1:=address(devname)).word=6384748 then display(.w3.,w0:=3,w1) ! REQUEST all !
else goto w_unknown;
end; ! end display !
begin comment signup action;
w0:=-8388607;w1:=8388605;
w3:=address(zero);
monitor(72); ! set catalog base !
w1:= freeparam;kind:= w1;
if w0:=param1type=1 then
begin comment signup to local device;
if w1<>15 ! ibm 3270 printer ! then
begin
w3:=address(devname);
monitor(4); ! lookup process !
if w1:=w0=0 then goto w_unknown;
if w0:=(w1).word<>84 ! local link ! then goto w_unknown;
end; ! end not ibm printer !
w0:=0;hostno:=w0;hostid:=w0;
end else
begin comment signup to remote ;
if w1<>15 ! ibm 3270 printer ! then
begin
w3:=address(dhlinkno);
lookupremote(.w3.,w0:=4,w3,w3:=address(devname),
w0,w1,w2:=address(dhlinkno));
if w0=4096 then w0:=0;
if w0<>0 then
begin comment local link or device trouble;
if w0 extract 12<>0 then goto w_unknown
else goto w_stateill;
end;
end;
end;
find_tc(.w3.,w3:=address(devname),w3:=hostno,
w3:=hostid,w3:=kind,w1);
if w1=0 then goto w_nores else
if w1<0 then
begin
-(w1);
devcorout:= w1;
move(.w3.,w0:=8,w1:=address(devname),
w2:=address((w2:=devcorout).tc_devname));
if w0:=hostid=0 ! local device ! then
move(.w3.,w0:=8,w1,w2:=address((w2:=devcorout).tc_name));
w1:=devcorout;
(w1).tc_hostno:= w0:= hostno;
(w1).tc_hostid:= w0:= hostid;
end else devcorout:= w1;
if w0:= (w1).tc_held<>0 then (w1).tc_held:= w0:= 1;
w3:=b.current;
(w1).tc_ohno:= w0:= (w3).opr_hostno;
(w1).tc_ohid:= w0:= (w3).opr_hostid;
move(.w3.,w0:=8,w1:=address((w3).opr_console),
w2:=address((w2:=devcorout).tc_console));
w2:= address((w2:=devcorout).tc_devcons);
w0:= (w3).opr_hostno;
if w0 > (w3).opr_hostid then ! csp terminal ! move (.w3.,w0:=8,w1,w2) else
terminalid(.w3.,w0:=(w3).opr_dhlinkno,w2:=address((w2:=devcorout).tc_devcons));
testout(.w3.,w0:=!length(transpcorout),w1:=devcorout,w2:=68);
display(.w3.,w0:=2,w1); ! get request if any !
end; ! end signup !
begin ! signoff !
w1:=devcorout;
!test 250;
if w1=0 then goto w_unknown;
if w1<0 then -(w1);
if w0:=(w1).tc_kind=14 then
(w1).pr_headtrail:=w0:=b.prheadtrail;
w2:= address((w1).tc_console);
(w2).word:= w0:= 0;
w2:= address((w1).tc_devcons);
(w2).word:= w0;
(w1).tc_ohno:= w0;
(w1).tc_ohid:= w0;
if w0<>(w1).tc_held then (w1).tc_held:= w0:= 2;
end;
begin comment select <printer> (<qgroup>.<qname>)0/1;
w1:=devcorout;
if w1<0 then goto w_stateill else if w1=0 then goto w_unknown else;
if w0:=(w1).tc_kind<>14 then goto w_notallow;
if w0:=paramno=4 then
begin comment select <printer> (first/last/next/previous/suspend);
w0 := freeparam;
if w0=6711666 ! first ! then w0:=1 else
if w0=7102835 ! last ! then w0:=2 else
if w0=7234936 ! next ! then w0:=3 else
if w0=7369317 ! prev. ! then w0:=4 else
if w0=7566707 ! suspnd ! then w0:=5 else
goto w_syntax;
(w1).pr_select := w0;
end else
begin
move(.w3.,w0:=8,w1:=address(parameters),
w2:=address((w3:=devcorout).tc_qgroup));
move(.w3.,w0:=8,w1:=address(parameters)+8,
w2:=address((w3:=devcorout).tc_qname));
end;
if w0:=(w1:=devcorout).pr_drain=1 then
begin
w0:=0;
(w1).tc_held:= w0;
(w1).c_ic := w0;
link(.w3.,w1,w2:=address(b.activqfst));
end else (w1).pr_drain:= w0:= -1;
end;
begin comment route <printer> <device>
<device>::= catalog entry;
w1:=devcorout;
if w1<0 then goto w_stateill else if w1=0 then goto w_unknown else;
if w0:=(w1).tc_kind<>14 then goto w_notallow;
if w0:=(w1).pr_drain<>1 then goto w_stateill;
looktransport(.w3.,w1:=(w1:=devcorout.pr_queref).tq_transno,w2);
if w2<=0 then goto w_applkill;
transref:= w2;
w0:=(w2).tr_basel;w1:=(w2).tr_baseu;
w3:=address(zero);
monitor(72); ! set catalog base to that of sender !
tail(w1:=1);
w3:=address(parameters);
monitor(42); ! lookup entry !
if w0<>0 then goto w_recentry;
w0:=(tail(w1:=1)).word;
if w0=-8380402 then w0:=-8388594;
if w0<>-8388594 then goto w_recentry;
move(.w3.,w0:=8,tail(w1:=2),w2:=address(destname));
find_tc(.w3.,w0:=address(destname),w0:=(tail(w1:=7)).word,
w0:=(tail(w1:=8)).word,w0:=14,w1);
if w1=0 then goto w_nores;
destref := w1;
if w1<0 then
begin comment create coroutine;
-(w1);destref:=w1;
if w0:=(tail(w1:=7)).word=0 then
begin comment local device;
w3:=address(destname);
monitor(4); ! lookup process !
if w0=0 then goto w_recdevice;
procref:=w0;
end else
begin comment remote device;
tail(w1:=7);
lookupremote(.w3.,w0:=4,w0:=w1,w0:=address(destname),
w0,w1:=14,w2:=address(dhlinkno));
if w0<>4096 then goto w_recdevice;
procref:=w2;
end;
w1:=destref;
create_tc(.w3.,w1,w0:=address(destname),w0:=(tail(w2:=7)).word,
w0:=(tail(w2:=8)).word,w0:=procref);
end;
w0 := address((w1:=destref).tc_nexttr);
w3 := (w1:=devcorout).pr_queref;
link(.w3.,w1:=w3,w2:=w0);
w2:=transref;
(w2).tr_corou := w0 := destref;
move(.w3.,w0:=8,w1:=address(destname),w2:=address((w2).tr_rname));
puttransport(.w3.,w1:=devcorout.tc_transno);
w1:=devcorout;
w0:=0;
(w1).tc_held:= w0;
(w1).c_ic := w0;
link(.w3.,w1,w2:=address(b.activqfst));
end; ! end route <printer> <destprinter> !
begin comment triang <printer> (on/off);
w1:=devcorout;
if w1=0 then goto w_unknown;
if w1<0 then -(w1);
if w0:=(w1).tc_kind<>14 then goto w_notallow;
w0:=freeparam;
if w0=7302656 ! on ! then (w1).pr_headtrail := w0 := 1 else
if w0=7300710 ! off ! then (w1).pr_headtrail := w0 := 0 else
goto w_syntax;
end;
begin comment display ;
display(.w3.,w0:=4,w1);
end; ! end display !
end; ! case !
if w1<>w1 then
begin comment errortexts;
w_syntax: w1:=address(t_syntax); goto outtext;
w_comm: w1:=address(t_comm); goto outtext;
w_plusparam: w1:=address(t_plusparam); goto outtext;
w_minusparam: w1:=address(t_minusparam); goto outtext;
w_unknown: w1:=address(t_unknown); goto outtext;
w_stateill: w1:=address(t_stateill); goto outtext;
w_notallow: w1:=address(t_notallow); goto outtext;
w_nores: w1:=address(t_nores); goto outtext;
w_recentry: w1:=address(t_recentry); goto outtext;
w_recdevice: w1:=address(t_recdevice); goto outtext;
w_applkill: w1:=address(t_applkill); goto outtext;
end;
w1:= address(t_ready);
outtext:
! w1 abs ref reply text !
w2:= (w3:=b.current).opr_buf;
(w2).buf_op := w0:= 5;
w0:= (w2).buf_first;
bufpointer:= w0;
w0 + 32;
(w2).buf_last:= w0;
move(.w3.,w0:=18,w1,w2:=bufpointer+14);
outtime (.w3.,w2:=bufpointer);
move (.w3.,w0:=8,w1:=b.primo+2,w2:=bufpointer+4);
(w2:=bufpointer+12).word:= w0:= 58;
(w2:=bufpointer+32).word:= w0:= 10;
testout(.w3.,w0:=34,w1:=bufpointer,w2:=0);
sendwait(.w3.,w0,w1:=(w3).opr_buf,w2:=address((w3).opr_console1));
w0:= 0;
(w3).c_mbuf:= w0 ! clear operation !
end; ! loop !
end;
end; ! operator !
body of display
begin
procedure d_request(.w3.;w1); ! w1=device !
procedure d_display(.w3.;w1); ! w1=device !
incode
ref return,
device;
word function,
main;
begin
return:= w3;
device:= w1;
function:= w0;
push(.w3.,w0:= return);
case w1:= function of
begin
begin comment request ;
w1:= address(b.proc_dhlinkno);
w2:= address((w3).opr_dhlinkno);
compare(.w3.,w0:=4,w1,w2);
if w0=0 then w0:=1 else w0:=0;
main:= w0;
w1:= b.tcpool_fst;
device:= w1;
while w1<b.tcpool_top do
begin comment search all coroutines;
if w0:= device.tc_held<>0 then
begin comment device in hold state;
push(.w3.,w0:=main);
if w0<>0 then
begin comment main operator;
w1:= device;
if w0:=(w1).tc_held=2 then
begin
d_request(.w3.,w1);
end else
begin
w1:= address(b.proc_devname);
w2:= address((w2:=device).tc_devcons);
compare(.w3.,w0:=8,w1,w2);
w1:= device;
if w0=0 then w0:= b.proc_hid-(w1).tc_ohid;
if w0=0 then d_request(.w3.,w1);
end;
device:= w1;
end ! end main operator ! else
begin comment remote oprator;
w1:= address((w1:=device).tc_devcons);
w2:= address((w3).opr_devcons);
compare(.w3.,w0:=8,w1,w2);
w1:= device;
if w0=0 then w0:= (w1).tc_ohid-(w3).opr_hostid;
if w0=0 then d_request(.w3.,w1);
device:= w1;
end;
pop(.w3.,w0);main:= w0;
end; ! end hold !
w1:=device; device:= w1:= (w1).tc_nexttc;
end; ! end while !
end; ! end request !
begin comment request device(w1);
d_request(.w3.,w1:=device);
end; ! end request device !
begin comment request all;
w1:= b.tcpool_fst;
while w1<b.tcpool_top do
begin
if w0:=(w1).tc_held<>0 then
d_request(.w3.,w1);
w1:= (w1).tc_nexttc;
end; ! end while !
end; ! end request all !
begin comment display;
w1:=b.tcpool_fst;
while w1<b.tcpool_top do
begin
if w0:=(w1).tc_created<>0 then
begin
d_display(.w3.,w1);
end else
if w0:= (w2:=address((w1).tc_console)).word<>0 then
begin
d_display(.w3.,w1);
end else;
w1:= (w1).tc_nexttc;
end; ! end while !
end; ! end display !
end; ! end case !
pop(.w3.,w0);return:=w0;
w1:= device;
call w0 return;
end; ! end display code \f
!
body of d_request
begin
incode
ref return,
device;
text( 5) t_host:= ",host";
word l_hno:= 656174, ! radix=10, positions=3, fill="."(46) !
l_hid:= 656686; ! radix=10, positions=5, fill="."(46) !
begin
return:= w3;
device:= w1;
push(.w3.,w0:=return);
push(.w3.,w0:=device);
if w0:= device.tc_held<>0 then
begin
w1:=device.tc_buf;
w2:= (w3).opr_buf;
w0:= (w1).buf_last-(w1).buf_first+2;
w1:= address((w1).buf_data1);
if w0>b.oprt_bufl then key(l_hno):= w1;
w2:= address((w2).buf_data1);
move(.w3.,w0,w1,w2); ! move from device- to operator buffer !
w2:= (w3).opr_buf;
(w2).buf_op:= w1:= 5;
(w2).buf_mode:= w1:= 0;
(w2).buf_first:= w1:= address((w2).buf_data1);
w1+w0-2;
(w2).buf_last:= w1;
if w0:= device.tc_hold=1 then
begin comment maybe add host information;
if w0:= device.tc_hostid=device.tc_ohid then
if w0<>(w3).opr_hostid then
begin comment add host ident information;
w2:= w1;
w1:= address(t_host);
move(.w3.,w0:=4,w1,w2); ! <host> !
writeinteger(.w3.,w0:= device.tc_hostno,w1:= w2+4, w2:= l_hno);
writeinteger(.w3.,w0:= device.tc_hostid,w1:= w1+2, w2:= l_hid);
w2:= w1+4;
(w2).word:= w0:= 10; ! add newline !
w1:= (w3).opr_buf;
(w1).buf_last:= w2;
end;
end;
w1:= (w3).opr_buf;
w2:= address((w3).opr_console);
sendwait(.w3.,w0,w1,w2);
end;
pop(.w3.,w0);device:= w0;
pop(.w3.,w0);return:= w0;
w1:= device;
call w0 return;
end;
end; ! end d_request !
body of d_display
begin
record d_rec (
text(12) dev,
host,
proc, bs, oper, state);
incode
ref return,
device,
txtref;
word main;
word l_hno:= 656174, ! radix=10,pos=3,fill=46 !
l_hid:= 656686; ! radix=10,pos=5,fill=46 !
text (12)
t_active := ",active",
t_waiting:= ",waiting",
t_idle:= ",idle",
t_main:= "main ",
t_host;
text(4) space := " ";
begin
return:= w3;
device:= w1;
push(.w3.,w0:=return);
push(.w3.,w0:=device);
w1:= (w3).opr_buf;
w2:= address((w1).buf_data1);
txtref:= w2;
move(.w3.,w0:=2,w1:=address(space),w2);
move(.w3.,w0:=!length(d_rec)-2,w1:=w2,w2+2);
w1:= address((w1:=device).tc_devname);
addtxt(.w3.,w0:=8,w1:=address((w1:=device).tc_devname),
w2:=address((w2:=txtref).dev));
writeinteger(.w3.,w0:=(w1:=device).tc_hostno,
w1:=address((w1:=txtref).host),w2:=l_hno);
writeinteger(.w3.,w0:=(w2:=device).tc_hostid,
w1+2,w2:=l_hid);
addtxt(.w3.,w0:=6,w1:= address(t_host),
w2:= address((w2:=txtref).host));
if w0:=(w1:=device).tc_created<>0 then
addtxt(.w3.,w0:=8,w1:= address((w1:=device).tc_name),
w2:= address((w2:=txtref).proc));
w1:= address((w1:=device).tc_console);
if w0:=(w1).word<>0 then
addtxt(.w3.,w0:=8,w1:=address((w1:=device).tc_devcons),
w2:= address((w2:=txtref).oper));
if w0:=(w1:=device).tc_created<>0 then
begin
addtxt(.w3.,w0:=8,w1:=address((w1:=device).tc_bsname),
w2:=address((w2:=txtref).bs));
if w0:=(w1:=device).tc_held<>0 then w1:= address(t_waiting)
else w1:= address(t_active);
addtxt(.w3.,w0:=6,w1,w2:=address((w2:=txtref).state));
end else
begin
addtxt(.w3.,w0:=6,w1:=address(t_idle),w2:=address((w2:=txtref).state));
end;
w2+w0;
(w2).word:= w0:= 10 lshift 16; ! add newline !
w1:= (w3).opr_buf;
(w1).buf_last:= w2;
(w1).buf_first:= w0:= txtref;
(w1).buf_op:= w0:= 5;
(w1).buf_mode:= w0:= 0;
sendwait(.w3.,w0,w1,w2:=address((w3).opr_console));
pop(.w3.,w0); device:= w0;
pop(.w3.,w0); return:= w0;
w1:= device;
call w0 return;
end;
end; ! end d_display !
end; ! end display !
!branch 1,5;
body of get_block
begin
label in_bs,rep,exit;
incode
word zero:=0;
word buf_op;
ref buf_fa,buf_la;
word buf_segno;
word rem_bytes,buf_rel,relative,status;
ref return;
word savew0,savew1;
begin
return:=w3;
savew0:=w0;
savew1:=w1;
rem_bytes:=w0;
status:=w2:=2;
buf_rel:=w0:=0;
w3:=b.current;
f1 := (w3).tc_bsptr;
w1 extract 9;relative := w1;
f1 := (w3).tc_bsptr;
f1 ashift -9;
in_bs:
w3:=b.current;
if w1<>(w3).tc_csegno then
begin
(w3).tc_csegno:=w1;
rep:
push(.w3.,w0:=return);
push(.w3.,w0:=savew0);
push(.w3.,w0:=rem_bytes);
push(.w3.,w0:=buf_rel);
push(.w3.,w0:=savew1);
push(.w3.,w0:=relative);
w0:=(w3).tc_bsl;
w1:=(w3).tc_bsu;
w3:=address(zero);
monitor(72);
w3:=b.current;
buf_op:=w0:=3 lshift 12;
buf_fa:=w0:=(w3).tc_bsbuf;
w0+510;
buf_la:=w0;
buf_segno:=w0:=(w3).tc_csegno;
w1:=address(buf_op);
w2:=address((w3).tc_bsname);
sendwait(.w3.,w0,w1,w2);
w2:=1 lshift w0;
if w2=2 then w2 or b.ans_status;
status:=w2;
pop(.w3.,w0);relative:=w0;
pop(.w3.,w0);savew1:=w0;
pop(.w3.,w0);buf_rel:=w0;
pop(.w3.,w0);rem_bytes:=w0;
pop(.w3.,w0);savew0:=w0;
pop(.w3.,w0);return:=w0;
if w2:=status and 2'100100<>0 then
begin comment rejected/does not exist;
w0:=(w3).tc_bsl;
w1:=(w3).tc_bsu;
w3:=address(zero);
monitor(72); ! set catalog base !
w3:=b.current;
w3:=address((w3).tc_bsname);
monitor(52); ! create area process !
if w0=0 then monitor(8); ! reserve process !
w3:=b.current;
if w0<>0 then goto exit;
goto rep;
end;
end;
if w2:=status=2 then
begin
w0:=512-relative;
if w0>rem_bytes then w0:=rem_bytes;
w1:=(w3).tc_bsbuf+relative;
w2:=savew1+buf_rel;
move(.w3.,w0,w1,w2);
buf_rel:=w2:=w0+buf_rel;
rem_bytes:=w2:=rem_bytes-w0;
relative:=w0:=0;
w1:=(w3).tc_csegno+1;
if w2>0 then goto in_bs;
end;
exit:
w2:=status;
w1:=savew1;
w0:=savew0-rem_bytes;
call w0 return;
end;
end; ! end get_block !
body of put_block
begin
label out_bs,rep,exit;
incode
word zero:=0;
word put_segm;
word buf_op:=20480;
ref buf_fa,buf_la;
word buf_segno;
word rem_bytes,buf_rel,relative,status;
ref return;
word savew0,savew1;
begin
return:=w3;
savew0:=w0;
savew1:=w1;
rem_bytes:=w0;
status:=w2:=2;
buf_rel:=w0:=0;
w3:=b.current;
f1 := (w3).tc_bsptr;
w1 extract 9;relative := w1;
f1 := (w3).tc_bsptr;
f1 ashift -9;
put_segm:=w1;
out_bs:
w3:=b.current;
if w1:=put_segm<>(w3).tc_csegno then
begin
rep:
push(.w3.,w0:=return);
push(.w3.,w0:=savew0);
push(.w3.,w0:=rem_bytes);
push(.w3.,w0:=buf_rel);
push(.w3.,w0:=savew1);
push(.w3.,w0:=put_segm);
w0:=(w3).tc_bsl;
w1:=(w3).tc_bsu;
w3:=address(zero);
monitor(72);
w3:=b.current;
buf_fa:=w0:=(w3).tc_bsbuf;
w0+510;
buf_la:=w0;
buf_segno:=w0:=(w3).tc_csegno;
if w0>-1 then
begin comment output segment;
w1:=address(buf_op);
w2:=address((w3).tc_bsname);
sendwait(.w3.,w0,w1,w2);
w2:=1 lshift w0;
if w2=2 then w2 or b.ans_status;
end else
begin comment first call don'nt output segment;
w2:=2; ! simulate normal result/status=0 !
end;
status:=w2;
pop(.w3.,w0);put_segm:=w0;
pop(.w3.,w0);savew1:=w0;
pop(.w3.,w0);buf_rel:=w0;
pop(.w3.,w0);rem_bytes:=w0;
pop(.w3.,w0);savew0:=w0;
pop(.w3.,w0);return:=w0;
if w2:=status and 2'100100<>0 then
begin comment rejected/does not exist;
w0:=(w3).tc_bsl;
w1:=(w3).tc_bsu;
monitor(72); ! set catalog base !
w3:=b.current;
w3:=address((w3).tc_bsname);
monitor(52); ! create area process !
if w0=0 then monitor(8); ! reserve process !
w3:=b.current;
if w0<>0 then goto exit;
goto rep;
end;
(w3).tc_csegno:=w1:=put_segm;
w1:=(w3).tc_bsbuf;
w2:=w1+2;(w1).word:=w0:=0; ! fill buffer with zeroes !
move(.w3.,w0:=510,w1,w2);
relative:=w0:=0;
end;
if w2:=status=2 then
begin
w0:=512-relative;
if w0>=rem_bytes then w0:=rem_bytes else
begin comment no room on this segment;
w1:=w0;
w0:= 0;
(w3).tc_bsptr:=f1+(w3).tc_bsptr;
put_segm:=w1:=put_segm+1;
goto out_bs;
end;
if w0<0 then
begin comment close file;
w0:=512-relative;
w2:=(w3).tc_bsbuf+relative;
move(.w3.,w0 extract 9,w1:=w2-2,w2);
rem_bytes:=w0:=0;
put_segm:=w1:=put_segm+1;
goto out_bs;
end;
w2:=(w3).tc_bsbuf+relative;
w1:=savew1+buf_rel;
move(.w3.,w0,w1,w2);
rem_bytes:=w2:=rem_bytes-w0;
if w2>0 then
end;
exit:
w2:=status;
w1:=savew1;
w0:=savew0-rem_bytes;
call w0 return;
end;
end; ! end put_block !
body of closebs
comment
terminate the use of the area connected to current printer coroutine
;
begin
label inuse;
incode
ref return;
word zero:= 0;
double savef1;
begin
savef1:= f1;
return:= w3;
w3:= b.current;
w0:= (w3).tc_bsl;
w1:= (w3).tc_bsu;
w3:= address(zero);
monitor(72); ! set cat.base !
w3:=b.current;
w0:=(w3).tc_areaproc;
(w3).tc_areaproc:=w1:=0; ! clear area in use !
w1:=b.tcpool_fst;
while w1<b.tcpool_top do
begin
if w0=(w1).tc_areaproc then goto inuse;
w1:=(w1).tc_nexttc;
end;
w3:=address((w3).tc_bsname);
monitor(64); ! remove area process !
inuse: ! don't remove area process, it is in use !
f1:= savef1;
w3:= b.current;
call w0 return;
end;
end; ! closebs !
body of openbs
begin
incode
ref return;
double savef1;
word savew2;
word zero:=0;
begin
return:=w3;
savef1:=f1;
savew2:=w2;
w3:=b.current;
w0:=(w3).tc_bsl;
w1:=(w3).tc_bsu;
w3:=address(zero);
monitor(72); ! set catalog base !
w3:=address((w3:=b.current).tc_bsname);
monitor(52); ! create area process !
if w0=0 then monitor(8); ! reserve process !
w3+8; ! skip name !
(w3).word:=w1:=0; ! set name table address to 0 !
w3-8;
if w0=0 then monitor(4); ! process description !
(w3:=b.current).tc_areaproc:=w0;
(w3).tc_csegno:=w0:= -1;
f1:=savef1;
w2:=savew2;
call w0 return;
end
end; ! openbs !
body of hold
comment link current coroutine into the hold-queue;
begin
incode
ref return, a_return;
begin
return:= w3;
a_return:= w0; ! save alternate return !
w3:= b.current;
(w3).c_w0:= w0;
(w3).c_w1:= w1;
(w3).c_w2:= w2;
(w3).c_ic:= w0:= return;
(w3).tc_held:= w0:= (w3).tc_hold;
if w0=0 then
begin comment dont hold;
if w0:= a_return <> 0 then (w3).c_ic:= w0; ! alternate return used !
w1:= (w3).c_w1;
w2:= (w3).c_w2;
call w0 (w3).c_ic; ! continue !
end;
link(.w3.,w1:=w3,w2:=address(b.holdqfst));
testout(.w3.,w0:=!length(coroutine),w1,w2:=4);
goto b.activate;
end;
end; ! hold !
body of oproutput
begin
label rep_sw, exit;
record outformat ! output format !
(text( 6) time;
text(11) ownname;
word colon;
word outtype;
word asterix;
text(11) processname;
text(1) vartext); ! start of variable message !
incode
text( 5) t_host := ",host";
text( 9) t_resume := " resume ";
text( 9) t_prepare:= " prepare ";
text( 9) t1;
text(11) t1trname;
text( 1) t11:= " ";
text(11) t1truser;
text( 1) t12:= " ";
text(11) t1trqgroup;
text( 1) t13:= ".";
text(11) t1trqname;
text(15) t2 := " intervention",
t21 := " parity error",
t22 := " timer",
t23 := " data overrun",
t24 := " block length",
t25 := " end document",
t26 := " load point",
t27 := " tapemark, att",
t28 := " write enable",
t29 := " mode error",
t210:= " read error",
t211:= " card reject",
t212:= " bit 12",
t213:= " bit 13",
t214:= " bit 14",
t215:= " stopped",
t216:= " word defect",
t217:= " position err.",
t218:= " do'39'nt exist",
t219:= " disconnected",
t220:= " unintelligent",
t221:= " rejected",
t222:= " normal";
text(21) t3:= " stopped by operator";
text(14) t4:= " end transport"; word t4state;
text(10) t5:= " transmit";
text(14) t6:= " end of area";
text(21) t7:= " cu,device exeeded";
text(18) t8:= " printer unknown";
text(18) t9:= " printer reserved";
text(29)t10:= " no resources at device host";
text(21)tt1:= " printer unavailable";
text(13)tt2:= " printer busy";
text(16)tt3:= " printer offline";
text(18)tt4:= " printer command";
text(29)tt5:= " printer status(s0/s1) = hex.";double s0s1;
text(21)tt6:= " printer disconnected";
word textsize;
ref transref; ! abs ref descr of transport !
ref bufref; ! abs ref first of data in buffer !
text(14) clock:="clock";
word timeunit:= 0, timevalue:= 20;
word savew2;
begin
savew2:= w2;
w2:= b.current;
(w2).tc_saveic:= w3;
w3:= b.current;
w2:= (w3).tc_buf;
w2:= address((w2).buf_data1);
bufref:= w2;
if w0=1 then w0:= 0
else
if w0=2 then w0:= 2763306 ! *** !
else;
(w2).outtype:= w0;
(w3).tc_hold:= w0:= 1;
if w0:=(w3).tc_hostno<>0 ! remote ! then w0:= 64; ! asterix !
(w2).asterix:= w0;
case w1 of ! select variable text !
begin
begin
if w0:=(w3).tc_kind=14 then
begin
f1:=(w2:=(w3).pr_queref).tq_suspend;
w0 or w1;
if w0<>0 then w1:=address(t_resume) else w1:=address(t_prepare);
move(.w3.,w0:=6,w1,w2:=address(t1));
looktransport(.w3.,w1:=(w2:=(w3).pr_queref).tq_transno,w2);
end else
begin
move(.w3.,w0:=6,w1:=address(t_prepare),w2:=address(t1));
looktransport(.w3.,w1:=(w3).tc_transno,w2);
end;
transref:= w2;
move(.w3.,w0:=8,w1:=address((w2).tr_name),w2:=address(t1trname));
move(.w3.,w0,w1:=address((w1:=transref).tr_user),w2:=address(t1truser));
move(.w3.,w0,w1:=address((w1:=transref).tr_qgroup),w2:=address(t1trqgroup));
move(.w3.,w0,w1:=address((w1:=transref).tr_qname),w2:=address(t1trqname));
w1:= address(t1);
if w0:=(w2).word=0 then w0:= 24 else w0:= 44;
end;
begin ! status error !
w0:= -10; w1:= 0; w2:= savew2;
while w1=0 do
begin
f2 lshift 1; w0+10;
end;
w1:= address(t2);
w1+w0;
w0:= 10;
end; ! status error !
begin ! operator stop !
w1:= address(t3);
w0:= 14;
end;
begin ! end transport !
t4state:= w0:= savew2+ 4'02000300; ! state + " 0" !
w1:= address(t4);
w0:= 12;
end;
begin ! transmit !
w1:= address(t5); w0:= 8;
end;
begin ! end of bs-area during skip !
w1:=address(t6);w0:=10;
end;
begin ! cu,device exeeded !
w1:= address(t7);w0:= 14;
end;
begin ! not connected !
w1:= address(t8);w0:= 12;
end;
begin ! printer reserved !
w1:= address(t9);w0:= 12;
end;
begin ! no resources at device host !
w1:= address(t10);w0:= 20;
end;
begin ! printer unavailable !
w1:= address(tt1);w0:= 14;
end;
begin ! printer busy !
w1:= address(tt2);w0:= 10;
end;
begin ! printer offline !
w1:= address(tt3);w0:= 12;
end;
begin ! printer comand error !
w1:= address(tt4);w0:=12;
end;
begin ! unexpected result !
w3:= savew2; ! w3 = status bytes s0/s1 ( format printer status )!
comment convert to text, hexadecimal digits, in print line;
w2:= 0;f3 lshift 12;
if w2>9 then w2+87 else w2+48;w0:= w2;
w2:= 0;f3 lshift 4;
if w2>9 then w2+87 else w2+48;w0 lshift 8;w0+w2;
w0 lshift 8;w0+32;
w2:= 0;f3 lshift 4;
if w2>9 then w2+87 else w2+48; w1:= w2;
w2:= 0;f3 lshift 4;
if w2>9 then w2+87 else w2+48;w1 lshift 8;w1+w2;
w1 lshift 8;
s0s1:= f1;
w1:= address(tt5);w0:= 24;
end;
begin ! f8000 printer discnt. by discnt. command !
w1:= address(tt6);
w0:= 14;
end;
end; ! case !
! w1 abs ref start of variable text, w0 length of variable text !
textsize:= w0;
move(.w3.,w0,w1,w2:=address((w2:=bufref).vartext));
(w2+w0).word:= w1:= 10; ! terminate text with nl !
outtime(.w3.,w2:=address((w2:=bufref).time));
w1:=b.primo+2;
move(.w3.,w0:=8,w1,w2:=address((w2:=bufref).ownname));
bufref.colon:= w1:= 58; ! ":" !
move(.w3.,w0,w1:=address((w3).tc_devname),w2:=address((w2:=bufref).processname));
w1:= (w3).tc_buf;
(w1).buf_op:= w2:= 5;
(w1).buf_mode:= w2:= 0;
(w1).buf_first:= w2:= bufref;
if w0:=(w3).tc_hostid<>0 then
begin
if w0=b.proc_hid then w0:= (w3).tc_ohid;
if w0<>(w3).tc_ohid then
begin comment add host information;
move(.w3.,w0:=4,w1:=address(t_host),
w2:=address((w2:=bufref).vartext)+textsize);
w1:=w2+w0;
writeinteger(.w3.,w0:=(w3).tc_hostno,w1,
w2:= 10 lshift 8 + 3 lshift 8 + 46);
writeinteger(.w3.,w0:=(w3).tc_hostid,w1+2,
w2:= 10 lshift 8 + 5 lshift 8 + 46);
w1+4;(w1).word:= w0:= 10; ! add newline !
(w3).tc_hold:= w0:= 2;
w0:=10; ! extension to textsize !
end
else w0:=0;
end
else w0:=0;
w0+!length(outformat)+textsize;
w2:=bufref+w0-2;
w1:=(w3).tc_buf;
(w1).buf_last:=w2;
testout(.w3.,w0,w1:=(w1).buf_first,w2:=0);
rep_sw:
sendwait(.w3.,w0,w1:=(w3).tc_buf,w2:=address((w3).tc_console));
w2:= 1 ashift w0;
if w2=2 then w2+b.ans_status
else
begin
b.ans_bytes:= w0:= 0;
if w0:= w2 and 2'110000 <> 0 then ! does not exist, disconnected !
begin
if w0:=(w1:=address((w3).tc_devcons)).word<>0 then
begin
sendwait(.w3.,w0,w1:=address(timeunit),w2:=address(clock)); ! delay !
linkupremote(.w3.,w0:=8,w0:=(w3).tc_ohno,w0:=(w3).tc_ohid,
w0:=address((w3).tc_devcons),w0,w2);
w3:= b.current;
if w0=4096 ! created ! then
begin
w1:= w2; w1+2;
move(.w3.,w0:=8,w1,w2:=address((w3).tc_console));
goto rep_sw;
end
else w2:= 32;
end;
end;
end;
w1:= (w3).tc_buf;
if w0:=8'00200002 onemask w2 then ! no status bits except att and normal !
if w0:=(w1).buf_first+b.ans_bytes<=(w1).buf_last then goto rep_sw;
if w2<>2 then
begin
begin comment route to mainoperator;
if w0:=(w3).tc_hostid<>0 then
begin comment remote device;
if w0=(w3).tc_ohid then
begin comment operator was remote,
add host information;
w1:=(w3).tc_buf;w2:= (w1).buf_last;
move(.w3.,w0:=4,w1:=address(t_host),w2);
writeinteger(.w3.,w0:=(w3).tc_hostno,w1:=w2+4,
w2:= 10 lshift 8 + 3 lshift 8 + 46);
writeinteger(.w3.,w0:=(w3).tc_hostid,w1+2,
w2:= 10 lshift 8 + 5 lshift 8 + 46);
w2:=w1+4;(w2).word:= w0:= 10; ! add newline !
w1:=(w3).tc_buf;
(w1).buf_last:= w2;
end; ! end add host information !
end;
(w3).tc_hold:= w0:= 2;
w1:= (w3).tc_buf;
outmain(.w3.,w1,w2);
end;
end;
exit:
!test 1010;
call w0 (w3).tc_saveic;
end;
end; ! oproutput !
body of updatetransport
comment update description of transport;
begin
label exit;
incode
ref transref;
! answer wait and get state of transport !
byte awt_1:= 7, awt_2:= 0,
awt_3:= 4, awt_4:= 4'010000,
awt_5:= 1, awt_6:= 4'020001;
word awt_rcode:= 0;
byte awt_7:= 1, awt_8:= 4'010010;
text(11) awt_trname;
byte awt_9:= 1, awt_10:= 4'010001;
word awt_no;
byte awt_11:= 1000, awt_12:= 4'010000,
awt_13:= 3, awt_14:= 4'020000,
awt_15:= 4, awt_16:= 4'030001;
word awt_state;
byte awt_19:= 7, awt_20:= 4'030002;
word awt_ptr1, awt_ptr2;
byte awt_17:=6, awt_18:= 4'030002;
word awt_cause, awt_status;
double savef1;
word savew2;
ref return;
begin
savef1:= f1;
savew2:= w2;
return:= w3;
w3:= b.current;
awt_no:= w1:= (w3).tc_transno;
looktransport(.w3.,w1,w2);
if w2<=0 then goto exit; ! transport already updated !
transref:= w2;
awt_state:= w0:= (w3).tc_state;
(w2).tr_state:= w0;
awt_cause:= w0:= (w3).tc_cause;
(w2).tr_cause:= w0;
awt_status:= w0:= (w3).tc_status;
(w2).tr_status:= w0;
f1:=(w3).tc_bsptr;
f3:=f1 ashift -1;
f1++f3; ! convert halfwords to characters !
w2:=transref; w3:=b.current;
awt_ptr1:=w0;
awt_ptr2:=w1;
(w2).tr_charposition:=f1;
if w0:=(w2).tr_waitmess>0 then
begin ! pending wait operation !
move(.w3.,w0:=8,w1:=address((w2).tr_name),w2:=address(awt_trname));
if w1:=awt_state=5 ! completed ! then w1:= address(awt_ptr2)
else
if w1=6 ! aborted ! then w1:= address(awt_status)
else w1:= address(awt_state);
copyanswer(.w3.,w0:=address(awt_1),w1,w2:=transref.tr_waitmess);
b.waitbufs:= w0:= b.waitbufs+1;
w2:= transref;
w0:= 0;
(w2).tr_waitmess:= w0;
end;
if w1:=(w2).tr_removetime=8'37777776 then w1:= 0
else
begin
w1:= 108;
f1:= (w1).double+b.trsaveperiod lshift -20;
end;
(w2).tr_removetime:= w1;
puttransport(.w3.,w1:=awt_no);
exit:
f1:= savef1;
w2:= savew2;
w3:= b.current;
call w0 return;
end;
end; ! updatetransport !
body of check_devicestatus
comment check device status for current coroutine, and clear noise
in hwords transferred.
try to repair rejected and does not exist;
begin
incode
double savef1;
text(11) zero := "'0''0''0'";
word helpw2, helpw0;
ref return;
begin
savef1:= f1;
return:= w3;
w3:= b.current;
w2:= 1 ashift w0;
if w2=2 then w2+(w1).word
else
begin
w1+2; (w1).word:= w0:= 0; ! hwords:= 0 !
if w2=4 then
begin ! rejected !
w1:= address((w3).tc_name)+8;
(w1).word:= w0:= 0;
w0:=-8388607;w1:=8388605;
w3:=address(zero);
monitor(72); ! set catalog base !
w3:=b.current;
w3:= address((w3).tc_name);
monitor(8); ! reserve !
if w0=0 then w2:= 0; ! status = 0 means repeat operation !
end
else
if w0:= w2 and 2'110000 <> 0 then
begin ! does not exist !
if w0:= (w3).tc_hostno<>0 ! remote ! then
begin
helpw2:= w2;
if w0:= (w3).tc_hostid = 0 then
begin comment csp connected printer;
alloc_ifp (.w3.,w0:=(w3).tc_kind,w0:=(w3).tc_hostno,w0,w1,w2);
if w0 = 0 then
begin comment ok;
push (.w3., w0:= return);
push (.w3., w0:= helpw2);
w3:= b.current;
(w3).tc_devno:= w1;
conn_csp (.w3., w0, w2);
helpw0:= w0;
pop (.w3.,w0); helpw2:= w0;
pop (.w3.,w0); return:= w0;
w0:= helpw0;
if w0 = 0 then w0:= 4096 ! created ! else
begin
dealloc_ifp (.w3.,w1:=(w3).tc_devno,w1:=(w3).tc_hostno);
w3:= b.current;
(w3).tc_devno:= w1:= 0;
end;
end;
end else
linkupremote(.w3.,w0:=(w3).tc_kind,w0:=(w3).tc_hostno,
w0:=(w3).tc_hostid,w0:=address((w3).tc_devname),w0,w2);
w3:= b.current;
if w0=4096 ! created ! then
begin
w1:= w2; w1+2;
move(.w3.,w0:=8,w1,w2:=address((w3).tc_name));
w2:= 0; ! status=0 means repeat operation !
end
else
begin
move(.w3.,w0:=8,w1:=address(b.no_link)+2,w2:=address((w3).tc_name));
w2:= helpw2;
end;
end;
end else;
end;
f1:= savef1;
w3:= b.current;
call w0 return;
end;
end;
!branch 2,6;
body of conn_csp
begin
label exit;
incode
word zero:= 0; ! zero name !
ref return;
word csp_m0:= 32768, csp_m2:= 0, csp_m4:= 0, csp_m6:= 10,
csp_m8, csp_m10, csp_m12, csp_m14;
begin
return:= w3;
while w0 = w0 do ! for ever !
begin
w3:= b.current;
move (.w3.,w0:=8,w1:=address((w3).tc_devname),w2:=address((w3).tc_name));
(w2+8).word:= w0:= 0; ! clear name table address !
if w0:= (w3).tc_ointervent <> 0 then goto exit;
if w0:= (w3).tc_aintervent <> 0 then goto exit;
w3:= address(zero);
w0:= -8388607;w1:= 8388605;
monitor (72); ! set catalog base !
w3:= b.current;
w1:= (w3).tc_devno;
w3:= address ((w3).tc_name);
monitor (54); ! create peripheral process !
if w0 = 0 ! ok ! then
begin comment send connect printer message;
monitor (8); ! reserve process !
push (.w3.,w0:= return);
move (.w3.,w0:=8,w1:=address((w3).tc_name),w2:=address(csp_m8));
w1:= address (csp_m0);
w2:= address ((w3).tc_name);
sendwait (.w3.,w0, w1, w2);
if w0 = 1 then w1:= b.ans_status else w1:= 1 lshift w0;
pop (.w3., w0); return:= w0;
if w1 <> 2097152 ! timer ! then
begin
w0:= w1;
w2:= (w1:=(w1:=74).word+(w3).tc_devno+(w3).tc_devno).word;
call w0 return;
end;
end else goto exit;
end; ! end for ever !
exit: w0:= 5; ! result = does not exist !
call w0 return;
end;
end; ! end conn_csp !
body of disconn_csp
begin
incode
ref return;
word csp_m0:= 40960; ! release printer opeartion !
text (24) csp_a;
begin
return:= w3;
push (.w3.,w0:= return);
w3:= b.current;
w2:= address((w3).tc_name);
w1:= address(csp_m0);
sendwait (.w3.,w0,w1,w2);
pop (.w3.,w0);
return:= w0;
call w0 return;
end;
end;
body of prcause
begin
incode
double savef2;
ref return;
byte d1,d2,d3,d4,d5,d6,d7,d8;
text(2) tnorm := "'12'";
text(2) tnill := "";
text(27) tokill:= "'12'***killed by operator'10'";
text(28) takill:= "'12'***killed by application'10'";
text(42) tsdev := "'12'***sender device status: 8.",
trdev := "'12'***receiver device status: 8.",
todev := "'12'***operator device status: 8.";
ref btext,etext;
begin
savef2:=f2;
return:=w3;
w1:=(w3:=b.current).tc_state-4;
if w1<1 then w1:=1;if w1>4 then w1:=1;
case w1 of
begin
begin comment normal termination;
if w0:=(w3).pr_headtrail<>0 then w1:=address(tnorm) else w1:=address(tnill);
btext:=w1;etext:=w1;
end;
begin comment aborted transport;
w1:=(w3).tc_status;
for w2:=1 step 1 upto 8 do
begin
w0:=0;f1 lshift 3;w0+48;
case w2 of
begin
d1:=w0;
d2:=w0;
d3:=w0;
d4:=w0;
d5:=w0;
d6:=w0;
d7:=w0;
d8:=w0;
end;
end;
w1:=(w3).tc_cause;
case w1 of
begin
w2:=address(tsdev);
w2:=address(trdev);
w2:=address(todev);
end;
w1:=w2;w2+20;
btext:=w1;
w1+26;etext:=w1;
(w2).word:=w0:=d1 lshift 8+d2 lshift 8+d3;
w2+2;(w2).word:=w0:=d4 lshift 8+d5 lshift 8+d6;
w2+2;(w2).word:=w0:=d7 lshift 8+d8 lshift 8+10;
end; ! end aborted transport !
begin comment killed by operator;
btext:=w1:=address(tokill);
w1+16;etext:=w1;
end;
begin comment killed by application;
btext:=w1:=address(takill);
w1+16;etext:=w1;
end;
end; ! end case !
w0:= etext-btext+2;
w2:=address((w2:=(w3).tc_buf).buf_data1);
move (.w3.,w0,w1:=btext,w2);
f2:=savef2;
call w0 return;
end;
end; ! end prcause !
body of prlistid
begin
incode
ref return;
double savef2;
ref transref;
text(12) t_cont:= "contents of:";
text(13) t_trans:= "'10'transport :";
text(13) t_user := "'10'user :";
text(2) nlff:= "'10''12'";
begin
savef2:= f2; return:= w3;
w3:= b.current;
looktransport(.w3.,w1:=(w3).tc_transno,w2);
transref:= w2;
w2:= (w3).tc_buf; w2:= address((w2).buf_data1);
move(.w3.,w0:=8,w1:=address(t_cont),w2);
w2+w0;
move(.w3.,w0:=8,w1:=address((w1:=transref).tr_sname),w2);
w2+w0;
move(.w3.,w0:=10,w1:=address(t_trans),w2);
w2+w0;
move(.w3.,w0:=8,w1:=address((w1:=transref).tr_name),w2);
w2+w0;
move(.w3.,w0:=10,w1:=address(t_user),w2);
w2+w0;
move(.w3.,w0:=8,w1:=address((w1:=transref).tr_user),w2);
w2+w0;
move(.w3.,w0:=2,w1:=address(nlff),w2);
w2+w0;
w1:= (w3).tc_buf; w1:= address((w1).buf_data1);
w0:= w2-w1;
f2:= savef2;
w3:= b.current;
call w0 return;
end;
end;
body of prlistdate
comment generate a text containing the current date and time.
put the text into the buffer of current coroutine;
begin
procedure convertdecimal(.w3.;w0);
incode
text(11) ownname;
text(7) fillspaces:= " :";
word year,point1:=46,month,point2:=46,day,sp2:=32,
hour,point3:=46,min,nl:=10;
double savef2;
ref return;
begin
savef2:= f2; return:= w3;
w1:= b.primo+2;
move(.w3.,w0:=8,w1,w2:=address(ownname));
w1:= 108; ! get clock !
f1:= (w1).double;
f1 ashift -4; f1//(60*60*625);
w3:= 0; f0//(60*625);
convertdecimal(.w3.,w0);
min:= w0;
w0:= 0; f1//24;
convertdecimal(.w3.,w0);
hour:= w0;
f1 lshift 26;
w0+99111;
w3:= 0;
f0//1461; ! year !
w3 ashift -2;
w3*5; w3+461; f3//153;
if w3 ! month ! >=13 then
begin
w3-12; w0+1;
end;
month:= w3;
convertdecimal(.w3.,w0);
year:= w0;
convertdecimal(.w3.,w0:=month);
month:= w0;
w2+5; f2//5;
convertdecimal(.w3.,w0:=w2);
day:= w0;
w0:= address(nl); w1:= address(ownname);
w0-w1+2;
move(.w3.,w0,w1,w2:=address((w2:=(w3).tc_buf).buf_data1));
f2:= savef2;
w3:= b.current;
call w0 return;
end;
body of convertdecimal
begin
incode ref return;
begin
return:= w3;
w3:= 0;
f0//10;
w0+48 lshift 8+w3+48;
w3:= b.current;
call w0 return;
end;
end;
end; ! prlistdate !
body of pr
comment printer coroutine;
begin
label loop, closeup, suicide, no_op, pr_action, rep_print, endloop;
incode
text(21) t_start := "'12'operator start'10''10'",
t_skip := "'12'operator skip'10''10'",
t_repeat := "'12'operator repeat'10''10'",
t_restart:= "'12'operator restart'10''10'";
text(102) triang1:= "
***************
*************
***********
*********
*******
*****
***
*
'10'";
text(103) triang2:= "'10'
*
***
*****
*******
*********
***********
*************
***************'10''10'";
word partial;
ref first, last;
ref transref, queueref;
double savef1,minus_2:=-2;
word halt;
ref return;
begin
return:= w3; call w3 return; ! pseudo call !
while w1=w1 do
begin ! get next transport !
w1:= address((w3).tc_nexttr);
w1:= (w1).tq_next;
if w2:=address((w3).tc_nexttr)=w1 then goto suicide; ! end transp. queue !
! hold tranport if no corout in queue matches current !
w1:=address((w3).tc_nexttr);
case w2:=(w3).pr_select+1 of
begin comment select next transport;
begin comment select papertype;
if w2=w1 then queueref:= w2:= (w1).tq_next;
queueref:=w2:=(w2).tq_next;
while w2:=address((w3).tc_nexttr)<>w1 do
begin
queueref:=w1;
looktransport(.w3.,w1:=(w1).tq_transno,w2);
transref:=w2;
compare(.w3.,w0:=8,w1:=address((w2).tr_qgroup),w2:=address((w3).tc_qgroup));
if w0=0 then
compare(.w3.,w0:=8,w1:=address((w1:=transref).tr_qname),
w2:=address((w3).tc_qname));
halt:=w0;
if w0=0 then w1:=address((w3).tc_nexttr) else
begin
w1:=queueref.tq_next;
queueref:=w1;
end;
end;
end;
begin comment select first transport;
queueref:=w1:=(w1).tq_next;
end;
begin comment select last transport;
queueref:=w1:=(w1).tq_prev;
end;
begin comment select next transport;
queueref:=w1:=(w1:=(w3).pr_queref).tq_next;
end;
begin comment select previous transport;
queueref:=w2:=(w2:=(w3).pr_queref).tq_prev;
end;
begin comment select suspended transport;
w2:=w1;
w1:=(w1).tq_next;
while w2<>w1 do
begin
f0:=(w1).tq_suspend;
w0 or w3;
w0 or w3;
if w0<>0 then
begin comment found;
w2:=w1;
end else
begin comment not found;
w1:= (w1).tq_next;
comment check end of chain;
if w1=w2 then w2:= w1:= (w1).tq_next; ! skip header select first !
end;
end;
queueref:=w1;
w3:=b.current;
end;
begin comment select next/prev while active;
queueref:= w2:= (w3).pr_queref;
end;
end; ! end case !
(w3).pr_select := w0 := 0;
if w2:=address((w3).tc_nexttr)=w1:=queueref then
begin
halt:= w0:= 1;
queueref:=w1:=(w1).tq_next;
end;
(w3).pr_queref:=w1;
looktransport(.w3.,w1:=(w1).tq_transno,w2);
transref:=w2;
w1:= queueref;
w2:= transref;
(w3).tc_ointervent:= w0:= 0;
(w3).tc_aintervent:= w0;
(w3).tc_mode:= w0:= (w2).tr_mode;
(w3).tc_bsl:= w0:= (w2).tr_basel;
(w3).tc_bsu:= w0:= (w2).tr_baseu;
f1:=(w1).tq_suspend;
w0 or w1;
if w0<>0 then
begin comment suspended transport;
w2:=(w3).pr_queref;
(w3).tc_bsptr:= f1:= (w2).tq_suspend;
w1:=(w3).pr_queref;
w2:=transref;
comment if nothing else then repeat 2 pages;
(w3).tc_ointervent := w0 := 3; ! repeat !
(w3).tc_workffs := w0 := 2; ! 2 pages !
halt:=w0:=1;
end else
(w3).tc_bsptr:= f1:= (w2).tr_bsstartptr;
(w3).tc_state:= w0:= 0;
move(.w3.,w0:=8,w1:=address((w2).tr_bsarea),w2:=address((w3).tc_bsname));
move(.w3.,w0,w1:=address((w1:=transref).tr_qgroup),
w2:=address((w3).tc_qgroup));
move(.w3.,w0,w1:=address((w1:=transref).tr_qname),
w2:=address((w3).tc_qname));
if w0:=(w3).pr_headtrail<>0 then (w3).pr_inpstate:= w0:= -3
else (w3).pr_inpstate:= w0;
w0:=(w3).pr_drain;
w0 or halt;
if w0<>0 then
begin ! hold device !
(w3).pr_drain:= w0:= 1;
oproutput(.w3.,w0:=1,w1:=1,w2);
if w2<>2 then
begin
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 3; ! operator !
(w3).tc_status:= w2;
(w3).tc_ointervent := w0 := 0;
(w3).pr_inpstate := w0 := 1;
goto pr_action;
end;
hold(.w3.,w0:=0);(w3).tc_held:=w0:=0;
(w3).pr_drain:= w0:= 0;
end;
openbs(.w3.); ! prepare area !
f1 lshift 100;
w2:=(w3).pr_queref;
(w2).tq_suspend:= f1;
looktransport(.w3.,w1:=(w2).tq_transno,w2);
if w2<=0 then
begin comment killed by application while waiting for activation;
(w3).tc_ointervent := w0 := 0;
(w3).tc_aintervent := w0 := 1;
end;
(w3).tc_transno := w1;
loop:
if w2:=(w3).tc_ointervent<>0 then
begin comment operator intervention;
case w2 of
begin
begin comment start command;
w1:=address(t_start);
end;
begin comment skip action;
looktransport(.w3.,w1:=(w3).tc_transno,w2);
(w3).tc_worknls := w0 := 0;
(w3).pr_partial := w0 ;
(w3).pr_workptr := f1 := (w3).tc_bsptr;
(w3).pr_workstartptr := f1 := (w2).tr_bsstartptr;
while w0:=(w3).tc_workffs>0 do
begin comment skip until an appropiate number
of ff's, nl's or end medium is met;
w1:=(w3).tc_buf;
get_block(.w3.,w0:=(w3).tc_bufsize,
w1:=address((w1).buf_data1),w2);
if w0<=0 then (w3).tc_workffs := w0 := 0;
w1:=(w3).tc_buf;first:=w2:=address((w1).buf_data1);
w2-2;w0+w2;
last:=w0;
while w2+2<=last do
begin comment check buffer;
w1:=(w2).word;
if w1 onemask 2105376 then w1:=0 else
if w1 zeromask -2097152 then else
if w1 zeromask 57344 then else
if w1 zeromask 224 then else w1:=0;
while w1<>0 do
begin comment do it the slow way;
w0:=0;
f1 lshift 8;
if w0=10 then
begin comment newline;
(w3).tc_worknls := w0 := (w3).tc_worknls + 1;
if w0 = b.prlpage then w0:=12 else w0:=0;
end;
if w0=12 then
begin comment formfeed;
(w3).tc_worknls := w0 := 0;
(w3).tc_workffss := w0 := (w3).tc_workffs - 1;
if w0<1 then
begin comment stop searching;
w0:=12;f1 lshift -8;
(w3).pr_partial := w1;
w2-2;last:=w2;
w1:=0;
end;
end else
if w0=25 then
begin comment end of medium;
(w3).tc_workffs := w0 := 0;
w1:=w2-first;
(w3).tc_bsptr := f1+(w3).tc_bsptr;
oproutput(.w3.,w0:=1,w1:=6,w2);
if w2<>2 then
begin
(w3).tc_state := w0 := 6;
(w3).tc_cause := w0 := 3;
(w3).tc_status:= w2 ;
(w3).pr_inpstate := w0 := 1;
(w3).tc_ointervent := w0 := 0;
goto pr_action;
end;
hold(.w3.,w0:=0);(w3).tc_held:=w0:=0;
if w0:=(w3).pr_headtrail=0 then (w3).pr_inpstate := w0 else
(w3).pr_inpstate := w0 - 4;
goto loop;
end else;
end;
end;
w1 := last-first+2;
w0 := 0;
(w3).tc_bsptr := f1 + (w3).tc_bsptr;
end;
w1:=address(t_skip);
end; ! end skip action !
begin comment repeat action;
looktransport(.w3.,w1:=(w3).tc_transno,w2);
(w3).pr_partial := w0 := 0;
(w3).tc_worknls := w0 := 0;
(w3).pr_workptr := f1 := (w3).tc_bsptr;
(w3).pr_workstartptr := f1 := (w2).tr_bsstartptr;
comment backspace until an appropiate number of
formfeeds, newlines or start file is met.;
while w0:=(w3).tc_workffs>0 do
begin
w1:=(w3).tc_bufsize;
w0:=-1;-(w1);
(w3).tc_bsptr:= f1+(w3).tc_bsptr;
f1-(w3).pr_workstartptr;
if w0<0 then
begin comment cut blocksize;
w0:=w1+(w3).tc_bufsize;
(w3).tc_bsptr:= f2:= (w3).pr_workstartptr;
end else w0:=(w3).tc_bufsize;
if w0>0 then
get_block(.w3.,w0,
w1:=address((w1:=(w3).tc_buf).buf_data1),w2);
if w0<=0 then (w3).tc_workffs:=w0:=0;
w1:=(w3).tc_buf;first:=w2:=address((w1).buf_data1);
w2-2;w2+w0;
last:=w2;
w2+2;
while w2-2>=first do
begin comment check buffer;
w0:=(w2).word;
if w0 onemask 2105376 then w0:=0 else
if w0 zeromask -2097152 then else
if w0 zeromask 57344 then else
if w0 zeromask 224 then else w0:=0;
if w0<>0 then partial:=w1:=0;
while w0<>0 do
begin comment char value less than 32 detected;
w1:=partial;f1 lshift -8;partial:=w1;w1 lshift -16;
if w1=10 then
begin comment newline;
(w3).tc_worknls := w1 := (w3).tc_worknls + 1;
if w1=b.prlpage then w1:=12 else w1:=0;
end;
if w1=12 then
begin comment formfeed;
(w3).tc_worknls := w1 := 0;
(w3).tc_workffs := w1 := (w3).tc_workffs - 1;
if w1<1 then
begin comment stop searching;
w0:=12;w1:=partial;w1 lshift 8;f1 lshift -8;
(w3).pr_partial := w1;
w1:= w2-first;
w0:=0;
(w3).tc_bsptr:= f1+(w3).tc_bsptr;
w0:=0;
w2:=first;
end;
end else;
end;
end;
end;
w1:=address(t_repeat);
end; ! end repeat action !
begin comment restart action;
looktransport(.w3.,w1:=(w3).tc_transno,w2);
(w3).tc_bsptr := f1 := (w2).tr_bsstartptr;
w1:=address(t_restart);
end; ! end restart action !
begin comment stop action;
oproutput(.w3.,w0:=1,w1:=3,w2);
if w2<>2 then
begin
(w3).tc_state := w0 := 6; ! aborted !
(w3).tc_cause := w0 := 3; ! operator!
(w3).tc_status:= w2 ;
(w3).tc_ointervent := w0 := 0;
(w3).pr_inpstate := w0 := 1;
goto pr_action;
end;
(w3).tc_ointervent := w0 := 0;
hold(.w3.,w0:=0);(w3).tc_held:=w0:=0;
goto loop;
end; ! end stop action !
begin comment kill action;
(w3).tc_state := w0 := 7; ! killed by operator !
(w3).tc_ointervent := w0 := 0;
(w3).pr_inpstate := w0 := 1;
goto pr_action;
end; ! end kill action !
begin comment suspend action;
closebs(.w3.);
(w2:=(w3).pr_queref).tq_suspend:=f1:=(w3).tc_bsptr;
(w3).pr_drain:= w0 := 1;
(w3).pr_select:=w0:= 3; ! select next transport !
w0:=0;
(w3).c_ic:= w0;
goto b.activate;
end;
end; ! end case !
if w0:=(w3).pr_headtrail<>0 then (w3).pr_inpstate:=w0:=-4 else
(w3).pr_inpstate:=w0:=0;
(w3).tc_ointervent := w0 := 0;
end; ! end operator intervention !
if w2:=(w3).tc_aintervent<>0 then
begin
(w3).tc_state:= w0:= 8; ! killed by appl !
(w3).tc_aintervent := w0 := 0;
(w3).pr_inpstate := w0 := 1;
goto pr_action;
end;
pr_action:
case w2:=(w3).pr_inpstate + 5 of
begin ! get next input block !
move(.w3.,w0:=14,w1,
w2:=address((w2:=(w3).tc_buf).buf_data1));
move(.w3.,w0:=68,w1:=address(triang1),
w2:=address((w2:=(w3).tc_buf).buf_data1));
prlistdate(.w3.,w0);
prlistid(.w3.,w0);
begin ! normal input mode !
get_block(.w3.,w0:=(w3).tc_bufsize,w1:=address((w1:=(w3).tc_buf).buf_data1),w2);
if w0<=0 then
begin
(w3).tc_state:= w1:= 6; ! aborted !
(w3).tc_cause:= w1:= 1; ! sender !
(w3).tc_status:= w2;
end
else
begin
! cut block size down if an em-char is found in the block !
w1:= (w3).tc_buf; first:= w2:= address((w1).buf_data1);
w2-2;
w0+w2;
last:= w0;
if w0:=(w3).pr_partial<>0 then
begin
(w2+2).word := w0;
(w3).pr_partial := w0 := 0;
end;
while w2+2<=last do
begin
w0:=(w2).word;
if w0 onemask 2105376 then w0:=0 else
if w0 zeromask -1703936 then else
if w0 zeromask 58880 then else
if w0 zeromask 230 then else w0:=0;
w3:=0;
while w0<>0 do
begin
f0 lshift 8;
if w1:= w3 extract 8=25 then
begin
w3 lshift -8;
(w2).word:= w3;
last:= w2;
(w3:=b.current).tc_state:= w1:= 5; ! completed !
w0:= 0;
end;
end;
end;
w0:= last-first+2;
w3:= b.current;
end;
end;
prcause(.w3.,w0);
move(.w3.,w0:=70,w1:=address(triang2),
w2:=address((w2:=(w3).tc_buf).buf_data1));
prlistdate(.w3.,w0);
prlistid(.w3.,w0);
end; ! case !
if w0>0 then
begin ! write next output block !
rep_print:
push(.w3.,w0); ! save no of halfwords !
w1:= (w3).tc_buf;
(w1).buf_op:= w2:= 5; (w1).buf_mode:= w2:= (w3).tc_mode;
(w1).buf_first:= w2:= address((w1).buf_data1);
w2+w0-2; (w1).buf_last:= w2;
testout(.w3.,w0,w1:=(w1).buf_first,w2:=0);
w1:= (w3).tc_buf;
sendwait(.w3.,w0,w1,w2:=address((w3).tc_name));
check_devicestatus(.w3.,w0,w1:=address(b.ans_status),w2);
pop(.w3.,w0); ! restore number of halfwords !
if w2=0 then goto rep_print;
if w1:=(w3).pr_inpstate=0 then ! normal input mode !
begin
w1:=b.ans_bytes;
w0:=0;
f1++(w3).tc_bsptr;
(w3).tc_bsptr:=f1;
end;
w1:=(w3).pr_inpstate;
if w1<=0 then
if w2<>2 then
begin
begin
oproutput(.w3.,w0:=2,w1:=2,w2);
if w2<>2 then
begin
if w0<>w0 then
begin
no_op: w2:= 2'100000;
end;
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 3; ! operator !
(w3).tc_status:= w2;
goto closeup;
end;
hold(.w3.,w0:=address(no_op));(w3).tc_held:=w0:=0;
if w0:=(w3).pr_headtrail<>0 then (w3).pr_inpstate:= w0:= -4;
goto loop;
end;
end;
end;
case w2:=(w0:=(w3).pr_inpstate+1)+4 of
begin
(w3).pr_inpstate:= w0;
(w3).pr_inpstate:= w0;
(w3).pr_inpstate:= w0;
(w3).pr_inpstate:= w0;
begin ! normal input mode !
if w2:=(w3).tc_state>0 then
begin
(w3).pr_inpstate:=w0;
end;
end;
if w2:=(w3).pr_headtrail<>0 then (w3).pr_inpstate:=w0 else goto closeup;
(w3).pr_inpstate:= w0;
(w3).pr_inpstate:= w0;
goto closeup;
end;
!test 295;
goto loop;
closeup:
w3:= b.current;
w1:= (w3).pr_queref;
w0:= (w3).pr_select;
if w0 = 3 then w1:= (w1).tq_next else
if w0 = 4 then w1:= (w1).tq_prev else
w1:= 0;
if w1 <> 0 then (w3).pr_select:= w0:= 6;
if w1 = w2:= address((w3).tc_nexttr) then w1:= (w1).tq_next;
queueref:= w1;
link (.w3., w1:= (w3).pr_queref, w2:= address(b.tqfreefst));
(w3).pr_queref:= w1:= queueref;
closebs(.w3.);
updatetransport(.w3.);
if w0:=b.oprtdetails onemask 1 then oproutput(.w3.,w0:=1,w1:=4,w2:=(w3).tc_state);
end; ! operation !
suicide:
disconn_csp (.w3.);
w3:= b.current;
dealloc_ifp (.w3., w0:= (w3).tc_devno, w0:= (w3).tc_hostno);
remove_tc(.w3.,w1:=b.current);
goto b.activate;
end;
end; ! pr !
!branch 2,7;
body of pc
comment punch coroutine;
begin
label loop, no_op, rep, closeup, suicide;
incode
ref first, last;
ref transref, queueref;
ref return;
begin
return:= w3; call w3 return; ! pseudo call !
while w1=w1 do
begin ! get next transport !
w1:= address((w3).tc_nexttr);
w1:= (w1).tq_next;
if w2:=address((w3).tc_nexttr)=w1 then goto suicide; ! end transp. queue !
w1:= (w3).tc_nexttr;
queueref:= w1;
looktransport(.w3.,w1:=(w1).tq_transno,w2);
transref:= w2;
w1:= queueref;
(w3).tc_transno:= w0:= (w1).tq_transno;
link(.w3.,w1:=queueref,w2:=address(b.tqfreefst));
w2:= transref;
(w3).tc_ointervent:= w0:= 0;
(w3).tc_aintervent:= w0;
(w3).tc_mode:= w0:= (w2).tr_mode;
(w3).tc_bsl:= w0:= (w2).tr_basel;
(w3).tc_bsu:= w0:= (w2).tr_baseu;
(w3).tc_bsptr:= f1:= (w2).tr_bsstartptr;
(w3).tc_state:= w0:= 0;
move(.w3.,w0:=8,w1:=address((w2).tr_bsarea),w2:=address((w3).tc_bsname));
move(.w3.,w0,w1:=address((w1:=transref).tr_qgroup),
w2:=address((w3).tc_qgroup));
move(.w3.,w0,w1:=address((w1:=transref).tr_qname),
w2:=address((w3).tc_qname));
(w3).pc_inpstate:= w0:= -1;
begin ! hold device !
oproutput(.w3.,w0:=1,w1:=1,w2);
if w2<>2 then
begin
if w0<>w0 then
begin
no_op: w2:= 2'100000;
end;
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 3; ! operator !
(w3).tc_status:= w2;
goto closeup;
end;
hold(.w3.,w0:=address(no_op));(w3).tc_held:=w0:=0;
end;
openbs(.w3.); ! prepare area !
loop:
if w2:=(w3).tc_ointervent<>0 then
begin ! operator intervention !
!test 206;
case w2 extract 12 of
begin
begin ! start !
end; ! start !
begin comment skip;end;
begin comment repeat;end;
begin ! restart !
looktransport(.w3.,w1:=(w3).tc_transno,w2);
(w3).tc_bsptr:= f1:= (w2).tr_bsstartptr;
end;
if w0:=(w3).pc_inpstate<=0 then
begin ! stop !
oproutput(.w3.,w0:=1,w1:=3,w2);
if w2<>2 then
begin
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 3; ! operator !
(w3).tc_status:= w2;
goto closeup;
end;
(w3).tc_ointervent:= w0:= 0;
hold(.w3.,w0:=address(no_op));(w3).tc_held:=w0:=0;
(w3).pc_inpstate:= w0:= -1;
goto loop;
end;
begin ! kill !
(w3).tc_state:= w0:= 7; ! killed by operator !
goto closeup;
end
end; ! case !
(w3).tc_ointervent:= w2:= 0;
end;
if w2:=(w3).tc_aintervent<>0 then
begin
(w3).tc_state:= w0:= 8; ! killed by appl !
goto closeup;
end;
case w2:=(w3).pc_inpstate + 2 of
begin ! get next input block !
begin ! put 90 null chars !
w1:= address((w2:=(w3).tc_buf).buf_data1);
(w1).word:= w0:= 0;
move(.w3.,w0:=60,w1,w2:=w1+2);
end;
begin ! normal input mode !
get_block(.w3.,w0:=(w3).tc_bufsize,w1:=address((w1:=(w3).tc_buf).buf_data1),w2);
if w0<=0 then
begin
(w3).tc_state:= w1:= 6; ! aborted !
(w3).tc_cause:= w1:= 1; ! sender !
(w3).tc_status:= w2;
end
else
begin
! cut block size down if an em-char is found in the block !
w1:= (w3).tc_buf; first:= w2:= address((w1).buf_data1);
w2-2;
w0+w2;
last:= w0;
while w2+2<=last do
begin
w3:= 0;
w0:= (w2).word;
while w0<>0 do
begin
f0 lshift 8;
if w1:= w3 extract 8=25 then
begin
w3 lshift -8;
(w2).word:= w3;
last:= w2;
(w3:=b.current).tc_state:= w1:= 5; ! completed !
w0:= 0;
end;
end;
end;
w0:= last-first+2;
w3:= b.current;
end;
end;
begin ! put 90 null chars !
w1:= address((w2:=(w3).tc_buf).buf_data1);
(w1).word:= w0:= 0;
move(.w3.,w0:=60,w1,w2:=w1+2);
end;
end; ! case !
if w0>0 then
begin ! write next output block !
rep:
push(.w3.,w0); ! save no of halfwords !
w1:= (w3).tc_buf;
(w1).buf_op:= w2:= 5; (w1).buf_mode:= w2:= (w3).tc_mode;
(w1).buf_first:= w2:= address((w1).buf_data1);
w2+w0-2; (w1).buf_last:= w2;
testout(.w3.,w0,w1:=(w1).buf_first,w2:=0);
w1:= (w3).tc_buf;
sendwait(.w3.,w0,w1,w2:=address((w3).tc_name));
check_devicestatus(.w3.,w0,w1:=address(b.ans_status),w2);
pop(.w3.,w0); ! restore number of halfwords !
if w2=0 then goto rep;
if w1:=(w3).pc_inpstate=0 then ! normal input mode !
begin
w1:=b.ans_bytes;
w0:=0;
f1++(w3).tc_bsptr;
(w3).tc_bsptr:=f1;
end;
w1:=(w3).pc_inpstate;
if w1<=0 then
if w2<>2 then
begin
begin
oproutput(.w3.,w0:=2,w1:=2,w2);
if w2<>2 then
begin
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 3; ! operator !
(w3).tc_status:= w2;
goto closeup;
end;
hold(.w3.,w0:=address(no_op));(w3).tc_held:=w0:=0;
(w3).pc_inpstate:= w0:= -1;
goto loop;
end;
end;
end;
case w2:=(w0:=(w3).pc_inpstate+1)+1 of
begin
(w3).pc_inpstate:= w0;
begin ! normal input mode !
if w2:=(w3).tc_state>0 then
begin
(w3).pc_inpstate:= w0;
end;
end;
goto closeup;
end;
!test 295;
goto loop;
closeup:
closebs(.w3.);
updatetransport(.w3.);
if w0:=b.oprtdetails onemask 1 then oproutput(.w3.,w0:=1,w1:=4,w2:=(w3).tc_state);
end; ! get next transport !
suicide:
remove_tc(.w3.,w1:=b.current);
goto b.activate;
end;
end; ! pc !
!branch 2,8;
body of rd
comment reader coroutine;
begin
label loop, no_op, closeup, suicide;
incode
ref first, last;
ref transref, queueref;
ref return;
begin
return:= w3; call w3 return; ! pseudo call !
while w1=w1 do
begin ! get next transport !
w1:= address((w3).tc_nexttr);
w1:= (w1).tq_next;
if w2:=address((w3).tc_nexttr)=w1 then goto suicide; ! end transp. queue !
w1:= (w3).tc_nexttr;
queueref:= w1;
looktransport(.w3.,w1:=(w1).tq_transno,w2);
transref:= w2;
w1:= queueref;
(w3).tc_transno:= w0:= (w1).tq_transno;
link(.w3.,w1:=queueref,w2:=address(b.tqfreefst));
w2:= transref;
(w3).tc_ointervent:= w0:= 0;
(w3).tc_aintervent:= w0;
(w3).tc_mode:= w0:= (w2).tr_mode;
(w3).tc_bsl:= w0:= (w2).tr_basel;
(w3).tc_bsu:= w0:= (w2).tr_baseu;
(w3).tc_bsptr:= f1:= (w2).tr_bsstartptr;
(w3).tc_state:= w0:= 0;
move(.w3.,w0:=8,w1:=address((w2).tr_bsarea),w2:=address((w3).tc_bsname));
move(.w3.,w0,w1:=address((w1:=transref).tr_qgroup),
w2:=address((w3).tc_qgroup));
move(.w3.,w0,w1:=address((w1:=transref).tr_qname),
w2:=address((w3).tc_qname));
begin ! hold device !
oproutput(.w3.,w0:=1,w1:=1,w2);
if w2<>2 then
begin
if w0<>w0 then
begin
no_op: w2:= 2'100000;
end;
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 3; ! operator !
(w3).tc_status:= w2;
goto closeup;
end;
hold(.w3.,w0:=address(no_op));(w3).tc_held:=w0:=0;
end;
openbs(.w3.); ! prepare area !
loop:
if w2:=(w3).tc_ointervent<>0 then
begin ! operator intervention !
!test 206;
case w2 extract 12 of
begin
begin ! start !
(w3).rd_inpstate:= w0:= (w3).tc_ointervent lshift -12;
end; ! start !
begin comment skip;end;
begin comment repeat;end;
begin ! restart !
! command not allowed !
end;
begin ! stop !
oproutput(.w3.,w0:=1,w1:=3,w2);
if w2<>2 then
begin
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 3; ! operator !
(w3).tc_status:= w2;
goto closeup;
end;
(w3).tc_ointervent:= w0:= 0;
hold(.w3.,w0:=address(no_op));(w3).tc_held:=w0:=0;
goto loop;
end;
begin ! kill !
(w3).tc_state:= w0:= 7; ! killed by operator !
goto closeup;
end
end; ! case !
(w3).tc_ointervent:= w2:= 0;
end;
if w2:=(w3).tc_aintervent<>0 then
begin
(w3).tc_state:= w0:= 8; ! killed by appl !
goto closeup;
end;
! get next input block !
w1:= (w3).tc_buf;
(w1).buf_op:= w2:= 3; (w1).buf_mode:= w2:= (w3).tc_mode;
(w1).buf_first:= w2:= address((w1).buf_data1);
w2+(w3).tc_bufsize-2;
(w1).buf_last:= w2;
sendwait(.w3.,w0,w1,w2:=address((w3).tc_name));
check_devicestatus(.w3.,w0,w1:=address(b.ans_status),w2);
w1:= (w3).tc_buf;
if w0:=b.ans_bytes=0 then
begin
if w2=2 then goto loop;
(w1).buf_data1:= w0:= 4'012101210121; ! "<25><25><25>" !
if w0:= 8'01000002 ! end doc, normal ! onemask w2 then
begin
if w0:=(w3).rd_inpstate>0 then
begin ! file continues on another tape !
oproutput(.w3.,w0:=1,w1:=2,w2);
if w2<>2 then
begin
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 3; ! operator !
(w3).tc_status:= w2;
end
else
begin
hold(.w3.,w0:=address(no_op));(w3).tc_held:=w0:=0;
goto loop;
end;
end
else
begin
(w3).tc_state:= w0:= 5; ! completed !
end;
end
else
begin
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 1; ! sender !
(w3).tc_status:= w2;
end;
w0:= 2;
end;
w1:= (w1).buf_first;
if w2:=(w1).word<>4'012101210121 then testout(.w3.,w0,w1,w2:=0);
put_block(.w3.,w0,w1,w2);
w1:=w0; w0:=0;
if w2=2 then (w3).tc_bsptr:= f1+(w3).tc_bsptr
else
begin
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 2; ! receiver !
(w3).tc_status:= w2;
end;
if w0:=(w3).tc_state=0 then goto loop;
put_block(.w3.,w0:=-1,w1,w2); ! close file !
closeup:
closebs(.w3.);
updatetransport(.w3.);
if w0:=b.oprtdetails onemask 1 then oproutput(.w3.,w0:=1,w1:=4,w2:=(w3).tc_state);
end; ! get next transport !
suicide:
remove_tc(.w3.,w1:=b.current);
goto b.activate;
end;
end; ! rd !
!branch 2,9;
body of tw
comment tty coroutine;
begin
label loop, closeup, suicide;
incode
ref first, last;
ref transref, queueref;
ref return;
begin
return:= w3; call w3 return; ! pseudo call !
while w1=w1 do
begin ! get next transport !
w1:= address((w3).tc_nexttr);
w1:= (w1).tq_next;
if w2:=address((w3).tc_nexttr)=w1 then goto suicide; ! end transp. queue !
w1:= (w3).tc_nexttr;
queueref:= w1;
looktransport(.w3.,w1:=(w1).tq_transno,w2);
transref:= w2;
w1:= queueref;
(w3).tc_transno:= w0:= (w1).tq_transno;
link(.w3.,w1:=queueref,w2:=address(b.tqfreefst));
w2:= transref;
(w3).tc_ointervent:= w0:= 0;
(w3).tc_aintervent:= w0;
(w3).tc_mode:= w0:= (w2).tr_mode;
(w3).tc_bsl:= w0:= (w2).tr_basel;
(w3).tc_bsu:= w0:= (w2).tr_baseu;
(w3).tc_bsptr:= f1:= (w2).tr_bsstartptr;
(w3).tc_state:= w0:= 0;
move(.w3.,w0:=8,w1:=address((w2).tr_bsarea),w2:=address((w3).tc_bsname));
(w3).tw_inpstate:= w0:= 5;
oproutput(.w3.,w0:=1,w1:=5,w2);
if w2<>2 then
begin
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 3; ! operator !
(w3).tc_status:= w2;
goto closeup;
end;
openbs(.w3.); ! prepare area !
loop:
if w2:=(w3).tc_aintervent<>0 then
begin
(w3).tc_state:= w0:= 8; ! killed by appl !
goto closeup;
end;
! get next input block !
w1:= (w3).tc_buf;
(w1).buf_op:= w2:= 3; (w1).buf_mode:= w2:= (w3).tc_mode;
(w1).buf_first:= w2:= address((w1).buf_data1);
w2+(w3).tc_bufsize-2;
(w1).buf_last:= w2;
sendwait(.w3.,w0,w1,w2:=address((w3).tc_name));
check_devicestatus(.w3.,w0,w1:=address(b.ans_status),w2);
w1:= (w3).tc_buf;
if w0:=b.ans_bytes=0 then
begin
if w2=2 then goto loop;
(w1).buf_data1:= w0:= 4'012101210121; ! "<25><25><25>" !
if w0:= 8'10000002 ! timer , normal ! onemask w2 then
begin
if w0:=(w3).tw_inpstate>0 then
begin
(w3).tw_inpstate:= w0-1;
goto loop;
end
else
begin
(w3).tc_state:= w0:= 5; ! completed !
end;
end
else
begin
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 1; ! sender !
(w3).tc_status:= w2;
end;
w0:= 2;
end
else
(w3).tw_inpstate:= w2:= 0;
w1:= (w1).buf_first;
if w2:=(w1).word<>4'012101210121 then testout(.w3.,w0,w1,w2:=0);
put_block(.w3.,w0,w1,w2);
w1:=w0; w0:=0;
if w2=2 then (w3).tc_bsptr:= f1+(w3).tc_bsptr
else
begin
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 2; ! receiver !
(w3).tc_status:= w2;
end;
if w0:=(w3).tc_state=0 then goto loop;
put_block(.w3.,w0:=-1,w1,w2); ! close file !
closeup:
if w0:=b.oprtdetails onemask 1 then oproutput(.w3.,w0:=1,w1:=4,w2:=(w3).tc_state);
closebs(.w3.);
updatetransport(.w3.);
end; ! get next transport !
suicide:
remove_tc(.w3.,w1:=b.current);
goto b.activate;
end;
end; ! tw !
!branch 2,10;
body of getlines
begin
label rep, exit;
record conv_header(byte srccar, srcsize); ! srcsize=size of entry !
incode
word zero:= 0, status;
word buf_op;
ref buf_fa, buf_la;
word buf_segno;
ref dest_end, source_end;
ref start_sequence, end_sequence;
word conv,char;
ref sx, dx;
ref relative, savew2, return;
word s_partial, d_partial, partial; ! source/destination-partial word !
word trail0, segment;
begin
comment initialize local pointers;
return:= w3;
w3:= b.current;
s_partial:= w0:= (w3).fpr_partial;
(w3).fpr_spartial:= w0; ! save patial := partila !
d_partial:= w0:= 0;
sx:= w0;dx:= w0;
status:= w0:= 2;
w2:= address((w1:=(w3).tc_buf).buf_data1)+4;
savew2:= w2;
w2+(w3).tc_bufsize;
dest_end:= w2;
f1:= (w3).tc_bsptr;
(w3).fpr_sbsptr:= f1; ! save bs pointer:= bs pointer !
w1 extract 9; relative := w1;
f1:= (w3).tc_bsptr;
w1 ashift - 9;
if w1<>(w3).tc_csegno then
begin comment actual segment not in core;
w0:= 1 lshift 23;
w1 or w0;(w3).tc_csegno:=w1;
w1:= (w3).tc_bsbuf;
source_end:= w1;
end else
begin
w1:= (w3).tc_bsbuf;
w0:= w1+510;
source_end:= w0;
w1+relative;
w0:= 0;relative := w0;
end;
w2:= savew2;
conv:= w0:= 0;
w0:= (w3).fpr_partial;
while w2<dest_end do
begin comment while -, end medium and
-, end output buffer do;
w0:= s_partial; ! w0=partial word !
while w0=0 do ! if word exhausted then !
begin comment increase source index;
if w0:=conv>0 then
begin comment take input from convert sequence;
conv:= w0-2; ! decrease convert count !
pop(.w3.,w0); ! w0=convert chars !
if w0=0 then w1+2;
end else w1+2;
if w1>source_end then ! if end input block then !
begin comment inblock (source);
w3:= b.current;
w1:= (w3).tc_csegno;
if w1<0 then
begin
f1:= (w3).tc_bsptr;
if w1 zeromask 511 then
begin comment first block of transport;
f1 lshift - 9;
w1 - (w3).fpr_startsegment;
end;
if w1<>0 then
begin
w1:= relative;
w1+2;
if w1>510 then
begin comment next segment;
w1:= 0;relative:= w1;
w1:= 512;
end else relative := w1;;
w1 lshift - 9;
end;
w1+(w3).tc_csegno;
w1 and 8388607;
end else w1+1;
(w3).tc_csegno:= w1;
rep:
push(.w3.,w0:=return);
push(.w3.,w0:=w2);
push(.w3.,w0:=dest_end);
push(.w3.,w0:=d_partial);
push(.w3.,w0:=relative);
push(.w3.,w0:=trail0);
push(.w3.,w0:=sx);
push(.w3.,w0:=dx);
push(.w3.,w0:=partial);
push(.w3.,w0:=segment);
w0:= (w3).tc_bsl;
w1:= (w3).tc_bsu;
w3:= address(zero);
monitor(72); ! set catalog base !
w3:= b.current;
buf_op:= w0:= 3 lshift 12;
buf_fa:= w0:= (w3).tc_bsbuf;
w0+510;
buf_la:= w0;
buf_segno:= w0:= (w3).tc_csegno;
w1:= address(buf_op);
w2:= address((w3).tc_bsname);
sendwait(.w3.,w0,w1,w2);
w2:= 1 lshift w0;
if w2=2 then w2 or b.ans_status;
status:= w2;
pop(.w3.,w0);segment:= w0;
pop(.w3.,w0);partial:= w0;
pop(.w3.,w0);dx:= w0;
pop(.w3.,w0);sx:= w0;
pop(.w3.,w0);trail0:= w0;
pop(.w3.,w0);relative:= w0;
pop(.w3.,w0);d_partial:= w0;
pop(.w3.,w0);dest_end:= w0;
pop(.w3.,w0);w2:= w0;
pop(.w3.,w0);return:= w0;
w0:= (w3).tc_bsbuf;
w0+510;
source_end:= w0;
if w0:= status and 2'100100<>0 then
begin comment rejected/does not exist;
savew2:= w2;
w0:= (w3).tc_bsl;
w1:= (w3).tc_bsu;
w3:= address(zero);
monitor(72); ! set catalog base !
w3:= b.current;
w3:= address((w3).tc_bsname);
monitor(52); ! create area process !
if w0=0 then monitor(8); ! reserve process !
w3:= b.current;
-(w0);
if w0<>0 then ! not first block ! goto exit;
w2:= savew2;
goto rep;
end;
if w0:=status<>2 then
begin
w0:=0;
goto exit;
end;
w1:=(w3).tc_bsbuf+relative;
w0:= 0;conv:= w0;relative:= w0;
end;
if w0=0 then w0:= (w1).word; ! take partial word from source or convert sequence !
end;
w3:= 0; ! w3:= char(partial word) !
f0 lshift 8;
s_partial:= w0;
char:= w3; ! save char value !
if w3 and 127>0 then ! ignore if char excl. high bit = zero !
begin comment outchar ( destination, w3);
if w0:=d_partial>65535 then ! if partial word filled then !
begin comment increase destination index;
(w2).word:= w0; ! destination(x2):= partial_word !
w2+2;
w0:= 0; ! partial word := 0 !
end;
w0 lshift 8; ! partial word := partial word shift 8 + char !
w0+w3;
d_partial:= w0;
w3:= char; ! restore eventual high bit to avoid,
recursive call of convert sequence !
comment check character;
if w3<32 then
begin
if w3=10 then ! if char=10 then !
begin comment newline;
w3:= b.current;
while w0<65536 do
begin comment left justify chars;
w0 lshift 8;
w0+25; ! and fill with ETX's !
end;
comment save newline information: ;
trail0:= w0; ! trailer_0 !
sx:= w1; ! source index !
dx:= w2; ! destination index !
partial:=w0:= s_partial; ! partial word !
segment:=w0:=(w3).tc_csegno; ! segment number !
w3:= 10;
end ! end newline ! else
if w3=25 then
begin comment end medium;
while w0<65536 do
begin comment left justify chars;
w0 lshift 8;
w0+3;
end;
trail0:= w0; ! trailer0 !
sx:= w1; ! source index !
dx:= w2; ! destination index !
segment:=w0:= (w3:=b.current).tc_csegno; ! segment number !
(w3).tc_state:= w0:= 5;
(w3).fpr_inpstate:= w0:= 4; ! completed !
dest_end:= w2;
w3:= 25;
end ! end end medium ! else
if w3=12 then ! formfeed ! else
if w3=13 then ! carriage return ! else
begin comment check for convert sequences;
d_partial:= w0:= d_partial lshift -8; ! regret char !
char:= w3; ! save character !
w3:= (w3:=b.current).fpr_convert; ! search char conversion table !
w0:= - 1 lshift - 1;
while w0>0 do
begin comment end of table will yeild w0=0;
w0:= (w3).srccar; ! w0:= table_input_char(n) !
if w0=char then -(w0) ! if found then w0=negative ! else
w3+(w3).srcsize; ! w3:= next_entry !
end;
-(w0); ! if matching entry then w0>0 else w0=0 !
if w0>0 then
begin comment push convert sequence incl. s_patial
on the stack;
conv:= w0:= (w3).srcsize;
end_sequence:= w3;
w3+w0-2;
start_sequence:= w3;
push(.w3.,w0:=s_partial); ! orig. partial word last in sequence !
s_partial:= w0:= 0; ! force input check to read convert sequence !
w3:= start_sequence; ! take convert sequence bottom upp !
while w3>end_sequence do
begin comment push on stack;
w0:= (w3).word; ! w0 convert chars !
w0 or -8355712; ! add high bits to avoid recursive
call of convert sequence !
push(.w3.,w0); ! push convert chars on stack !
w3:= start_sequence-2; ! n=n-1 !
start_sequence:= w3;
end;
end else
begin comment no convert sequence defined -
wrap character in an escape seguence;
push(.w3.,w0:= s_partial);
comment add highbit to avoid escape trap ;
w3:= 155; ! escape sequence: !
w0:= char lshift - 4; ! char1:= char(0..3) !
if w0<10 then w0+48 else w0+87;
w0 lshift 16;f0 lshift 8;
w0:= char extract 4; ! char3:= hex(char(4..7)) !
if w0<10 then w0+48 else w0+87;
w0 lshift 16;f0 lshift 8;
push(.w3.,w0:=w3);
s_partial:= w0:= 0; ! force input chaeck to take input
from convert sequence !
conv:= w0:= 4;
end;
end; ! end convert !
end;
end; ! end char -, zerochar !
end; ! end while w2<dest_end !
while w0:=conv>0 do
begin
conv:= w0-2;
pop(.w3.,w0);
end;
if w0:=sx=0 then
begin comment the block did not contain any newlines;
w0 lshift 8;w0+25;
w0 lshift 8;w0+3;
trail0:= w0;
sx:= w1;
dx:= w2;
partial:= w0:= s_partial;
segment:= w0:=(w3:=b.current).tc_csegno;
end;
w3:= b.current;
(w3).fpr_partial:= w0:= partial;
w0:= 0;
w1:= segment;
f1 lshift 9;
w1+sx-(w3).tc_bsbuf;
(w3).tc_bsptr:= f1;
w2:= dx;
(w2).word:= w0:= trail0;
(w2+2).word:= w0:= 1639171; ! EM, ETX, ETX !
w1:=address((w1:=(w3).tc_buf).buf_data1);
w0:= w2-w1+2; ! no of halfwords output !
exit:
w2:= status;
call w0 return;
end;
end; ! end getlines !
body of connect_3270
begin
label reserve_printer, exit;
incode
text (14) clock:= "clock";
word zero:= 0;
word lb:= -8388607, ub:= -8388605;
ref return;
begin
push (.w3.,w0:= w3); ! save return address !
w0:= lb;w1:= ub;w3:= address(zero); monitor(72); ! set catalog base !
w1:= (w3:=b.current).fpr_stcorout;
w3:= address((w1).fpr_procout);
monitor (4); ! process description !
w3:= b.current;
w0:= (w1:=w0).word; ! w0 = kind (process) !
if w0=28 then
begin comment connected through adp3270;
w1:= (w3).fpr_stcorout;
if w0:= (w1).fpr_count=1 then
begin comment send application connect message;
w1:= (w3).tc_buf;
(w1).buf_op:= w0:= 4;
(w1).buf_mode:= w0:= 4;
w2:= address((w1).buf_last);
move (.w3.,w0:=8,w1:=address(b.primo_id),w2);
w1:= (w3).tc_buf;
w2:= address((w2:=(w3).fpr_stcorout).fpr_procout);
sendwait (.w3.,w0,w1,w2);
w1:= address(b.ans_status);
w2:= 1 lshift w0;
if w2=2 then (w1).word:= w2 or (w1).word else (w1).word:= w2;
if w2:=b.ans_status<>2 then
begin
(w3).tc_status:= w2;
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 2; ! receiver!
oproutput(.w3.,w0:= 2,w1:= 2, w2);
(w3).fpr_llcudev:= w0:= - 1;
goto exit;
end;
end;
comment send reserve printer message;
(w3).tc_retry:= w0:= 0;
reserve_printer:
w1:= (w3).tc_buf;
(w1).buf_op:= w0:= 0;
(w1).buf_mode:= w0;
w0:= (w3).tc_retry;
w2 := 1 lshift w0;
(w1).buf_first:= w2;
w2:= address(clock);
sendwait (.w3.,w0,w1,w2);
w1:= (w3).tc_buf;
(w1).buf_op:= w0:= 4;
(w1).buf_mode:= w0:= 16;
w0:= (w3).fpr_plcudev;
(w1).buf_last:= w0;
w2:= address((w2:=(w3).fpr_stcorout).fpr_procout);
sendwait (.w3.,w0,w1,w2);
if w0=4 then
begin comment cu not (yet?) connected;
if w0:= (w3).tc_retry < 7 then
begin
(w3).tc_retry:= w0:= (w3).tc_retry+1;
goto reserve_printer;
end;
w0:= 4; ! disconnected !
end;
w1:= address(b.ans_status);
w2:= 1 lshift w0;
if w2=2 then (w1).word:= w2 or (w1).word else (w1).word:= w2;
if w2:=b.ans_status<>2 then
begin
(w3).tc_status:= w2;
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 2; ! receiver!
oproutput(.w3.,w0:= 2,w1:= 2, w2);
(w3).fpr_llcudev:= w0:= - 1;
goto exit;
end else
if w1:=b.ans_bytes<>0 then
begin comment no connect;
case w1 of
begin
! 1, not processed - impossible ! ;
! 2, not used ! ;
! 3, no resources ! w1:= 10;
! 4, not used ! ;
! 5, not used ! ;
! 6, unavaileable ! w1:= 11;
! 7, device no. out of range ! w1:= 7;
! 8, device not printer ! w1:= 8;
! 9, not used ! ;
! 10, printer reserved ! w1:= 9;
! 11, not used ! ;
! 12, printer busy ! w1:= 12;
end; ! end case !
oproutput(.w3.,w0:=1,w1,w2);
(w3).tc_status:= w0:= 2;
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 2; ! receiver!
(w3).fpr_llcudev:= w0:= -1;
goto exit;
end else
(w3).fpr_llcudev:= w0:= (w3).fpr_plcudev;
end ! end adp3270 connected printer !
else
begin comment connected through m.rocs, NCP;
w1:= (w3).tc_buf;
(w1).buf_op:= w0:= 2 ;
(w1).buf_mode:= w0:= 6; ! connect mess !
w0:= (w3).fpr_plcudev;
(w1).buf_last:= w0;
w2:= address((w2:=(w3).fpr_stcorout).fpr_procout);
sendwait (.w3.,w0,w1,w2);
w1:= address(b.ans_status);
w2:= 1 lshift w0;
if w2=2 then (w1).word:= w2 or (w1).word else (w1).word:= w2;
if w2:=b.ans_status<>2 then
begin
(w3).tc_status:= w2;
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 2; ! receiver!
oproutput(.w3.,w0:= 2,w1:= 2, w2);
(w3).fpr_llcudev:= w0:= - 1;
goto exit;
end else
if w1:=b.ans_bytes<>0 then
begin comment no connect;
w1 extract 8;
oproutput(.w3.,w0:=1,w1+6,w2);
(w3).tc_status:= w0:= 2;
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 2; ! receiver!
(w3).fpr_llcudev:= w0:= -1;
goto exit;
end else
(w3).fpr_llcudev:= w0:= b.ans4;
end;
exit:
pop (.w3.,w0);
return:= w0;
call w0 return;
end;
end; ! end connect_3270 !
body of disc_3270
begin
incode
word zero:= 0;
word lb:= -8388607, ub:= -8388605;
ref return;
begin
push (.w3.,w0:= w3); ! save return address !
w0:= lb;w1:= ub;w3:= address(zero); monitor(72); ! set catalog base !
w1:= (w3:=b.current).fpr_stcorout;
w3:= address((w1).fpr_procout);
monitor (4); ! process description !
w3:= b.current;
w0:= (w1:=w0).word; ! w0 = kind (process) !
if w0=28 then
begin comment connected through adp3270;
comment send release printer message;
w1:= (w3).tc_buf;
(w1).buf_op:= w0:= 4;
(w1).buf_mode:= w0:= 20;
w0:= (w3).fpr_plcudev;
(w1).buf_last:= w0;
w2:= address((w2:=(w3).fpr_stcorout).fpr_procout);
sendwait (.w3.,w0,w1,w2);
w1:= (w3).fpr_stcorout;
if w0:= (w1).fpr_count=1 then
begin comment send application disconnect message;
w1:= (w3).tc_buf;
(w1).buf_op:= w0:= 4;
(w1).buf_mode:= w0:= 8;
w1:= (w3).tc_buf;
w2:= address((w2:=(w3).fpr_stcorout).fpr_procout);
sendwait (.w3.,w0,w1,w2);
end;
end ! end adp3270 connected printer !
else
begin comment connected through m.rocs, NCP;
w1:= (w3).tc_buf;
(w1).buf_op:= w0:= 2 ;
(w1).buf_mode:= w0:= 8; ! disconnect mess !
w0:= (w3).fpr_plcudev;
(w1).buf_data1:= w0;
w2:= address((w2:=(w3).fpr_stcorout).fpr_procout);
sendwait (.w3.,w0,w1,w2);
end;
pop (.w3.,w0);
return:= w0;
call w0 return;
end;
end; ! end disc_3270 !
body of fpr
comment format printer coroutine;
begin
label loop, no_op, rep, closeup, suicide;
incode
word ! adp3270 status codes: (see adp3270 reff. rcsl.991 - 09910)
first byte: AID(=156) sec. byte: SB !
! AID(=156)/SB: 7654321076543210 !
adp_end:= 2'1001110010000000,
adp_nready:= 2'1001110010000001,
adp_tout:= 2'1001110010000010,
adp_offline:= 2'1001110010000011,
adp_unav:= 2'1001110010000100,
! status bytes s0/s1 (see. rc855 ibm 3270 bsc emulator
- rcsl. 42-i1692) !
! s0/s1: 7654321076543210 !
dev_end:= 2'1100001001000000, ! hex: c2,40 !
dev_unavaileable:= 2'0100000001010000, ! hex: 40,50 !
dev_busy:= 2'1100100001000000, ! hex: c8,40 !
dev_offline:= 2'1100001001010000, ! hex: c2,50 !
dev_cmderror:= 2'0100000001100000; ! hex: 40,60 !
word oprhead0 := 3475487 ; ! write code lshift 16 (53) !
! + wcc lshift 8 ( 8) !
! + usm (31) !
word oprhead1 := 3475469 ; ! write code lshift 16 (53) !
! + wcc lshift 8 ( 8) !
! + cr (13);!
word oprhead2 ; ! characters or "cr"s part.word!
text (27) t_oprkill := "'10'***killed by operator'25''3''0''0'";
text (30) t_aplkill := "'10'***killed by application'25''3''0''0'";
text (30) t_oprfault:= "'10'***operator device trouble'25''3'";
ref transref, queueref;
ref relative;
word segment;
ref return;
begin
return := w3; call w3 return; ! pseudo call !
connect_3270 (.w3.);
while w1=w1 do
begin comment get next transport;
w1 := address((w3).tc_nexttr);
w1 := (w1).tq_next;
if w2:=address((w3).tc_nexttr)=w1 then goto suicide;
w1 := (w3).tc_nexttr;
queueref := w1;
looktransport(.w3.,w1:=(w1).tq_transno,w2);
transref := w2;
w1 := queueref;
(w3).tc_transno := w0 := (w1).tq_transno;
link(.w3.,w1:=queueref,w2:=address(b.tqfreefst));
if w0:= (w3).fpr_llcudev < 0 then goto closeup;
(w3).fpr_convert:= w0:= address(b.strttable);
w2 := transref;
(w3).tc_ointervent := w0 := 0;
(w3).tc_aintervent := w0 ;
(w3).tc_mode := w1 := (w2).tr_mode;
w0:= (w3).fpr_llcudev;w0 and 32639; w0 lshift 8; w0+27;
(w3).fpr_transid := w0; ! cu lshift 16 + dev lshift 8 + esc !
(w3).fpr_partial := w0 := 0;
(w3).tc_bsl := w0 := (w2).tr_basel;
(w3).tc_bsu := w0 := (w2).tr_baseu;
(w3).tc_bsptr:= f1 := (w2).tr_bsstartptr;
f1 ashift - 9;
(w3).fpr_startsegment:= w1;
(w3).tc_state:= w0 := 0;
move(.w3.,w0:=8,w1:=address((w2).tr_bsarea),w2:=address((w3).tc_bsname));
move(.w3.,w0,w1:=address((w1:=transref).tr_qgroup),
w2:=address((w3).tc_qgroup));
move(.w3.,w0,w1:=address((w1:=transref).tr_qname),
w2:=address((w3).tc_qname));
(w3).fpr_inpstate := w0 := 0;
openbs(.w3.); ! prepare area !
loop:
case w2:=(w3).tc_ointervent of
begin
begin comment start;
(w3).tc_ointervent:= w0:= 0;
end;
begin ! skip ! end;
begin comment repeat;
(w3).tc_ointervent:= w0:= 0;
get_block(.w3.,w0:=0,w1,w2);
f1:= (w3).tc_bsptr;
w1 extract 9;relative:= w1;
f1:= (w3).tc_bsptr;
f1 ashift - 9;
segment:= w1;
w1:= (w3).tc_bsbuf+relative-2;
while w0:= (w3).tc_workffs > 0 do
begin comment move back one page;
if w1<(w3).tc_bsbuf then
begin comment backspace one segment;
w0:=0;w1:= segment-1;
if w1>=(w3).fpr_startsegment then
begin
segment:= w1;
f1 lshift 9;
(w3).tc_bsptr:= f1;
get_block(.w3.,w0:=0,w1,w2);
if w2<>2 then
begin
(w3).tc_state:= w1:= 6;
(w3).tc_cause:= w1:= 1; ! sender !
(w3).tc_status:= w2;
goto closeup;
end;
f1:= (w3).tc_bsptr;
f1 ashift - 9;
segment:= w1;
w1:= (w3).tc_bsbuf+510;
end
else
begin comment start of file;
(w3).tc_workffs:= w0:= 0;
goto loop;
end;
end; ! end get segment !
comment check loop;
w0:=(w1).word;
if w0 onemask 2105376 then
else
begin comment check chars for newlines and ff's;
relative:= w1;
while w0<>0 do
begin
f1 lshift -8;
w1 lshift-16;
if w1=10 then
begin
(w3).tc_worknls:= w1:= (w3).tc_worknls+1;
if w1=b.prlpage then w1:= 12 else w1:=0;
end;
if w1=12 then
begin
(w3).tc_workffs:= w1:= (w3).tc_workffs-1;
(w3).tc_worknls:= w1:= 0;
end;
end;
w1:= relative;
end;
w1-2;
end; ! end backspace !
w0:= (w1+2).word;
relative:= w1-(w3).tc_bsbuf;
w2:= segment;
w2 lshift 9;
w2+relative;
(w3).tc_bsptr:= f2;
(w3).fpr_sbsptr:= f2;
w2:= w0; ! w0=w2==word containing ff or nl !
w1:= 0;
while w0<>0 do
begin
if w0 onemask 12 then
if w0 zeromask 243 then
begin comment ff found;
w0:= 12;
w2:= 0;
end;
f1 lshift -8;
end;
if w0:=w2<>0 then w1:= 0;
while w0<>0 do
begin comment no ff found find newline;
if w0 onemask 10 then
if w0 zeromask 245 then
begin
w0:=12; ! replace newline with formfeed !
end;
f1 lshift -8;
end;
(w3).fpr_partial:= w1;
end; ! end repeat !
begin comment restart;
w0:=0;w1:=(w3).fpr_startsegment;f1 lshift 9;
(w3).tc_bsptr:= f1;
(w3).fpr_partial:= w0:= 0;
(w3).tc_ointervent:= w0;
end; ! end restart !
begin comment stop command;
oproutput(.w3.,w0:=1,w1:=3,w2);
if w2<>2 then
begin
if w0<>w0 then
begin
no_op: w2:= 2'100000;
end;
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 3; ! operator!
(w3).tc_status:= w2;
(w3).tc_ointervent:= w0:= 0;
(w3).fpr_inpstate:= w0:=3;
end else
begin
(w3).tc_ointervent:= w0:=0;
hold(.w3.,w0:=address(no_op));(w3).tc_held:=w0:=0;(w3).tc_held:= w0:= 0;
goto loop;
end;
end; ! end stop action !
begin comment kill;
(w3).tc_state:= w0:= 7; ! killed by operator !
(w3).tc_ointervent:= w0:= 0;
(w3).fpr_inpstate:= w0:= 1;
if w0:= (w3).tc_cause=2 then goto closeup;
end;
end; ! end case !
if w0:= (w3).tc_aintervent<>0 then
begin
(w3).tc_state:= w0:= 8;
(w3).tc_aintervent:= w0:= 0;
(w3).fpr_inpstate:= w0:= 2;
end;
case w2 := (w3).fpr_inpstate+1 of
begin
begin comment normal input mode;
getlines(.w3.,w0,w2);
if w0 <= 0 then
begin
(w3).fpr_usedblock:= w0:= 0;
(w3).tc_state := w1 := 6; ! aborted !
(w3).tc_cause := w1 := 1; ! sender !
(w3).tc_status:= w2 ;
goto closeup;
end;
end; ! end normal input mode !
begin comment killed by operator;
w1:=(w3).tc_buf;
w2:= address((w1).buf_data1)+4;
move(.w3.,w0:=18,w1:=address(t_oprkill),w2);
w0+4;
end;
begin comment killed by application;
w1:=(w3).tc_buf;
w2:= address((w1).buf_data1)+4;
move(.w3.,w0:=20,w1:=address(t_aplkill),w2);
w0+4;
end;
begin comment operator device fault;
w1:=(w3).tc_buf;
w2:= address((w1).buf_data1)+4;
move(.w3.,w0:=20,w1:=address(t_oprfault),w2);
w0+4;
end;
begin ! end of input !
w0:= 0;
end;
begin ! completed !
goto closeup;
end;
end; ! end case !
if w0 > 0 then
begin comment write next output block;
w1 := (w3).tc_buf;
(w1).buf_first:= w2:= address((w1).buf_data1);
w2+w0-2;(w1).buf_last:= w2;
(w1).buf_op:= w0:= 5;
(w1).buf_mode := w0 := 0;
(w1:=(w1).buf_first).word := w2:= (w3).fpr_transid; ! cu,dev,esc!
if w0:=(w3).fpr_inpstate=0 then
(w1+2).word := w0 := oprhead0 ! transhead1 := wcode,wcc,usm ! else
(w1+2).word := w0 := oprhead1; ! transhead1 := wcode,wcc,cr !
w1:= (w3).tc_buf;
w0:= (w1).buf_last-(w1).buf_first+2;
testout(.w3.,w0,w1:= address((w1).buf_data1),w2:=0);
rep:
w1 := (w3).tc_buf;
sendwait(.w3.,w0,w1,w2:=address((w3:=(w3).fpr_stcorout).fpr_procout));
w2:= 1 lshift w0;
if w2=2 then w2 or b.ans_status;
if w2=2097154 ! timer status on output link ! then
begin
(w3).tc_status:= w2;
oproutput(.w3.,w0:=1,w1:=16,w2); ! disconnected !
(w3).tc_state:= w0:= 6;
(w3).tc_cause:= w0:= 2;
goto closeup;
end;
if w2=2 then wait_status(.w3.,w0:=2) else (w3).fpr_status:= w2;
if w2:=(w3).fpr_status<>2 then
begin
(w3).tc_status:= w2;
if w2=4 ! rejected ! then
begin
w3:= address((w3:=(w3).fpr_stcorout).fpr_procout);
monitor(8);
w3:= b.current;
if w0=0 then goto rep;
end;
(w3).tc_state:= w0:= 6; ! aborted !
(w3).tc_cause:= w0:= 2; ! receiver!
oproutput(.w3.,w0:=2,w1:=2,w2);
goto closeup;
end;
if w0:=(w3).fpr_devstatus<> dev_end then
if w0<> adp_end then
begin
if w0=dev_offline then w1:=13 else
if w0=dev_unavaileable then w1:= 11 else
if w0=dev_busy then w1:= 12 else
if w0=dev_cmderror then w1:= 14 else
if w0=adp_nready then w1:= 13 else
if w0=adp_tout then w1:= 13 else
if w0=adp_offline then w1:= 13 else
if w0=adp_unav then w1:= 11 else w1:= 15; ! unexpected result !
oproutput(.w3.,w0:=1,w1,w2:=(w3).fpr_devstatus);
(w3).tc_status:= w0:= 2;
(w3).tc_state:= w0:= 6;
(w3).tc_cause:= w0:= 2;
hold(.w3.,w0:=address(no_op));(w3).tc_held:= w0:= 0;
(w3).fpr_partial:= w0:= (w3).fpr_spartial;
(w3).tc_bsptr:= f1:= (w3).fpr_sbsptr;
if w0:= (w3).fpr_inpstate=4 then (w3).fpr_inpstate:= w0:= 0;
(w3).tc_csegno:= w0:= -1;
if w0:= (w3).fpr_devstatus=adp_unav then
begin
! send reserve printer message !
w1:= (w3).tc_buf;
(w1).buf_op:= w0:= 4;
(w1).buf_mode:= w0:= 16; ! reserve printer !
w0:= (w3).fpr_plcudev; ! cu device !
(w1).buf_last:= w0;
w2:= address((w2:=(w3).fpr_stcorout).fpr_procout);
sendwait (.w3., w0, w1, w2);
end;
goto loop;
end;
if w0:= (w3).fpr_inpstate<>0 then
(w3).fpr_inpstate:= w0:= 5;
end; ! end write next output block !
goto loop;
closeup:
closebs(.w3.);
updatetransport(.w3.);
if w0:= b.oprtdetails onemask 1 then oproutput(.w3.,w0:=1,w1:=4,w2:=(w3).tc_state);
end;
suicide:
disc_3270 (.w3.);
remove_fpr(.w3.,w1:=b.current);
remove_tc(.w3.,w1:=b.current);
goto b.activate;
end;
end; ! end fpr !
body of fpr_in
comment format printer coroutine for
input (status) handling;
begin
label sense_ready, input, loop;
incode
ref return;
word savew0;
word savew2;
word fi_op;
ref fi_first,fi_last;
word s0s1;
begin
return:= w3; call w3 return; ! pseudo call !
while w1=w1 do
begin comment forever do;
sense_ready:
w3:= b.current;
fi_op:= w0:= 2; ! sense ready operation !
w1:= address(fi_op);
sendwait(.w3.,w0,w1,w2:=address((w3).fpr_procin));
w2:= 1 lshift w0;
if w2=2 then w2 or b.ans_status;
w3:= b.current;
if w2=2 then
begin comment input (status) ready;
input:
w3:= b.current;
fi_op:= w0:= 3 lshift 12;
fi_first:= w0:= address((w3).fpr_indata);w0+2;
fi_last:=w0;
w1:= address(fi_op);
sendwait(.w3.,w0,w1,w2:=address((w3).fpr_procin));
w2:= 1 lshift w0;
if w2=2 then w2 or b.ans_status;
w3:= b.current;
if w2=2 then
begin comment input arrived;
w0:= b.ans_chars;
if w0=0 then goto sense_ready else
if w0<>5 ! status: "cu,dev,s0,s1,etx" ! then goto input else
testout(.w3.,w0:=8,w1:=address((w3).fpr_indata),w2:=48);
w0:=(w3).fpr_indata; ! w0= "cu,dev,s0" , w1= "s1,etx,xx"!
w1:=(w3).fpr_dat1;
f1 lshift -8; ! w0= "0,cu,dev" , w1= "s0,s1,xx"!
w1 lshift -8; ! w1= "0,s0,s1" !
w0 and 4'03330333;
s0s1:= w1;
w0 lshift 8;
w0+27; ! w0= cu,dev,esc !
comment find linked fpr with corresponding cu,dev;
w2:= address((w3).fpr_next);
w1:= (w2).c_next;
while w2<>w1 do
begin
savew0:= w0;
savew2:= w2;
if w0=(w1).fpr_transid then
begin
(w1).fpr_devstatus:= w0:= s0s1;
(w1).fpr_status:= w0:= 2;
link(.w3.,w1,w2:=address(b.activqfst));
(w3).fpr_wait:= w0:= (w3).fpr_wait - 1;
goto loop;
end;
f3:= (w3:=108).double;
f3 lshift - 19;
if w3>= (w1).fpr_timer then
begin
(w1).fpr_status:= w3:= 2097154; ! timer !
w0:= (w1).c_next;
link(.w3.,w1,w2:=address(b.activqfst));
(w3).fpr_wait:= w2:= (w3).fpr_wait-1;
w1:=w0; ! next in queue !
end else w1:= (w1).c_next;
w0:= savew0;
w2:= savew2;
end;
w3:= b.current;
goto loop; ! unknown device !
end;
end;
if w2=4 ! rejected ! then
begin
w3:= address((w3).fpr_procin);
monitor(8);
w3:=b.current;
if w0=0 then goto loop;
w2:=4;
end;
if w2=2097154 ! timer ! then
begin
w0:= address((w3).fpr_next);
w1:= (w3).fpr_next;
f3:= (w3:=108).double;
f3 lshift - 19;
w2:= w3;
while w0<>w1 do
begin
if w2 >= (w1).fpr_timer then
begin
(w1).fpr_status:= w3:= 2097154;
w0:= (w1).c_next;
link(.w3.,w1,w2:=address(b.activqfst));
(w3).fpr_wait:= w2:= (w3).fpr_wait-1;
f3:= (w3:=108).double;
f3 lshift - 19;
w2:= w3;
w1:= w0;
end else w1:= (w1).c_next;
end;
w3:= b.current;
goto sense_ready;
end else
begin
w1:= (w3).fpr_next;
if w1<>w0:= address((w3).fpr_next) then
begin
(w1).fpr_status:= w2;
link(.w3.,w1,w2:=address(b.activqfst));
(w3).fpr_wait:= w0:= (w3).fpr_wait - 1;
end;
end;
loop:
goto input;
end;
end;
end;
end.
▶EOF◀