|
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: 99072 (0x18300)
Types: TextFile
Names: »initamx4tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »initamx4tx «
begin
<* this program is used for ncp testing ncp revision 6.00 and later versions
version 3.0 date 84.07.02 release 13 of system utility
version 3.1 date 85.03.05 hlv minirocs command
dump high core error for more than
129 words
printer command defaults defined
version 3.2 date 85.05.24 lbj a dumpprogram can be loaded in a rc3600
which returns the coredump to rc8000.
from version 2.0 knowledge is used about the layout
of the printer coroutines. The name of the amx-driver
and amx-channel is read from the ssp-printerdrivers process-
description. This is all done in the procedure 'terminal'*>
integer array kind(0:100),alphabet(0:127),shdescr(1:12),zdescr(1:20);
real array ra(0:100),param(1:2),ncptest_name(1:2);
integer sep,space_name,point_name,space_integer,point_integer,
s_text,p_text,s_number,p_number,type,paramno,start_pos,
last,anything,i,j,int,byte,text,octal,bit,all,
supdev_pointer,max_link,prog_chain,proc_chain,
record_length,giveup, last_get_addr,dump_size,
mask,words,firstcore,lastcore,file;
boolean ok,not_online,morelines,sp,nl,host_connected,coredump,
ncptest,syntax_error;
zone supdev(43,1,blockproc),dumpz(128,1,blockproc);
real array field raf;
integer array field iaf;
procedure commands;
begin
write(out,<:info :>,nl,1,
<:typein :>,nl,1,
<:end :>,nl,1,
<:host :>,nl,1,
<:core :>,nl,1,
<:set :>,nl,1,
<:prog :>,nl,1,
<:proc :>,nl,1,
<:table :>,nl,1,
<:devicetable :>,nl,1,
<:bufferpool :>,nl,1,
<:buf :>,nl,1,
<:dump :>,nl,1,
<:movedump :>,nl,1,
<:diagnostic :>,nl,1,
<:sendwait :>,nl,1,
<:terminal :>,nl,1,
<:printer :>,nl,1,
<:hdlcstat :>,nl,1,
<:minirocs :>,nl,1,
<:format :>,nl,1);
end;
procedure info;
begin
next_param(s_text);
write(out,<:call:<10>:>,sp,7,case convert_to_number(param) of (
<:ncptest typein<10>
' makes the program enter the conversational mode ':>,
<:end<10>
' makes the program leave the conversational mode ':>,
<::>,<::>,
<:host <devicehost no><10>
' connects the program to devicehost no <devicehost no> ':>,
<:core <first address>(.<last address>)<10>
' prints the core from <first address> to <last address> ':>,
<:set <word address>.<content1> ... <contenti><10>
' modifies the contents from <word address> and on
with <content1>.. ':>,
<:prog.<item>(.<chainstart>) <first address>(.<last address>)<10>
' prints from <first address> to <last address>
relative to program <item>. if <chainstart> is entered the value
is used as start of the programchain, in all later calls the value
is used ':>,
<:proc.<item>(.<chainstart>) <first address>(.<last address>)<10>
' prints from <first address> to <last address>
relative to process <item>. if <chainstart> is entered the value
is used as start of processchain, and the corresponding value for
programchain is calculated ':>,
<:table.<table number> (entry.<first entry>(.<last entry>)) ,
(<first address>(.<last address>))<10>
' prints <first entry> to <last entry> of NCP's table no <table no> ':>,
<:devicetable (<first entry>(.<last entry>)
(<first address>(.<last address>)))<10>
' prints <first entry> to <last entry> of NCP's devicetable
each entry from <first address> to <last address>':>,
<:bufferpool (<first descr>(.<last descr>))<10>
' prints <first descr> to <last descr> of NCP's bufferpool descriptions ':>,
<:buf receiver.<name>
sender.<name> receiver.<name>
sender.<name><10>
' prints MUS message buffers ':>,
<:dump.<file name><10>
' changes the input to a file containing a coredump ':>,
<:movedump tape.<mt name> file.<bs name>,
main.<mainproc> file.<bs name><10>
' moves a rc3600 coredump from the tape <mt name> to
the bs file <bs name> or loads the rc3600 with a dump
program and reads the coredump ':>,
<:diagnostic (process.all!<proc name>(.event)),
(list.running.delay.proc.prog),
(corout.<firstcor> (<first>(.<last>))),
(buffer.<head>),
(chain.<firstitem>(.<chainoffset>) (<first>(.<last>)))<10>
' prints a diagnostic of process description and their event
queue, the running queue and the delay queue, the process
chain and the program chain ':>,
<:sendwait name.<name> mess.<mess0>.<mess1>.<mess2>.<mess3><10>
' send a message and waits for an answer ':>,
<:terminal dhlink.<no> (lookup) ! ((type.<termtype>),
(timer.<intimer>(.<outtimer>)) (s.<stopbits>) (p.<parity>),
(l.<charlength>) (r.<inrate>(.<outrate>)) (dc1.<dctype>) (echo.<quest>),
(prompt.<char>) (cont.<quest>) (cont.<quest>) (conv.<quest>) (att.<att>)
(mess.<quest>))<10>
' initialises the terminalcoroutine with devicehost linkno. <no> '
<termtype>= 0..9 <intimer>,<outtimer>= 0..255
<stopbits>=(1,2) <parity>=(n,o,e) <charlength>=(5,6,7,8)
<inrate>,<outrate>=(40,50,75,110,134,150,200,220,300,600,
1200,2400,4800,9600)
<dctype>=(input,output,both,no)
<quest>=(yes,no) <att>=(ena,disa)
Default values = current terminal specs:>,
<:printer dhlink.<no> (timer.<timer>) (s.<stopbits>),
(p.<parity>) (l.<charlength>) (r.<bitrate>) (dc1.<quest>)
' initializes the terminalprinter with devicehost linkno. <no> '
<stopbits>=(1,2) <parity>=(n,o,e) <charlength>=(5,6,7,8)
<bitrate>=(40,50,75,110,134,150,200,220,300,600,1200,2400,4800,9600)
<quest>=(yes,no)
Defalut specs = timer.60 s.2 p.e l.7 r.1200 dc1.no:>,
<:hdlcstat name.<driver> chan.<no>,
<driver>=(hlc,hlc1,hlc2,hlc3) <no>=(0,1,2,3)
' the command writes the statistics from the hdlc driver':>,
<:minirocs,
' the command writes the minirocs device tables'
contents of table 1 and 2 are displayed in decimal and
all displayed numbers are in the interval 0..max:>,
<:format octal.decimal.byte.bit.text.all.words.<words per line>.window.<first>(.<last>)<10>
' changes the layout of coredumps'
- the different presentations of 16 bit words
words - the number of words printed on a line
window - the first and last address to be printed of coreitems:>,
<:command not found:>
),nl,1);
end;
procedure host;
begin
integer devicehost;
next_param(s_number);
if coredump then close(dumpz,true);
coredump:=false;
devicehost:=round param(1);
link_host(devicehost);
supdev_pointer:=0;
end host;
procedure core;
begin
integer first,last;
check_host_online;
write(out,nl,1,<:*** core ***:>,nl,1);
core_specifications(first,last);
first:=octal_to_decimal(first);
last:=octal_to_decimal(last);
print_core(0,first,last,mask,words);
end;
procedure prog;
begin
real r;
check_host_online;
next_param(p_text);
r:= param(1);
write(out,nl,1,<:*** program :>,string param(1),<: ***:>,nl,1);
type:= anything;
next_param(type);
if type=p_number then
prog_chain:= octal_to_decimal(round param(1))
else
paramno:= paramno-1;
print_item(12 shift 12,r);
end prog;
procedure proc;
begin
real r;
check_host_online;
next_param(p_text);
r:= param(1);
write(out,nl,1,<:*** process :>,string param(1),<: ***:>,nl,1);
type:= anything;
next_param(type);
if type=p_number then
begin
proc_chain:= octal_to_decimal(round param(1));
set_3600_address(proc_chain+10);
prog_chain:= get_3600_word;
end
else
paramno:= paramno-1;
print_item(10 shift 12,r);
end proc;
procedure set;
begin
integer i;
if host_connected then
begin
next_param(s_number);
i:=octal_to_decimal(round param(1));
next_param(p_number);
setposition(supdev,0,0);
getshare6(supdev,shdescr,1);
shdescr(4):= 8 shift 12;
shdescr(5):= i;
setshare6(supdev,shdescr,1);
monitor(16)send message:(supdev,1,shdescr);
monitor(18)wait answer :(supdev,1,shdescr);
supdev_pointer:= max_link;
setposition(supdev,0,0);
i:=octal_to_decimal(round param(1));
outrec6(supdev,2);
supdev.iaf(1):=i shift 8;
type:=anything;
next_param(type);
while type=s_number do
begin
i:=octal_to_decimal(round param(1)) extract 16;
setposition(supdev,0,0);
outrec6(supdev,2);
supdev.iaf(1):=i shift 8;
type:=anything;
next_param(type);
end;
paramno:=paramno-1;
setposition(supdev,0,0);
supdev_pointer:=0;
end
else
begin
write(out,nl,1,<:***ncptest: :>,if -,coredump then <:no devicehost connected:>
else <:coredump mode:>,nl,1);
ok:= false;
end;
end set;
procedure table;
begin
integer tabno,first,last,word,first_entry,last_entry;
integer array tabdescr(0:5);
boolean first_type;
next_param(p_number);
tabno:=round param(1);
type:=anything;
next_param(type);
first_entry:=last_entry:=-1;
if param(1)=real<:entry:> and type=s_text then
begin
next_param(p_number);
first_entry:=last_entry:=round param(1);
type:=anything;
next_param(type);
if type=p_number then
last_entry:=round param(1)
else
paramno:=paramno-1;
end
else
paramno:=paramno-1;
check_host_online;
write(out,nl,1,<:*** table :>,tabno,<: ***:>,nl,1);
if get_tabdescr(tabdescr,tabno) then
begin
addr_specifications(first,last);
first:=octal_to_decimal(first);
last:=octal_to_decimal(last);
if first_entry=-1 then
begin
first_entry:=0;
last_entry:=tabdescr(5)-1;
end;
if last>= tabdescr(2)//2 then last:=tabdescr(2)//2-1;
if first>last then first:=last;
if last_entry>= tabdescr(5) then last_entry:=tabdescr(5)-1;
if first_entry>last_entry then first_entry:=last_entry;
first_type:=true;
for i:=first_entry step 1 until last_entry do
begin
word:=tab_start(tabdescr,i);
if word<>0 then
begin
if -,first_type then typein else first_type:=false;
write(out,nl,1,<:entry no : :>,<<dddd>,i,nl,1);
print_core(word,first,last,mask,words);
end;
end for i;
end else type_text(<:table not found:>);
end table;
procedure devicetable;
begin
integer first,last,first_addr,last_addr,word,i;
integer array tabdescr(0:5);
boolean first_type;
long l;
check_host_online;
write(out,nl,1,<:*** devicetable, table 120 ***:>,nl,1);
if get_tabdescr(tabdescr,120) then
begin
addr_specifications(first,last);
if last>=tabdescr(5) then last:=tabdescr(5)-1;
if first>last then first:=last;
addr_specifications(first_addr,last_addr);
first_addr:=octal_to_decimal(first_addr);
last_addr:=octal_to_decimal(last_addr);
if last_addr>= tabdescr(2)//2 then
last_addr:= tabdescr(2)//2 - 1;
if first_addr > last_addr then first_addr:=last_addr;
first_type:=true;
for i:=first step 1 until last do
begin
if -,first_type then typein else first_type:=false;
word:=tab_start(tabdescr,i);
write(out,nl,1,<:entry no : :>,<<dddd>,i,nl,2,<:core : :>);
write_formatted(word,octal); write(out,nl,1);
for j:=1 step 1 until last_addr+1 do
begin
if j>first_addr then
begin
case j of
begin
begin
write(out,<: 0: device semaphore:>,sp,4,<:: :>);
write_formatted(get_3600_word,octal);
write(out,nl,1);
end;
begin
word:=get_3600_word;
write(out,<: 1: link request:>,sp,8,<:: :>,
case (word shift (-11) extract 3)+1 of
(<:lookup reserve:>,<:lookup link local:>,<:lookup link remote:>,
<:lookup:>,<:lookup release:>,<:create link:>,<::>,<::>),nl,1,
<: link kind:>,sp,11,<:: :>,case (word shift (-6) extract 2)+1 of
(<:no link:>,<:remote link:>,<:central link:>,<::>),nl,1,
<: link state:>,sp,10,<:: :>,case (word extract 5)+1 of
(<:online:>,<:reserving:>,<:repeat reserving:>,<:creating:>,
<:opening:>,<:opening no link:>,<:closing:>,<:removing:>,
<:closing no link:>,<:regret reservation:>,<:regret creation:>,
<:regret opening:>,<:offline:>,<:prepare:>,<::>,<::>),nl,1);
end;
write(out,<: 2: reserver host:>,sp,7,<:: :>,<<dddddd>,get_3600_word,nl,1);
write(out,<: 3: job host id:>,sp,9,<:: :>,<<dddddd>,get_3600_word,nl,1);
begin
word:=get_3600_word;
write(out,<: 4: link events:>,sp,9,<:: :>,
case (word shift (-10) extract 5)+1 of
(<:none:>,<:timeout:>,<:answer reserve ok:>,<:answer reserve not ok:>,
<:answer create ok:>,<:answer create not ok:>,<:answer open:>,
<:prepare:>,<:answer close:>,<:answer remove:>,<:request create:>,
<:request remove:>,<:job host down:>,<:reserver host down:>,
<:lookup link local:>,<:release link:>,<:answer reserve link local:>,
<:answer reserve lookup reserve:>,<:answer reserve repeat:>),nl,1,
<: job host linkno:>,sp,5,<:: :>,<<dddddd>,word extract 10,nl,1);
end;
write(out,<: 5: max buffersize:>,sp,6,<:: :>,<<dddddd>,
get_3600_word extract 13,nl,1);
begin
word:=get_3600_word;
write(out,<: 6: no of buffers:>,<<dddddd>,sp,7,<:: :>,
word shift (-8) extract 8,nl,1,
<: timer:>,sp,15,<:: :>,word extract 8,nl,1);
end;
begin
write(out,<: 7: device name:>,sp,9,<:: :>);
write_formatted(get_3600_word,text);
end;
write_formatted(get_3600_word,text);
write_formatted(get_3600_word,text);
write_formatted(get_3600_word,text);
write_formatted(get_3600_word,text);
begin
word:=get_3600_word;
write_formatted(word shift (-8),text);
write(out,nl,1,<:14: kind:>,sp,16,<:: :>,<<dddddd>,word extract 8,nl,1);
end;
begin
word:=get_3600_word;
write(out,<:15: access count:>,sp,8,<:: :>,<<dddddd>,word,nl,1);
end;
begin
l:= extend get_3600_word shift 16 add get_3600_word;
write(out,<:16: bytes transferred:>,sp,3,<:: :>,<<dddddd>,l,nl,1);
end;
;
end case;
end
else word:= get_3600_word;
end for j;
end for i;
end else type_text(<:devicetable not found:>);
end devicetable;
procedure bufferpool;
begin
integer first,last,word,i,j;
integer array tabdescr(0:5);
boolean first_type;
check_host_online;
write(out,nl,1,<:*** bufferpool descriptions, table 121 ***:>,nl,1);
if get_tabdescr(tabdescr,121) then
begin
addr_specifications(first,last);
if last>= tabdescr(5) then last:=tabdescr(5)-1;
if first>=last then first:=last;
first_type:=true;
for i:=first step 1 until last do
begin
word:=tab_start(tabdescr,i);
if word<>0 then
begin
if -,first_type then typein else first_type:=false;
write(out,nl,1,<:entry no : :>,<<dddd>,i extract 12,nl,1,case i+1 of(
<:terminal:>,<:mp0:>,<:mp1:>,<:mp2:>,<:mp3:>,<:mp4:>,<:mp5:>,<:ap0:>,
<:ap1:>,<:ap2:>,<:ap3:>,<:rtci:>,<:test:>,<:xmt hdlc:>,<:rec hdlc:>,<:router:>),
<: pool:>,nl,2);
write(out,<:core : :>);
write_formatted(word,octal);
type_text(<::>);
for j:=1 step 1 until tabdescr(2)//2 do
begin
case j of
begin
write(out,<: 0: type:>,sp,16,<:: :>,<<dddddd>,get_3600_word extract 3);
begin
write(out,<: 1: :>,sp,20,<:: :>);
write_formatted(get_3600_word,octal);
end;
begin
write(out,<: 2: pool semaphore:>,sp,6,<:: :>);
write_formatted(get_3600_word,octal);
end;
begin
write(out,<: 3: chain:>,sp,15,<:: :>);
write_formatted(get_3600_word,octal);
end;
write(out,<: 4: no of free buffers:>,sp,2,<:: :>,<<dddddd>,get_3600_word);
write(out,<: 5: no of buffers:>,sp,7,<:: :>,<<dddddd>,get_3600_word);
write(out,<: 6: size of buffers:>,sp,5,<:: :>,<<dddddd>,get_3600_word);
write(out,<: 7: minimal free count:>,sp,2,<:: :>,<<dddddd>,get_3600_word);
write(out,<:10: access count:>,sp,8,<:: :>,<<dddddd>,get_3600_word);
write(out,<:11: wait count:>,sp,10,<:: :>,<<dddddd>,get_3600_word);
end case;
type_text(<::>);
end for j;
end if word<>0;
end for i;
end else type_text(<:bufferpool not found:>);
end bufferpool;
procedure buf;
begin
check_host_online;
begin
real sender;
integer receiver,word,i,j,l,k,addr;
integer array messbuf(1:max_link);
boolean first_type;
real array field raf;
first_type:=true;
receiver:=0;
sender:=real<:ncp:>;
raf:=0;
type:=anything;
next_param(type);
if type=s_text and (param(1)=real<:sende:> add 'r') then
begin
next_param(p_text);
sender:=param(1);
end else paramno:=paramno-1;
type:=anything;
next_param(type);
if (type=s_text) and (param(1)=real<:recei:> add 'v') and (param(2)=real<:er:>) then
begin
next_param(p_text);
receiver:=description(param(1),10 shift 12);
end else paramno:=paramno-1;
addr:=description(sender,10 shift 12);
if addr <> 0 then
begin
set_3600_address(addr+9);
word:=get_3600_word;
if word<>0 then
begin
write(out,nl,1,<:*** message buffers ***:>,nl,1);
repeat
set_3600_address(word);
for i:= 1 step 1 until max_link do
messbuf(i):=get_3600_word;
i:= -1;
repeat
i:=i+1;
if messbuf(i*10+6)=receiver or receiver=0 or messbuf(i*10+6)=(-receiver) extract 16 then
begin
if -,first_type then typein else first_type:=false;
print_buf(word,i,messbuf);
end;
until messbuf(10*i+3)=0 or 10*(i+2)>maxlink or messbuf(i*10+3)<>word+(i+1)*10;
word:=messbuf(10*i+3);
until messbuf(10*i+3)=0;
end if word<>0;
end else write(out,nl,1,<:sender not found:>,nl,1);
end;
end buf;
procedure dump;
begin
integer array tail(1:10);
integer i,j,modekind;
zone z(1,1,stderror);
next_param(p_text);
if host_connected then remove_link;
if coredump then begin close(dumpz,true); coredump:= false end;
j:=i:=1;
open(z,0,string param(increase(i)),0);
i:=monitor(42)lookup entry:(z,1,tail);
close(z,true);
if i= 0 then
begin
if tail(1)<0 then
begin
real array field raf;
modekind:= tail(1) extract 23;
raf:=2;
j:=1;
open(dumpz,modekind,string tail.raf(increase(j)),giveup);
dump_size:= 0;
file:= tail(7);
setposition(dumpz,file,0);
end
else
begin
open(dumpz,4,string param(increase(j)),giveup);
dump_size:= tail(1);
file:= 0;
setposition(dumpz,0,0);
end;
j:=1;
write(out,nl,1,<:dump : :>,string param(increase(j)),nl,1);
record_length:=inrec6(dumpz,0);
max_link:=((record_length*3)//4) shift (-1) shift 1;
supdev_pointer:=0;
coredump:= true;
end
else
write(out,nl,1,<:***ncptest: dumpentry not found:>,nl,1);
end dump;
procedure movedump;
begin
integer field iff;
integer i,j,transferred,words,halfwords;
integer array tail(1:10);
boolean em;
procedure blockproc(z,s,b);
zone z;
integer s,b;
if s shift 7 < 0 then
em:= true else
if s shift 16 > 0 then
stderror(z,s,b);
next_param(s_text);
if param(1)<>real<:main:> then
begin
zone savezone(2*128,2*1,stderror),dumpzone(2*128,2*1,blockproc);
next_param(p_text);
i:=j:=1;
open(dumpzone,0,string param(increase(i)),0);
i:= monitor(42) lookup entry:(dumpzone,1,tail);
close(dumpzone,true);
if i = 0 and tail(1) < 0 then
begin
real array field raf;
i:= 1; raf:= 2;
open(dumpzone,tail(1) extract 23,string tail.raf(increase(i)),giveup);
setposition(dumpzone,tail(7),tail(8));
end else
begin
open(dumpzone,18,string param(increase(j)),giveup);
setposition(dumpzone,0,0);
end;
next_param(s_text); <* file. *>
i:=1;
next_param(p_text);
open(savezone,4,string param(increase(i)),0);
i:=monitor(42)lookup entry:(savezone,1,tail);
if i<>0 then
begin
tail(1):=1;
tail(2):=1;
for i:=3 step 1 until 10 do tail(i):=0;
i:=monitor(40)create entry:(savezone,1,tail);
end;
if i=0 then
begin
setposition(savezone,0,0);
transferred:=0;
halfwords:=inrec6(dumpzone,0); <* blocklength *>
words:=((halfwords*3)//4) shift (-1) shift 1;
<* convert to 16 bits words *>
em:= false;
inrec6(dumpzone,halfwords);
while (transferred < 65535) and -,em do
begin
iff:=2;
for j:=3 step 3 until words*2 do
begin
outchar(savezone,dumpzone.iff shift (-16));
outchar(savezone,dumpzone.iff shift (-8) extract 8);
outchar(savezone,dumpzone.iff extract 8);
iff:=iff+2;
end;
j:=3-j+words*2;
for i:=1,2 do if j>=i then
outchar(savezone,dumpzone.iff shift ((i-3)*8) extract 8);
transferred:=transferred+words;
inrec6(dumpzone,halfwords);
end;
write(savezone,false,768);
getposition(savezone,i,j);
monitor(42)lookup entry:(savezone,1,tail);
tail(1):= j+1;
tail(6):= systime(7,0,0.0);
monitor(44)change entry:(savezone,1,tail);
end
else
write(out,nl,1,<:***ncptest: error in create entry:>,nl,1);
close(savezone,true);
close(dumpzone,true);
end <* tapedump *>
else begin
zone savezone (128,1,stderror), dumpzone (128,1,stderror);
integer array field iaf;
iaf:= 0;
next_param(p_text);
i:=j:= 1;
open(dumpzone,14,string param(increase(i)),0);
next_param(s_text); <* file. *>
i:=1;
next_param(p_text);
open(savezone,4,string param(increase(i)),0);
i:=monitor(42)lookup entry:(savezone,1,tail);
if i<>0 then
begin
tail(1):= 171;
tail(2):= 1;
for i:=3 step 1 until 10 do tail(i):=0;
i:=monitor(40)create entry:(savezone,1,tail);
end;
if i=0 then
begin
monitor(8)reserve process :(dumpzone,1,shdescr);
getshare6(dumpzone,shdescr,1);
shdescr(4):= 4 shift 12; <* reset *>
setshare6(dumpzone,shdescr,1);
monitor(16)send message:(dumpzone,1,shdescr);
monitor(18)wait answer:(dumpzone,1,shdescr);
getshare6(dumpzone,shdescr,1);
shdescr(4):= 6 shift 12 + 1; <* autoload, receive status *>
setshare6(dumpzone,shdescr,1);
outrec6(dumpzone,342);
monitor(16)send message :(dumpzone,1,shdescr);
monitor(18)wait answer:(dumpzone,1,shdescr);
getzone6(dumpzone,zdescr);
getshare6(dumpzone,shdescr,1);
shdescr(4):= 5 shift 12 + 0; <* transmit block *>
shdescr(5):= zdescr(19)+1;
shdescr(6):= zdescr(19)+1+342-2;
shdescr(7):= 512; <* size in bytes *>
shdescr(8):= 0; <* startbyte *>
setshare6(dumpzone,shdescr,1);
; <* .loc 0 *>
dumpzone.iaf(1):= 257 shift 8 + 26049 shift (-8) ; <* jmp .+1 *>
dumpzone.iaf(2):= 26049 shift 16 + 12317 ; <* dicp 0,1 enable hic *>
; <* lda 2,addr *>
dumpzone.iaf(3):= 14366 shift 8 + 10267 shift (-8) ; <* lda 3,buf *>
dumpzone.iaf(4):= 10267 shift 16 +8704 ; <* lda 1,m384 *>
; <* lda 0,0,2 *>
dumpzone.iaf(5):= 17152 shift 8 + 54016 shift (-8) ; <* sta 0,0,3 *>
dumpzone.iaf(6):= 54016 shift 16 + 64256 ; <* inc 2,2 *>
; <* inc 3,3 *>
dumpzone.iaf(7):= 43780 shift 8 + 5 shift (-8) ; <* inc 1,1,szr *>
dumpzone.iaf(8):= 5 shift 16 + 257 ; <* jmp 5 *>
; <* jmp .+1 *>
dumpzone.iaf(9):= 8222 shift 8 + 25088 shift (-8) ; <* lda 0,buf *>
dumpzone.iaf(10):= 25088 shift 16 + 8220 ; <* doa 0,0 *>
; <* lda 0,m768 *>
dumpzone.iaf(11):= 25600 shift 8 + 28224 shift (-8) ; <* dob 0,0 *>
dumpzone.iaf(12):=28224 shift 16 + 26432 ; <* docs 1,0 *>
; <* skpbz 0 *>
dumpzone.iaf(13):=511 shift 8 + 25856 shift (-8) ; <* jmp .-1 *>
dumpzone.iaf(14):=25856 shift 16 + 33284 ; <* dic 0,0 *>
; <* mov 0,0,szr *>
dumpzone.iaf(15):=26175 shift 8 + 8219 shift (-8) ; <* halt *>
dumpzone.iaf(16):=8219 shift 16 + 12317 ; <* lda 0,m384 *>
; <* lda 2,addr *>
dumpzone.iaf(17):=38144 shift 8 + 20509 shift (-8) ; <* sub 0,2 *>
dumpzone.iaf(18):=20509 shift 16 + 2 ; <* sta 2,addr *>
; <* jmp 2 *>
dumpzone.iaf(19):=65152 shift 8 + 64768 shift (-8) ; <*m384: -384 *>
dumpzone.iaf(20):=64768 shift 16 + 0 ; <*m768: -768 *>
; <*addr: 0 *>
dumpzone.iaf(21):= 32320 shift 8 ; <*buf: 8'77100 *>
; <* .loc 8'277 *>
dumpzone.iaf(128):= 63 ; <* 8'77 *>
dumpzone.iaf(129):=26943 shift 8 + 8702 shift (-8) ; <* reads 1 *>
dumpzone.iaf(130):=8702 shift 16 + 42752 ; <* lda 0,.-2 *>
; <* and 1,0 *>
dumpzone.iaf(131):=10454 shift 8 + 36352 shift (-8) ; <* lda 1,8'326 *>
dumpzone.iaf(132):=36352 shift 16 + 18646 ; <* add 0,1 *>
; <* sta 1,8'326 *>
dumpzone.iaf(133):=33536 shift 8 + 10253 shift (-8) ; <* inc 0,0 *>
dumpzone.iaf(134):=10253 shift 16 + 36352 ; <* lda 1,13. *>
; <* add 0,1 *>
dumpzone.iaf(135):=18445 shift 8 + 10255 shift (-8) ; <* sta 1,13. *>
dumpzone.iaf(136):=10255 shift 16 +36352 ; <* lda 1,15. *>
; <* add 0,1 *>
dumpzone.iaf(137):=18447 shift 8 + 10256 shift (-8) ; <* sta 1,15. *>
dumpzone.iaf(138):=10256 shift 16 + 36352 ; <* lda 1,16. *>
; <* add 0,1 *>
dumpzone.iaf(139):=18448 shift 8 + 10257 shift (-8) ; <* sta 1,16. *>
dumpzone.iaf(140):=10257 shift 16 + 36352 ; <* lda 1,17. *>
; <* add 0,1 *>
dumpzone.iaf(141):=18449 shift 8 + 10259 shift (-8) ; <* sta 1,17. *>
dumpzone.iaf(142):=10259 shift 16 + 36352 ; <* lda 1,19. *>
; <* add 0,1 *>
dumpzone.iaf(143):=18451 shift 8 + 26432 shift (-8) ; <* sta 1,19. *>
dumpzone.iaf(144):=26432 shift 16 + 511 ; <* skpbz 0 *>
; <* jmp .-1 *>
dumpzone.iaf(145):=10470 shift 8 + 36352 shift (-8) ; <* lda 1,346 *>
dumpzone.iaf(146):=36352 shift 16 + 18662 ; <* add 0,1 *>
; <* sta 1,346 *>
dumpzone.iaf(147):=10467 shift 8 + 36352 shift (-8) ; <* lda 1,343 *>
dumpzone.iaf(148):=36352 shift 16 + 18659 ; <* add 0,1 *>
; <* sta 1,343 *>
dumpzone.iaf(149):=10468 shift 8 +36352 shift (-8) ; <* lda 1,344 *>
dumpzone.iaf(150):=36352 shift 16 + 18660 ; <* add 0,1 *>
; <* sta 1,344 *>
dumpzone.iaf(151):= 34128 shift 8 + 33472 shift (-8); <* subzl 0,0 *>
dumpzone.iaf(152):= 33472 shift 16 + 26176 ; <* movs 0,0 *>
; <* docs 0,0 *>
dumpzone.iaf(153):=26432 shift 8 + 511 shift (-8) ; <* skpbz 0 *>
dumpzone.iaf(154):=511 shift 16 + 25856 ; <* jmp .-1 *>
; <* dic 0,0 *>
dumpzone.iaf(155):=33284 shift 8 + 26175 shift (-8) ; <* mov 0,0,szr *>
dumpzone.iaf(156):=26175 shift 16 + 0 ; <* halt *>
; <* jmp 0 *>
; <* .loc 8'377 *>
dumpzone.iaf(171):= 192 shift 8 ; <* jmp 8'300 *>
monitor(16)send message :(dumpzone,1,shdescr);
check(dumpzone);
changerec6(dumpzone,512);
getshare6(dumpzone,shdescr,1);
shdescr(4):= 3 shift 12 + 1; <* send statusbyte *>
shdescr(6):= shdescr(5) + 512 -2;
shdescr(7):= 768; <* bytecount *>
shdescr(8):= 0; <* statusbyte *>
setshare6(dumpzone,shdescr,1);
monitor(16) send message :(dumpzone,1,shdescr);
check(dumpzone);
<* the first message will give a reset status *>
for i:= 1 step 1 until 171 do
begin
outrec6(savezone,512);
monitor(16)send message :(dumpzone,1,shdescr);
check(dumpzone);
tofrom(savezone,dumpzone,512);
end;
changerec6(dumpzone,0);
close(savezone,true);
close(dumpzone,false);
monitor(10)release process:(dumpzone,1,shdescr);
monitor(42)lookup entry:(savezone,1,tail);
tail(1):= 171;
tail(6):= systime(7,0,0.0);
monitor(44)change entry:(savezone,1,tail);
end
else
write(out,nl,1,<:***ncptest: error in create entry:>,nl,1);
end;
end movedump;
procedure diagnostic;
begin
integer word,process,first,last,i;
boolean first_type,event,all_process,more_diagnostic;
check_host_online;
event:=all_process:=false;
first_type:=more_diagnostic:=true;
while more_diagnostic do
begin
type:=anything;
next_param(type);
if type=s_text and param(1)=(real<:proce:> add 's') and param(2)=real<:s:> then
begin
next_param(p_text);
if param(1)=real<:all:> and param(2)=real<::> then
all_process:=true
else
process:=description(param(1),10 shift 12);
type:=anything;
next_param(type);
if type=p_text and param(1)=real<:event:> and param(2)=real<::> then
event:=true
else paramno:=paramno-1;
write(out,nl,1,<:*** processes in process chain ***:>,nl,1);
if -,all_process then
begin
if process<>0 then
begin
print_process(process,event);
end
else write(out,nl,1,<:process not found:>,nl,1);
end else
begin
if proc_chain=0 then
begin
set_3600_address(44);
word:= get_3600_word;
end else
word:= proc_chain;
set_3600_address(word+2);
word:=get_3600_word;
while word<>0 do
begin
if -,first_type then typein else first_type:=false;
print_process(word,event);
set_3600_address(word+2);
word:=get_3600_word;
end;
end;
end else
if type=s_text and param(1)=real<:list:> then
begin
next_param(p_text);
repeat
if param(1)=(real<:runni:> add 'n') and param(2)=real<:g:> then
begin
write(out,nl,1,<:*** processes in running queue ***:>,nl,2);
print_process_queue(32);
end else
if param(1)=real<:delay:> then
begin
write(out,nl,1,<:*** processes in delay queue ***:>,nl,2);
print_process_queue(39);
end else
if param(1)=real<:proc:> then
begin
write(out,nl,1,<:*** process chain ***:>,nl,2);
print_process_chain(34);
end else
if param(1)=real<:prog:> then
begin
write(out,<:<10>*** program chain ***<10><10>:>);
print_process_chain(42);
end;
type:= anything;
next_param(type);
until type<>p_text;
paramno:= paramno-1;
end else
if param(1) = real<:corou:> add 't' then
begin
integer first_corout;
next_param(p_number);
write(out,nl,1,<:*** coroutine chain ***:>,nl,1);
word:= octal_to_decimal(round param(1));
core_specifications(first,last);
print_chain(word,first,last,0,true);
end else
if param(1) = real<:buffe:> add 'r' then
begin
next_param(p_number);
write(out,nl,1,<:*** buffer queue ***:>,nl,1);
word:= octal_to_decimal(round param(1));
print_buffer_queue(word);
end else
if param(1) = real<:chain:> then
begin
next_param(p_number);
write(out,nl,1,<:*** chain ***:>,nl,1);
word:= octal_to_decimal(round param(1));
type:= anything;
next_param(type);
if type = p_number then
i:= octal_to_decimal(round param(1))
else
begin
i:= 0;
paramno:= paramno-1;
end;
core_specifications(first,last);
print_chain(word,first,last,i,false);
end else
begin
paramno:= paramno-1;
more_diagnostic:= false;
end;
end while more_diagnostic;
end diagnostic;
procedure sendwait;
begin
real work; integer i,j;
if host_connected then
begin
next_param(s_text);
getshare6(supdev,shdescr,1);
if param(1)=real<:name:> and param(2)=real<::> then
begin
next_param(p_text);
work:=param(1);
for i:=1 step 1 until 6 do
begin
j:=work shift (-40) extract 8;
if j>=97 and j<=122 then j:=j-32;
work:=(work shift 8) add j;
end;
shdescr(4):=14 shift 12;
shdescr(6):=work shift (-24) extract 24;
shdescr(7):=work extract 24;
next_param(s_text);
if param(1)=real<:mess:> and param(2)=real<::> then
begin
next_param(p_number); <* mess0 *>
i:=octal_to_decimal(round param(1)) extract 2;
<* input = 1; output = 3 *>
shdescr(8):= (octal_to_decimal(round param(1))) shift 8;
next_param(p_number); <* mess1 *>
j:=octal_to_decimal(round param(1));
<* bytecount *>
shdescr(9):= octal_to_decimal(round param(1));
next_param(p_number); <* mess2 *>
shdescr(10):= (octal_to_decimal(round param(1))) shift 8;
next_param(p_number); <* mess3 *>
shdescr(11):= octal_to_decimal(round param(1));
setshare6(supdev,shdescr,1);
monitor(16)send message:(supdev,1,shdescr);
monitor(18)wait answer:(supdev,1,shdescr);
if i = 1 then
begin <* input message *>
if j > max_link * 2 then j:=max_link * 2;
j:=((j+2)//3)*2;
if j > record_length -2 then j:=record_length -2
else
if j = 0 then j:=2;
getzone6(supdev,zdescr);
getshare6(supdev,shdescr,1);
shdescr(4):= 3 shift 12 + 1;
shdescr(5):= zdescr(19) + 1;
shdescr(6):= zdescr(19) + 1 + (j-2);
setshare6(supdev,shdescr,1);
zdescr(14):= zdescr(19);
zdescr(15):= zdescr(19) + zdescr(20);
zdescr(16):= j+2;
setzone6(supdev,zdescr);
monitor(16)send message :(supdev,1,shdescr);
monitor(18)wait answer :(supdev,1,shdescr);
write(out,nl,1,<:*** input ***:>,nl,2,<:status : :>);
write_formatted(shdescr(1) shift (-12),bit);
write(out,nl,1,<:bytecount : :>,shdescr(3),nl,1);
supdev_pointer:= 0;
j:= (shdescr(3) + 1)// 2;
for i:= 1 step 1 until j do
begin
write(out,nl,1,<<ddd>,i-1,<: : :>);
write_formatted(get_3600_word,all);
end;
supdev_pointer:= max_link;
write(out,nl,1);
end
else if i = 3 then
begin <* output *>
<* later *>
end else
begin <* control *>
if shdescr(1)<>0 then
write(out,nl,1,<:***ncptest: sequence error:>,nl,1)
else
begin
write(out,nl,1,<:*** answer ***:>,nl,2,<:mess0: :>);
write_formatted(shdescr(5) shift (-8),all);
write(out,nl,1,<:mess1: :>);
write_formatted(shdescr(6),all);
write(out,nl,1,<:mess2: :>);
write_formatted(shdescr(7) shift (-8),all);
write(out,nl,1,<:mess3: :>);
write_formatted(shdescr(8),all);
write(out,nl,1);
end;
end;
end else paramno:=paramno-1;
end else paramno:=paramno-1;
end else
begin
write(out,nl,1,<:***ncptest: :>);
write(out,if -,coredump then <:no devicehost connected:>
else <:coredump mode:>,nl,1);
ok:= false;
end;
end sendwait;
procedure terminal(device);
integer device;
begin
integer procedure convert_speed(speed);
integer speed;
begin
integer j;
convert_speed:= 2;
for j:=1 step 1 until 14 do
if speed= (case j of (9600,4800,2400,1200,600,300,220,200,
150,134,110,75,50,40)) then convert_speed:=j-1;
end convert_speed;
procedure write_speed(spec);
integer spec;
write(out,case spec extract 4 +1 of (<:9600:>,
<:4800:>,<:2400:>,<:1200:>,<:600:>,<:300:>,<:220:>,<:200:>,<:150:>,
<:134:>,<:110:>,<:75:>,<:50:>,<:40:>,<::>,<::>));
integer l;
l:= 1;
if host_connected then
begin
integer linkno,timer,otimer,termtype,spec,i,j,k,status,chan,prompt,att;
integer array tabdescr(0:5);
boolean finis_terminal;
next_param(s_text);
if param(1)=real<:dhlin:> add 'k' and param(2)=real<::> then
begin
next_param(p_number);
linkno:= round param(1);
if device = 0 then <* terminal *>
begin
getshare6(supdev,shdescr,1);
shdescr(4):= 18 shift 12; <* lookup specs *>
shdescr(8):= linkno shift 8;
setshare6(supdev,shdescr,1);
monitor(16)send message:(supdev,1,shdescr);
i:=monitor(18)wait answer:(supdev,1,shdescr);
if shdescr(1)<> 0 or i<>1 then <* old release of ncp *>
begin
otimer:=timer:= 60; prompt:= 7;
att:= 0;
termtype:= 12 shift 8 + 1;
spec:= 1 shift 15 + 1 shift 12 + 1 shift 10 + 1 shift 8 +
2 shift 4 + 2;
end else
begin
otimer:=timer:= shdescr(7) shift (-8);
att:= shdescr(3);
termtype:= shdescr(2);
spec:= shdescr(8);
prompt:= shdescr(4) shift (-8);
end;
end else
begin <* printer defaults *>
timer:= 60;
spec:= 1 shift 15 + 1 shift 12 + 1 shift 10 + 1 shift 8 +
3 shift 4 + 3;
end;
finis_terminal:= false;
while -,finis_terminal do
begin
type:=anything;
next_param(type);
if type=s_text and param(1)=real<:type:> and param(2)=real<::> then
begin
next_param(p_number);
if round param(1) < 10 then
termtype:= termtype - termtype extract 8 + round param(1);
end else
if type=s_text and param(1)=real<:timer:> and param(2)=real<::> then
begin
next_param(p_number);
timer:= timer - timer extract 8 + round param(1);
type:=anything;
next_param(type);
if type=p_number then
otimer:= round param(1)
else
paramno:= paramno-1;
end else
if type=s_text and param(1)=real<:s:> and param(2)=real<::> then
begin
next_param(p_number);
spec:= spec - spec extract 13 + spec extract 12;
if round param(1) <> 1 then spec:= spec + 1 shift 12;
end else
if type=s_text and param(1)=real<:p:> and param(2)=real<::> then
begin
next_param(p_text);
spec:= spec - spec extract 12 + spec extract 10;
termtype:= termtype - termtype extract 11 + termtype extract 10;
if param(1)=real<:n:> and param(2)=real<::> then i:=2 else
if param(1)=real<:o:> and param(2)=real<::> then i:= 0 else
begin <* even parity *>
i:= 1;
termtype:= termtype + 1 shift 10; <* soft parity *>
end;
spec:=spec+ i shift 10;
end else
if type=s_text and param(1)=real<:l:> and param(2)=real<::> then
begin
next_param(p_number);
spec:= spec - spec extract 10 + spec extract 8;
i:=round param(1);
j:= 0;
if i<=8 and i>0 then
begin
case i of
begin
;
;
;
;
j:= 0;
j:= 2;
j:= 1;
j:= 3;
end case;
end;
spec:= spec + j shift 8;
end else
if type=s_text and param(1)=real<:r:> and param(2)=real<::> then
begin
next_param(p_number);
spec:= spec - spec extract 8;
j:=k:=convert_speed(round param(1));
type:= anything;
next_param(type);
if type=p_number then
k:= convert_speed(round param(1))
else
paramno:=paramno-1;
spec:= spec + j shift 4 + k;
end else
if type=s_text and param(1)=real<:dc1:> and param(2)=real<::> then
begin
next_param(p_text);
spec:= spec - spec extract 15 + spec extract 13;
i:= 0;
if device = 0 then
begin
if param(1)=real<:input:> then i:= 2 else
if param(1)=real<:outpu:> add 't' then i:= 3 else
if param(1)=real<:both:> then i:= 1;
end else <* printer *>
if param(1)=real<:yes:> then i:= 3;
spec:= spec + i shift 13;
end else
if type=s_text and param(1)=real<:echo:> then
begin
next_param(p_text);
termtype:=termtype-termtype extract 12 + termtype extract 11;
if param(1)=real<:yes:> then
termtype:= termtype+1 shift 11;
end else
if type=s_text and param(1)=real<:conv:> then
begin
termtype:= termtype-termtype extract 16 + termtype extract 15;
next_param(p_text);
if param(1)=real<:yes:> then
termtype:= termtype + 1 shift 15;
end else
if type=s_text and param(1)=real<:promp:> add 't' then
begin
next_param(p_number);
prompt:= round param(1);
end else
if type = s_text and param(1)=real<:cont:> then
begin
next_param(p_text);
termtype:= termtype-termtype extract 14 + termtype extract 13;
if param(1)=real<:yes:> then
termtype:= termtype+1 shift 13;
end else
if type = s_text and param(1)=real<:att:> then
begin
next_param(p_text);
att:= att - att extract 22 + att extract 21;
if param(1)=real<:disa:> then
att:= att + 1 shift 21;
end else
if type = s_text and param(1)=real<:mess:> then
begin
next_param(p_text);
att:= att - att extract 21 + att extract 20;
if param(1)=real<:no:> then
att:= att + 1 shift 20;
end else
finis_terminal:= true;
end while;
if ((param(1)=real<:looku:> add 'p') and device=0) then
begin
write(out,<<d>,<:terminal dhlink.:>,linkno,<: type.:>,termtype extract 8,
<: timer.:>,timer extract 8,<: s.:>,if spec shift(-12) extract 1=1
then <:2:> else <:1:>,<: p.:>,case spec shift(-10) extract 2 +1 of
(<:o:>,<:e:>,<:n:>,<::>),<: l.:>,case spec shift(-8) extract 2 + 1 of
(<:5:>,<:7:>,<:6:>,<:8:>),<: r.:>);
i:= spec extract 4;
j:= ( spec shift (-4) ) extract 4;
write_speed(j);
if i<>j then
begin
write(out,<:.:>);
write_speed(i);
end;
write(out,<<d>,<: dc1.:>,case spec shift(-13) extract 2 +1 of
(<:no:>,<:both:>,<:input:>,<:output:>),<:<10>:>,
<:echo.:>,if termtype shift(-11) extract 1<>0 then <:yes:>
else <:no:>,<: conv.:>,if termtype shift(-15) extract 1<>0 then <:yes:>
else <:no:>,<: prompt.:>,prompt extract 8,<: cont.:>,
if termtype shift(-13) extract 1<>0 then <:yes:> else <:no:>,
<: att.:>,if att shift 2 >= 0 then <:ena:> else <:disa:>,
<: mess.:>,if att shift 3 >= 0 then <:yes:> else <:no:>,<:<10>:>);
end else
begin
paramno:=paramno-1;
if device=0 then <* terminal *>
begin <* init input channel and coroutine parameters *>
getshare6(supdev,shdescr,1);
shdescr(4):= 16 shift 12 + 3;
<* mode=3 indicates to core3600 release 3.0 of ncptest *>
shdescr(5):= termtype;
shdescr(6):= att;
shdescr(7):= prompt shift 8;
shdescr(8):= linkno shift 8;
shdescr(9):= otimer shift 8;
shdescr(10):= timer shift 8;
shdescr(11):= spec;
setshare6(supdev,shdescr,1);
monitor(16)send message:(supdev,1,shdescr);
monitor(18)wait answer:(supdev,1,shdescr);
if shdescr(1)<>0 then
write(out,nl,1,<:***:>,string ncptest_name(increase(l)),
<:: terminal not found:>,nl,1);
end else <* printer *>
begin
if get_tabdescr(tabdescr,120) and tabdescr(5)> linkno then
begin <* devicetable *>
i:= tab_start(tabdescr,linkno);
i:= get_3600_word; <* entry semaphore *>
set_3600_address(i+17); <* address of ssp name *>
i:= get_3600_word;
set_3600_address(i);
i:= get_3600_word;
i:= description(supdev.raf(1)<*ssp name*>,10 shift 12);
if i<>0 then
begin
set_3600_address(i+26);
i:= get_3600_word;
param(1):= supdev.raf(1); <* name of amx driver *>
chan:= supdev.iaf(11) extract 8; <* amx channel *>
getshare6(supdev,shdescr,1);
shdescr(4):= 14 shift 12;
shdescr(6):= param.iaf(1);
shdescr(7):= param.iaf(2);
shdescr(8):= (chan shift 8 + 32) shift 8;
shdescr(10):= (timer shift 8 + timer) shift 8;
shdescr(11):= spec;
setshare6(supdev,shdescr,1);
monitor(16)send message:(supdev,1,shdescr);
monitor(18)wait answer:(supdev,1,shdescr);
status:= shdescr(5) shift (-8);
if status<>0 then
begin
write(out,nl,1,<:***:>,string ncptest_name(increase(l)),
<:: status: :>);
write_formatted(status,octal);
write(out,nl,1);
end;
end;
end else
write(out,nl,1,<:***:>,string ncptest_name(increase(l)),
<:: printer not found:>,nl,1);
end;
end;
end else
begin
write(out,nl,1,<:***:>,string ncptest_name(increase(l)),
<:: no linknumber specified:>,nl,1);
ok:= false;
end;
end else
begin
write(out,nl,1,<:***:>,string ncptest_name(increase(l)),<:::>,
if -,coredump then <: no devicehost connected:>
else <: coredump mode:>,nl,1);
ok:= false;
end;
end terminal;
procedure hdlcstat;
begin
integer i,j,chan;
long l;
real work;
if host_connected then
begin
next_param(s_text);
getshare6(supdev,shdescr,1);
if param(1)=real<:name:> and param(2)=real<::> then
begin
next_param(p_text);
work:=param(1);
for i:=1 step 1 until 6 do
begin
j:=work shift (-40) extract 8;
if j>=97 and j<=122 then j:=j-32;
work:=(work shift 8) add j;
end;
shdescr(4):=14 shift 12;
shdescr(6):=work shift (-24) extract 24;
shdescr(7):=work extract 24;
next_param(s_text);
if param(1)=real<:chan:> and param(2)=real<::> then
begin
next_param(p_number);
chan:=round param(1) extract 2;
<* mess0 *>
shdescr(8):= (chan shift 6 + 1) shift 8;
<* bytecount *>
shdescr(9):= 50;
setshare6(supdev,shdescr,1);
monitor(16)send message:(supdev,1,shdescr);
monitor(18)wait answer:(supdev,1,shdescr);
getzone6(supdev,zdescr);
getshare6(supdev,shdescr,1);
shdescr(4):= 3 shift 12 + 1;
shdescr(5):= zdescr(19) + 1;
shdescr(6):= zdescr(19) + 1 + 50-2;
setshare6(supdev,shdescr,1);
zdescr(14):= zdescr(19);
zdescr(15):= zdescr(19) + zdescr(20);
zdescr(16):= 50+2;
setzone6(supdev,zdescr);
monitor(16)send message :(supdev,1,shdescr);
monitor(18)wait answer :(supdev,1,shdescr);
write(out,nl,1,<:*** hdlc statistics ***:>,nl,1,
<:name.:>,string work,<: chan.:>,chan,nl,1);
if shdescr(1) shift(-12) <> 0 then
begin
write(out,<:status ::>);
write_formatted(shdescr(1) shift(-12),bit);
write(out,nl,1);
end else
begin
supdev_pointer:= 0;
j:= (shdescr(3) + 1)// 2;
if j>17 then j:= 17;
for i:= 1 step 1 until j do
begin
case i of
begin
begin
l:= extend get_3600_word shift 16 add get_3600_word;
write(out,<:rec errorfree packets : :>,<<dddddd>,l,nl,1);
end;
;
begin
l:= extend get_3600_word shift 16 add get_3600_word;
write(out,<:xmt errorfree packets : :>,<<dddddd>,l,nl,1);
end;
;
begin
l:= extend get_3600_word shift 16 add get_3600_word;
write(out,<:rec error packets : :>,<<dddddd>,l,nl,1);
end;
;
begin
l:= extend get_3600_word shift 16 add get_3600_word;
write(out,<:re xmt packets : :>,<<dddddd>,l,nl,1);
end;
;
write(out,<:rec RNR packets : :>,<<dddddd>,get_3600_word,nl,1);
write(out,<:xmt RNR packets : :>,<<dddddd>,get_3600_word,nl,1);
write(out,<:rec REJ packets : :>,<<dddddd>,get_3600_word,nl,1);
write(out,<:xmt REJ packets : :>,<<dddddd>,get_3600_word,nl,1);
write(out,<:re xmt by timeout : :>,<<dddddd>,get_3600_word,nl,1);
write(out,<:DSR being off : :>,<<dddddd>,get_3600_word,nl,1);
write(out,<:CD being off : :>,<<dddddd>,get_3600_word,nl,1);
write(out,<:CI being off : :>,<<dddddd>,get_3600_word,nl,1);
write(out,<:RFS being off : :>,<<dddddd>,get_3600_word,nl,1);
end case;
end;
supdev_pointer:= max_link;
end;
end else begin
write(out,<:***ncptest: no channel:>,nl,1);
ok:= false;
end;
end else begin
write(out,<:***ncptest: no driver:>,nl,1);
ok:= false;
end;
end else begin write(out,<:***ncptest: :>,if -,coredump then
<:no devicehost connected:> else <:coredump mode:>,nl,1);
ok:= false;
end;
end hdlcstat;
procedure minirocs;
begin
integer e, i, j, k, l, tableadr, ibmdv, tab1, tab2, links, lines, dispno;
real array name(1:2);
procedure wo( text, v, n );
value v, n; string text; integer v, n;
begin
integer i;
write( out, text );
for i:= 15 step -3 until 0 do
write(out, <<d>, v shift (-i) extract 3 );
write(out, nl, n );
end;
l:= 1;
tableadr:= 0; ibmdv:= 0; tab1:= 0; tab2:= 0; links:= 0; lines:= 0;
check_host_online;
tableadr:= description( real<:TABLE:>, 10 shift 12 );
if tableadr = 0 then
begin
write(out,nl,1,<:***:>,string ncptest_name(increase(l)),<:::>,
<: MINIROCS module TABLE not found:>,nl,1);
ok:= false; goto exit;
end;
set_3600_address( tableadr-10 );
links:= get_3600_word; lines:= get_3600_word;
wo( <:links : :>, links , 0 );
wo( <: lines : :>, lines , 1 );
wo( <:menuchar: :>, get_3600_word , 1 );
tab1:= get_3600_word; tab2:= get_3600_word;
wo( <:tab1 : :>, tab1, 0 );
wo( <: tab2 : :>, tab2, 1 );
wo( <:menuaddr: :>, get_3600_word, 0 );
wo( <: menusize: :>, get_3600_word, 1 );
ibmdv:= description( real<:IBMDV:>, 12 shift 12 );
if ibmdv = 0 then
begin
write(out,nl,1,<:***:>,string ncptest_name(increase(l)),<:::>,
<: MINIROCS module IBMDV not found:>,nl,1);
ok:= false; goto exit;
end;
if (links = 0) or (links > 8) or (lines = 0) or (lines > 8) then
begin
write(out,nl,1,<:***:>,string ncptest_name(increase(l)),<:::>,
<: MINIROCS lines/links inconsistency:>, nl,1);
ok:= false; goto exit;
end;
write(out, <:konfiguration table::> );
<* display ibmdv konfiguration table *>
set_3600_address( ibmdv+15 );
for i:= 1 step 1 until 8 do
begin
write( out, nl, 1, <: line :>, i, <: : :> );
for j:= 1 step 1 until 16 do
begin
k:= get_3600_word;
if (k shift (-8) extract 8) <> 0 then
write(out, sp, 1, k shift (-8) extract 8 );
if (k extract 8) <> 0 then
write(out, sp, 1, k extract 8 );
end;
end;
write(out, nl, 1);
if (tab1 < ibmdv) or (tab2 < ibmdv) then
begin
write(out,nl,1,<:***:>,string ncptest_name(increase(l)),<:::>,
<: MINIROCS tab1/tab2 address inconsistency:>, nl,1);
ok:= false; goto exit;
end;
typein; dispno:= 0;
write(out, <:Table 1 : RC8000 -> Line Address Transformation:>,nl,1,
<:lnk C:DV-lin C:DV ! :>,
<:lnk C:DV-lin C:DV ! :>,
<:lnk C:DV-lin C:DV ! :>,
<:lnk C:DV-lin C:DV:>,nl,1);
set_3600_address( tab1 );
for i:= 0 step 1 until links-1 do
begin <* scan links *>
for j:= 0 step 1 until 7 do
begin <* scan cu's for link *>
for k:= 0 step 1 until 63 do
begin <* scan dev's for cu *>
e:= get_3600_word;
if e < 16384 then
begin
if dispno mod 4 = 0 then write(out,nl,1);
if increase(dispno) > 15*4 then begin typein; dispno:= 0; end;
write(out, <<dd>, i, <: :>, j, <:::>, k,
<:-:>, e shift (-11) extract 3,
<: :>, e shift (-6) extract 5,
<:::>, e extract 6, <: ! :> );
end;
end; <* scan dev's *>
end; <* scan cu's *>
end; <* scan links *>
write(out, nl,1 ); typein; dispno:= 0;
write(out, <:Table 2 : Line -> RC8000 Address Transformation:>,nl,1,
<:lin C:DV-lnk C:DV ! :>,
<:lin C:DV-lnk C:DV ! :>,
<:lin C:DV-lnk C:DV ! :>,
<:lin C:DV-lnk C:DV:>,nl,1);
set_3600_address( tab2 );
for i:= 0 step 1 until lines-1 do
begin <* scan lines *>
for j:= 0 step 1 until 7 do
begin <* scan cu's for line *>
for k:= 0 step 1 until 63 do
begin <* scan dev's for cu *>
e:= get_3600_word;
if e < 2048 then
begin
if dispno mod 4 = 0 then write(out,nl,1);
if increase(dispno) > 15*4 then begin typein; dispno:= 0; end;
write(out, <<dd>, i, <: :>, j, <:::>, k,
<:-:>, e shift (-9) extract 3,
<: :>, e shift (-6) extract 3,
<:::>, e extract 6, <: ! :> );
end;
end; <* scan dev's *>
end; <* scan cu's *>
end; <* scan lines *>
write(out, nl,1 );
exit:
end;
procedure format;
begin
integer tmask;
integer procedure get_format;
get_format:= if param(1) = real<:octal:> then 1 else
if param(1) = real<:decim:> add 'a' and
param(2) = real<:l:> then 2 else
if param(1) = real<:byte:> then 3 else
if param(1) = real<:bit:> then 4 else
if param(1) = real<:text:> then 5 else
if param(1) = real<:all:> then 6 else
if param(1) = real<:words:> then 7 else
if param(1) = real<:windo:> add 'w' then 8 else 9;
type:=anything;
tmask:= 0;
next_param(type);
repeat
case get_format of
begin
tmask:=tmask add octal;
tmask:=tmask add int;
tmask:=tmask add byte;
tmask:=tmask add bit;
tmask:=tmask add text;
tmask:=all;
begin
next_param(p_number);
words:= round param(1);
end;
begin
next_param(p_number);
firstcore:=lastcore:= round param(1);
type:= anything;
nextparam(type);
if type = p_number then
lastcore:= round param(1)
else paramno:= paramno - 1;
if firstcore > lastcore then firstcore:= lastcore;
end;
type_text(<:illegal format:>);
end case;
type:=anything;
next_param(type);
until type <> p_text;
paramno:= paramno - 1;
if tmask <> 0 then mask:= tmask;
end format;
procedure typein;
begin
integer i,j;
if -,not_online then
begin
write(out, <:Type <CR> to continue, f<CR> to discard: :>);
setposition(out,0,0);
readchar(in,i);
if i<>10 then repeat readchar(in,j) until j=10;
if i=102 then goto nextline;
end;
end typein;
procedure blockproc(z,s,b);
zone z;
integer s,b;
begin
write(out,nl,1);
for i:= 0 step 1 until 23 do
write(out,s shift (-i) extract 1);
setposition(out,0,0);
if s shift 16 > 0 then
stderror(z,s,b);
end;
integer procedure search(chain,name);
integer chain;
real name;
begin
integer word,i,next;
boolean found;
if chain= 12 shift 12 then <* program *>
begin
word:= 57;
i:= prog_chain;
end else
begin
word:= 44;
i:= proc_chain;
end;
next:= -1; found:=false;
if i=0 then
begin
set_3600_address(word);
word:= get_3600_word;
end else
word:= i;
while word<>0 and -,found do
begin
set_3600_address(word+2);
next:=get_3600_word;
search:=word;
set_3600_address(word+4);
i:=0;
while i<3 and name shift ((i-2)*16) extract 16 = get_3600_word do i:=i+1;
found:=i=3;
word:=next;
end;
if -,found then search:=0;
end search;
procedure core_specifications(first,last);
integer first,last;
begin
type:=anything;
next_param(type);
if type=s_number then
begin
last:=first:=round param(1);
type:=anything;
next_param(type);
if type=p_number then
last:=round param(1)
else
paramno:=paramno-1; <* try again *>
end
else
begin
paramno:=paramno-1;
first:= firstcore;
last:= lastcore;
end;
if first>last then first:=last;
end core_specifications;
procedure addr_specifications(first,last);
integer first,last;
begin
type:=anything;
next_param(type);
paramno:=paramno-1;
if type=s_number then
core_specifications(first,last)
else
begin
first:=0;
last:=77777;
end;
end addr_specifications;
procedure print_item(mode,name);
value mode,name;
integer mode;
real name;
begin
integer first,last,addr;
addr:=description(name,mode);
if addr <> 0 then
begin
core_specifications(first,last);
first:=octal_to_decimal(first);
last:=octal_to_decimal(last);
print_core(addr,first,last,mask,words);
end
else
write(out,<:not found:>,nl,1);
end print_item;
procedure print_buffer_queue(head);
value head;
integer head;
begin
integer event,last_event,i;
integer array messbuf(1:10);
boolean first_type;
first_type:=true;
set_3600_address(head);
messbuf(1):=get_3600_word;
last_event:=get_3600_word;
event:= 0;
if last_event=head then write(out,nl,1,<:queue empty:>,nl,1)
else
begin
while event<>last_event do
begin
event:=messbuf(1);
set_3600_address(event);
for i:=1 step 1 until 10 do
messbuf(i):=get_3600_word;
if -,first_type then typein else first_type:=false;
print_buf(event,0,messbuf);
end;
end;
end print_buffer_queue;
procedure print_chain(first_item,first,last,offset,corout);
integer first_item,first,last,offset;
boolean corout;
begin
integer next;
boolean first_type;
first_type:= true; next:= first_item;
while next <> 0 do
begin
if -,first_type then typein else first_type:= false;
if corout then
begin
set_3600_address(next-1);
write(out,nl,1,<:ident :>);
write_formatted(get_3600_word,octal+int);
end;
write(out,nl,1);
print_core(next,first,last,mask,words);
set_3600_address(next+offset);
next:= get_3600_word;
write(out,nl,1);
end while next<>0;
end print_chain;
procedure print_buf(addr,index,messbuf);
value addr,index;
integer addr,index;
integer array messbuf;
begin
integer i,j,k;
write(out,nl,2,<:core : :>);
write_formatted(addr+10*index,octal);
for i:=1 step 1 until 10 do
begin
j:=messbuf(index*10+i);
case i of
begin
write(out,nl,1,<: 0: next : :>);
write(out,<: 1: prev : :>);
write(out,<: 2: chain : :>);
write(out,<: 3: size : :>,<<dddddd>,j);
write(out,<: 4: sender : :>);
write(out,<: 5: receiver : :>);
write(out,<: 6: mess0 : :>);
write(out,<: 7: mess1 : :>);
write(out,<:10: mess2 : :>);
write(out,<:11: mess3 : :>);
end case;
case i of
begin
write_formatted(j,octal); <* next *>
write_formatted(j,octal); <* prev *>
write_formatted(j,octal); <* chain *>
; <* size *>
begin <* sender *>
write_formatted(j,octal);
if j<>0 then
begin
set_3600_address(j+4);
for k:=0,1,2 do
write_formatted(get_3600_word,text);
end;
end;
begin <* receiver *>
write_formatted(j,octal);
if j<>0 then
begin
if j shift 8<0 then
j:=(-j) extract 16;
set_3600_address(j+4);
for k:=0,1,2 do
write_formatted(get_3600_word,text);
end;
end;
write_formatted(j,all); <* mess0 *>
write_formatted(j,all); <* mess1 *>
write_formatted(j,all); <* mess2 *>
write_formatted(j,all); <* mess3 *>
end case;
type_text(<::>);
end for i;
end print_buf;
procedure print_process(process,event);
value process;
integer process;
boolean event;
begin
integer k,i;
integer array proc_descr(1:26);
set_3600_address(process);
for i:= 1 step 1 until 26 do proc_descr(i):=get_3600_word;
write(out,nl,2,<:core : :>);
write_formatted(process,octal);
for i:= 1 step 1 until 26 do
begin
case i of
begin
write(out,nl,1,<: 0: next:>,sp,16,<:: :>);
write(out,nl,1,<: 1: previous:>,sp,12,<:: :>);
write(out,nl,1,<: 2: chain:>,sp,15,<:: :>);
write(out,nl,1,<: 3: size:>,sp,16,<:: :>);
write(out,nl,1,<: 4: name:>,sp,16,<:: :>);
;
;
write(out,nl,1,<: 7: first event:>,sp,9,<:: :>);
write(out,nl,1,<:10: last event:>,sp,10,<:: :>);
write(out,nl,1,<:11: message buffers:>,sp,5,<:: :>);
write(out,nl,1,<:12: program start:>,sp,7,<:: :>);
write(out,nl,1,<:13: state:>,sp,15,<:: :>);
write(out,nl,1,<:14: timer:>,sp,15,<:: :>);
write(out,nl,1,<:15: priority:>,sp,12,<:: :>);
write(out,nl,1,<:16: break address:>,sp,7,<:: :>);
write(out,nl,1,<:17: ac0:>,sp,17,<:: :>);
write(out,nl,1,<:20: ac1:>,sp,17,<:: :>);
write(out,nl,1,<:21: ac2:>,sp,17,<:: :>);
write(out,nl,1,<:22: ac3:>,sp,17,<:: :>);
write(out,nl,1,<:23: psw:>,sp,17,<:: :>);
write(out,nl,1,<:24: save:>,sp,16,<:: :>);
write(out,nl,1,<:25: buf:>,sp,17,<:: :>);
write(out,nl,1,<:26: address:>,sp,13,<:: :>);
write(out,nl,1,<:27: count:>,sp,15,<:: :>);
write(out,nl,1,<:30: reserver:>,sp,12,<:: :>);
write(out,nl,1,<:31: conversiontable:>,sp,5,<:: :>);
end case;
case i of
begin
write_formatted(proc_descr(i),octal); <* next *>
write_formatted(proc_descr(i),octal); <* prev *>
write_formatted(proc_descr(i),octal); <* chain *>
write_formatted(proc_descr(i),octal+int); <* size *>
write_formatted(proc_descr(i),text); <* name(0) *>
write_formatted(proc_descr(i),text); <* name(1) *>
write_formatted(proc_descr(i),text); <* name(2) *>
write_formatted(proc_descr(i),octal); <* first event *>
write_formatted(proc_descr(i),octal); <* last event *>
write_formatted(proc_descr(i),octal); <* message buffers *>
write_formatted(proc_descr(i),octal); <* program start *>
write_formatted(proc_descr(i),octal); <* state *>
write_formatted(proc_descr(i),octal+int); <* timer *>
write_formatted(proc_descr(i),octal); <* priority *>
write_formatted(proc_descr(i),octal); <* break address *>
write_formatted(proc_descr(i),all); <* ac0 *>
write_formatted(proc_descr(i),all); <* ac1 *>
write_formatted(proc_descr(i),all); <* ac2 *>
write_formatted(proc_descr(i),all); <* ac3 *>
begin
write_formatted(proc_descr(i),octal);
write_formatted(proc_descr(i) shift (-1),octal);
write(out,if proc_descr(i) extract 1<>0 then 1 else 0);
end;
write_formatted(proc_descr(i),all); <* save *>
write_formatted(proc_descr(i),octal); <* buf *>
write_formatted(proc_descr(i),octal); <* address *>
write_formatted(proc_descr(i),octal+int); <* count *>
begin <* reserver *>
write_formatted(proc_descr(i),octal);
if proc_descr(i) > 0 and proc_descr(i) < 32768 then
begin
set_3600_address(proc_descr(i)+4);
for k:=0,1,2 do
write_formatted(get_3600_word,text);
end;
end;
write_formatted(proc_descr(i),octal); <* conversion table *>
end case;
end for i;
type_text(<::>);
if event then
begin
typein;
write(out,nl,1,<:messagebuffers in event queue:>,nl,1);
print_buffer_queue(process+7);
end;
end print_process;
procedure print_process_queue(head);
value head;
integer head;
begin
integer first,last,k;
first:=head;
set_3600_address(head+1);
last:=get_3600_word;
while first<>last do
begin
set_3600_address(first);
first:=get_3600_word;
set_3600_address(first+4);
for k:=0,1,2 do
write_formatted(get_3600_word,text);
write_formatted(first,octal);
write(out,nl,1);
end;
end print_process_queue;
procedure print_process_chain(head);
value head;
integer head;
begin
integer first,next,i;
set_3600_address(head);
first:= get_3600_word;
while first<>0 do
begin
set_3600_address(first+2);
next:= get_3600_word;
set_3600_address(first+4);
for i:= 0,1,2 do
write_formatted(get_3600_word,text);
write_formatted(first,octal);
write(out,nl,1);
first:= next;
end;
end print_process_chain;
integer procedure get_3600_word;
begin
integer i;
real field rf;
if supdev_pointer>=max_link then
begin
if coredump then
begin
supdev_pointer:= 0;
inrec6(dumpz,record_length);
end
else
begin
setposition(supdev,0,0);
getshare6(supdev,shdescr,1);
shdescr(4):=8 shift 12;
last_get_addr:= last_get_addr + max_link;
shdescr(5):= last_get_addr;
setshare6(supdev,shdescr,1);
monitor(16)send message:(supdev,1,shdescr);
monitor(18)wait answer:(supdev,1,shdescr);
inrec6(supdev,record_length);
supdev_pointer:=0;
end; <* not coredump *>
end;
i:=(2-supdev_pointer mod 3)*16;
rf:=(supdev_pointer//3+1)*4;
get_3600_word:= if coredump then dumpz.rf shift (-i) extract 16
else supdev.rf shift (-i) extract 16;
supdev_pointer:=supdev_pointer+1;
end get_3600_word;
procedure set_3600_address(addr);
integer addr;
begin
if coredump then
begin
if (dump_size <> 0) and (addr//maxlink >= dump_size) then
begin
write(out,nl,1,<:***ncptest: positioning outside dump:>,nl,1);
if not_online then goto end_program else
goto next_line;
end;
setposition(dumpz,file,addr//max_link);
supdev_pointer:=addr mod max_link;
inrec6(dumpz,record_length);
end
else
begin
last_get_addr:= addr - max_link;
supdev_pointer:=max_link;
end;
end set_3600_address;
procedure print_core(base,first,last,mask,words);
integer base,first,last,mask,words;
begin
integer i,j,word;
word:=words;
set_3600_address(base+first);
for i:= first step word until last do
begin
if base<>0 then
write_formatted(base+i,octal);
write_formatted(i,octal);
write(out,<:: :>);
if i+word > last+1 then word:= (last-first+1) mod word;
for j:=1 step 1 until word do
write_formatted(get_3600_word,mask);
type_text(<::>);
end;
end print_core;
boolean procedure get_tabdescr(tabdescr,tabno);
value tabno;
integer tabno;
integer array tabdescr;
begin
integer addr,word,i,j;
addr:=description(real<:ncp:>,12 shift 12);
set_3600_address(addr+7);
word:=get_3600_word;
set_3600_address(word);
j:= -1;
repeat
j:=get_3600_word;
tabdescr(0):=j;
for i:=1 step 1 until 5 do
tabdescr(i):=get_3600_word;
until (j=65535 or tabno=j);
if j= 65535 then
get_tabdescr:=false
else
get_tabdescr:=true;
end get_tabdescr;
integer procedure tab_start(tabdescr,entry);
value entry;
integer entry;
integer array tabdescr;
begin
integer organisation,i,j,chain;
organisation:=tabdescr(1) extract 2;
tab_start:=0;
case organisation+1 of
begin
i:=tab_start:=tabdescr(4)+tabdescr(2)//2*entry; <* simple not chained *>
begin <* chained *>
i:=tabdescr(4);
if entry<>0 then
for j:=1 step 1 until entry do
begin
chain:=i+tabdescr(3);
set_3600_address(chain);
i:=get_3600_word;
end;
tab_start:=i;
end;
begin <* indexed *>
i:=tabdescr(4)+entry;
set_3600_address(i);
i:=tab_start:=get_3600_word;
end;
; <* skip *>
end case;
set_3600_address(i);
end tab_start;
procedure link_host(devicehost);
value devicehost;
integer devicehost;
begin
integer peripherals,i,j,hoststatus;
integer array start(1:2),process_description(0:5);
integer array field iaf;
iaf := -2;
if host_connected then remove_link;
hoststatus:=-1;
system(5)copy core:(74,start);
peripherals:=(start(2)-start(1))/2-1;
begin
integer array nametable(0:peripherals);
integer array field iaf;
iaf := -2;
system(5)copy core:(start(1),nametable.iaf);
for i:=0,i+1 while (-,host_connected and i<=peripherals) do
begin
system(5)copy core:(nametable(i),process_description.iaf);
if process_description(0)=82 and <* kind=subhost *>
process_description.raf(1)=real<:host3:> add '6' then
begin
j:=linkup(i,devicehost);
if j<>-1 then hoststatus:=j;
end;
end;
if -,host_connected then
begin
i:= 1;
write(out,<:***:>,string ncptest_name(increase(i)),<:::>);
if hoststatus = -1 then write(out,<: devicehost no :>,devicehost,<: not found:>,nl,1) else
write(out,<: link error : :>,case hoststatus extract 4 +1 of (<:devicehost reserved:>,
<:supervisor device not present:>,<:supervisor device reserved:>,
<:no resources at jobhost:>,
<:no resources at devicehost:>,<:timeout:>,<:priority:>,<:link present:>,
<:devicehost unknown:>,<:job cannot be user of the device:>,
<:links exceeded:>,<::>,<::>,<::>,<::>),
<: , connecting to devicehost no :>,devicehost,nl,1);
ok:= false;
end;
end;
end link_host;
integer procedure linkup(hostno,devicehost);
value hostno, devicehost;
integer hostno,devicehost;
begin
integer array process_description(1:10);
zone z(6,1,stderror);
integer i,j,process;
real array field raf;
raf:=0;
open(z,0,<:host:>,0);
getzone6(z,zdescr);
getshare6(z,shdescr,1);
shdescr(4):=1 shift 12 + 6 shift 1 +0;
shdescr(5):=zdescr(19)+1;
shdescr(6):=zdescr(19)+1+20;
shdescr(7):=hostno;
shdescr(8):=devicehost;
shdescr(9):=0;
setshare6(z,shdescr,1);
zdescr(14):=zdescr(19);
zdescr(15):=zdescr(19)+zdescr(20);
zdescr(16):=24;
setzone6(z,zdescr);
z.iaf(1):=12; <* devicekind *>
z.iaf(2):= 1; <* buffers *>
z.iaf(3):=258; <* bufferlength *>
z.iaf(4):= real<:cor:> shift (-24) extract 24;
z.raf(3):= real<:e3600:>;
z.iaf(7):= 0; <* devicename *>
z.iaf(9):=0;
z.iaf(10):=0;
monitor(16)send message:(z,1,shdescr);
i:=monitor(18)wait answer:(z,1,shdescr);
hostconnected := false;
linkup := -1; <*shdescr(1) was 0 before wait answer *>
if i <> 1 then
linkup:= 0
else
if shdescr(1) extract 12<>0 then
linkup:=shdescr(1) extract 12
else
begin
process:=z.iaf(11);
max_link:= (z.iaf(3)//6)*3;
record_length:= 172;
system(5,process,process_description);
raf:=2;
close(z, true);
i :=1; open(supdev, 12, string process_description.raf(increase(i)),giveup);
j:=monitor(8)reserve process:(supdev,1,shdescr);
getshare6(supdev, shdescr, 1);
shdescr(4) := 8 shift 12; shdescr(5) := 0;
setshare6(supdev, shdescr, 1);
monitor(16)send_message:(supdev, 1, shdescr);
i := monitor(18)wait_answer:(supdev, 1, shdescr);
linkup:= 0;
if i > 1 or shdescr(1)<>0 or j<> 0 then
begin
close(supdev,true);
monitor(64)remove_process:(supdev, 1, shdescr);
end else
begin
host_connected := true;
write(out,nl,1,<:connected to devicehost no: :>,devicehost,nl,1);
end
end;
end linkup;
procedure link_to_console;
begin
integer array process_description(0:25),name(1:12);
zone z(6,1,stderror);
integer array field iaf;
iaf := -2;
open(z,8,<:console1:>,0);
if monitor(4,z,1,name)<>0 then
begin
system(5,monitor(4,z,1,name),process_description.iaf);
link_host(process_description(25) extract 16);
end;
end link_to_console;
procedure remove_link;
begin
close(supdev,true);
monitor(64)remove process:(supdev,i,shdescr);
host_connected:=false;
end remove_link;
integer procedure description(name,chain);
value chain;
integer chain;
real name;
begin
real work;
work:= name;
for i:=1 step 1 until 6 do
begin
j:=work shift (-40) extract 8;
if j>=97 and j<=122 then j:=j-32; <* convert to capital letters *>
work:=(work shift 8) add j;
end;
if coredump then
description:=search(chain,work)
else
begin
setposition(supdev,0,0);
supdev_pointer:=max_link;
getshare6(supdev,shdescr,1);
shdescr(4):=chain;
shdescr(6):=work shift (-24) extract 24;
shdescr(7):=work extract 24;
setshare6(supdev,shdescr,1);
monitor(16)send message:(supdev,1,shdescr);
monitor(18)wait answer:(supdev,1,shdescr);
description:=shdescr(2) extract 16;
end;
end description;
integer procedure octal_to_decimal(word);
value word;
integer word;
begin
integer i,j,k;
k:=word mod 200000;
j:=0;
for i:=100000,10000,1000,100,10,1 do
begin
j:= j*8 + k//i;
k:=k-(k//i)*i;
end;
octal_to_decimal:=j extract 16;
end octal_to_decimal;
procedure write_formatted(word,mask);
value word,mask ;
integer word,mask ;
begin <* writes the contents of 'word' according to format specification
given in 'mask' *>
integer i,j,char;
for i:= 0 step 1 until 4 do
begin
if mask shift (-i) extract 1 = 1 then
begin
case i+1 of
begin
begin <* octal *>
for j:= 15 step -3 until 0 do
write(out,<<d>,word shift(-j) extract 3);
write(out,sp,2);
end;
write(out,<<ddddd>,word,sp,2); <* decimal *>
write(out,<<ddd>,word shift (-8) extract 8,
sp,1,word extract 8,sp,2); <* byte *>
begin <* bit *>
for j:= 8 step 1 until 23 do
write(out,if word shift j < 0 then <:1:> else <:.:>);
write(out,sp,2);
end;
begin <* text *>
for j:= 8 step -8 until 0 do
begin
char:= word shift (-j) extract 8;
if char > 32 and char < 127
then outchar(out,char)
else outchar(out,32);
end;
end;
end case;
end;
end for-loop;
end write_formatted;
procedure check_host_online;
begin
if -,host_connected and -,coredump then
begin
link_to_console;
if -,host_connected then
begin
if not_online then goto endprogram
else goto nextline;
end;
end;
end check_host_online;
procedure type_text(text);
string text ;
begin
write(out,text,nl,1);
end;
boolean procedure next_param(type);
integer type ;
begin <* this procedure returns the next call parameter in array
'param' .
1<= type <= 4 :
type checking is performed as follows:
type=1 (call): space_name is demanded
type=2 - : point_name -
type=3 - : space_integer -
type=4 - : point_integer -
in case of errors error messages are written
on current output.
type = 5 : any type is accepted. the actual type value
(1,2,3 or 4) is returned.
the procedure returns true as long as the next parameter exists,
otherwise false. *>
procedure conv_error(number,i,type,delim);
value number,i,type,delim ;
integer number,i,type,delim ;
begin <* error-messages in conversational mode *>
write(out,<:<10>***ncptest: illegal parameter no. :>,paramno,
<: , read: :>);
if delim = 0
then write(out,<:<integer>:>)
else outchar(out,delim);
if kind(i) = 6 <* text *>
then write(out,string ra(increase(i)))
else
if kind(i) = 2 <* legal number *>
then write(out,round ra(i))
else write(out,<: illegal number :>);
syntax_error:= true;
goto next_line;
end conv_error;
integer sep,action,number,delim,separator;
if not_online then
begin <* fp_mode *>
sep:= system(4,paramno,param);
case type of
begin
syntax_error:= sep <> space_name;
syntax_error:= sep <> point_name;
syntax_error:= sep <> space_integer;
syntax_error:= sep <> point_integer;
begin <* return actual type *>
type:= if sep = space_name then 1 else
if sep = point_name then 2 else
if sep = space_integer then 3 else
if sep = point_integer then 4 else 5;
syntax_error:= sep<>0 and type=5 ;
end;
end;
if syntax_error then
begin
separator:= 5;
for i:= 1 step 1 until 4 do
if sep = ( case i of (space_name,point_name,space_integer,
point_integer)) then separator:= i ;
i:= 1;
write(out,<:<10>***:>,string ncptest_name(increase(i)),
<:: illegal fpparameter no. :>,
paramno,<: , read: :>,case separator of (<: :>,<:.:>,
<: :>,<:.:>,<::>));
if separator < 3 <* name *> then
begin
i:= 1;
write(out,string param(increase(i)));
end
else if separator <> 5 then
write(out,round param(1));
ok:= false;
goto endprogram;
end syntax_error;
next_param:= sep <> 0;
end
else
begin <* conversational mode *>
delim:= 0;
number:= -1;
<* search item *>
for i:= 0,i + 1 while kind(i) <> 8 and number < paramno do
begin
action:= case ((kind(i)-1)*8 + kind(i+1)) of
<* kind(i+1) *>
( 3 , 3 , 3 , 3 , 3 , 2 , 2 , 2 ,
3 , 3 , 3 , 3 , 3 , 2 , 2 , 2 ,
3 , 3 , 3 , 3 , 3 , 3 , 3 , 3 ,
<* kind(i) *> 3 , 3 , 3 , 3 , 3 , 3 , 3 , 3 ,
3 , 3 , 3 , 3 , 3 , 3 , 3 , 3 ,
3 , 3 , 3 , 3 , 3 , 2 , 2 , 2 ,
1 , 1 , 3 , 3 , 3 , 1 , 2 , 2 ) ;
case action of
begin
number:= number + 1; <* text or integer found *>
; <* skip *>
begin <* error *>
write(out,<:<10>action-table in error:>);
goto endprogram;
end;
end;
end for-loop;
if number = paramno then
begin <* now 'i' points at the first element of the
item in array 'ra' . get the item and check it . *>
if kind(i-1) = 7 then delim:= round ra(i-1);
case type of
begin
<* space-name *> if delim <> 32 or kind(i) <> 6
then conv_error(number,i,1,delim);
<* point-name *> if delim <> 46 or kind(i) <> 6
then converror(number,i,2,delim);
<* space-int. *> if delim <> 32 or kind(i) <> 2
then conv_error(number,i,3,delim);
<* point-int. *> if delim <> 46 or kind(i) <> 2
then conv_error(number,i,4,delim);
<* any type *> begin
if delim=32 and kind(i)=6 then type:= 1 else
if delim=46 and kind(i)=6 then type:= 2 else
if delim=32 and kind(i)=2 then type:= 3 else
if delim=46 and kind(i)=2 then type:= 4 else
conv_error(number,i,5,delim);
end;
end case;
<* return item in 'param' *>
if type < 3 then
begin <* text *>
param(1):= ra(i);
param(2):= if kind(i+1) <> 6 then real <::> else
ra(i+1) shift(-8) shift 8; <* max 11 chars *>
end
else
param(1):= ra(i);
end
else if type<>5 then
begin
syntax_error:= true;
goto next_line;
end;
next_param:= number = paramno;
end conversational mode;
paramno:= paramno + 1;
end next_param;
integer procedure convert_to_number(param);
array param ;
begin
integer i,j;
j:= 23;
for i:= 1 step 1 until 22 do
begin
if param(1) = ( case i of ( real<:typei:> add 'n' ,
real<:end:> ,
real<:comma:> add 'n' ,
real<:info:> ,
real<:host:> ,
real<:core:> ,
real<:set:> ,
real<:prog:> ,
real<:proc:> ,
real<:table:> ,
real<:devic:> add 'e' ,
real<:buffe:> add 'r' ,
real<:buf:> ,
real<:dump:> ,
real<:moved:> add 'u' ,
real<:diagn:> add 'o' ,
real<:sendw:> add 'a' ,
real<:termi:> add 'n' ,
real<:print:> add 'e' ,
real<:hdlcs:> add 't' ,
real<:minir:> add 'o' ,
real<:forma:> add 't' )) and
param(2) = ( case i of ( real<::> ,
real<::> ,
real<:ds:> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<:table:> ,
real<:pool:> ,
real<::> ,
real<::> ,
real<:mp:> ,
real<:stic:> ,
real<:it:> ,
real<:al:> ,
real<:r:> ,
real<:at:> ,
real<:cs:> ,
real<::> ))
then
j:= i;
end;
if -,ncptest and j<>4 and j<>5 and j<>18 and j<>19 and j<>21 then
j:= 23;
ok:= j<>23;
syntax_error:= -,ok;
convert_to_number:= j;
end convert_to_number;
procedure outtable(alphabet,length);
value length ;
integer length ;
integer array alphabet ;
begin <* enter 'class shift 12 + value' corresponding to the 'length'
first characters of the current alphabet in array 'alphabet'.
used for later call of 'intable' . *>
zone alpha(25,1,blockproc);
integer class,char,i;
procedure blockproc(z,s,b);
zone z ;
integer s,b ;
if (s shift (-5)) extract 1 <> 1 then stderror(z,s,b) else b:= 25*4;
if length < 0 or length > 127 then length:= 127;
open(alpha,0,<::>,1 shift 5);
for i:= 0 step 1 until length do write(alpha,false add i,1);
write(alpha,false add 10,1);
setposition(alpha,0,0);
for i:= 0 step 1 until length do
begin
class:= readchar(alpha,char);
if char <> i then
begin
class:= 0;
repeatchar(alpha);
end;
alphabet(i):= class shift 12 + i;
end;
end outtable;
<* start of program *>
trapmode:= 0; <* write all alarms *>
trap(after_error);
errorbits:= 1; <* ok.no *>
raf:=0;
iaf:= 0;
<* constant definitions *>
s_text:= 1;
p_text:= 2;
s_number:= 3;
p_number:= 4;
anything:= 5;
octal:= 1;
int:= 1 shift 1;
byte:= 1 shift 2;
bit := 1 shift 3;
text:= 1 shift 4;
all:= 31;
sp:= false add 32;
nl:= false add 10;
space_name:= 4 shift 12 + 10;
point_name:= 8 shift 12 + 10;
space_integer:= 4 shift 12 + 4;
point_integer:= 8 shift 12 + 4;
giveup:= 1 shift 16 + 1 shift 7;
proc_chain:=prog_chain:= 0;
mask:= all; words:= 1; firstcore:= 0; lastcore:= 10;
not_online:= true;
host_connected:= false;
coredump:= false;
syntax_error:= false;
kind(0):= 7; <* delimiter *>
ra(0):= 32 ; <* space *>
system(4,0,param);
ncptest_name(1):= param(1); ncptest_name(2):= param(2);
ncptest:= (param(1)=real<:ncpte:> add 115) and (param(2)=real<:t:>);
paramno:= 1;
next_param(s_text);
<* decide action *>
if convert_to_number(param)=1 then
begin <* typein - enter conversational mode *>
write(out,<:*** ncptest version 3.2 850524 ***<10>:>);
not_online:= false;
<* modify standardalphabet *>
outtable(alphabet,127);
for i:= 39,43,46 do alphabet(i):= 7 shift 12 + i;
intable(alphabet);
tableindex:= 0;
next_line:
if syntax_error then
write(out,nl,1,<:try 'commands' and 'info <commands>':>,nl,1);
syntax_error:= false;
write(out,<:*:>);
setposition(out,0,0);
morelines:= true;
start_pos:= 1;
while morelines do
begin <* read lines of command *>
i:= readall(in,ra,kind,start_pos);
if i < 0 then
begin <* array bounds exceeded *>
write(out,<:<10>command too long - last line skipped<10>:>);
setposition(out,0,0);
kind(start_pos):= 8; <* terminates inf. in 'ra' and 'kind'*>
morelines:= false;
end
else
begin <* check if current line terminates command *>
for i:= 0,i+1 while round ra(i) = 32 do;
if kind(i) = 8 then goto next_line; <* skip if no command *>
for i:= startpos,i+1 while kind(i) <> 8 do;
last:= i;
ra(last):= 32;
kind(last):= 7;
for i:= i,i-1 while kind(i) = 7 and round ra(i) = 32 do;
if (kind(i) = 7 and round ra(i) = 44) <* comma *> then
begin
ra(i):= ra(i+1):= 32; <* space *>
kind(i):= kind(i+1):= 7;
startpos:= i+1;
end
else
begin
morelines:= false;
kind(last):= 8;
end;
end;
end while_loop;
<* start execution of command *>
paramno:= 0;
next_param(s_text);
case convert_to_number(param) of
begin
<* typein ignored *> ;
goto endprogram ; <* end *>
commands ;
info ;
host ;
core ;
set ;
prog ;
proc ;
table ;
devicetable ;
bufferpool ;
buf ;
dump ;
movedump ;
diagnostic ;
sendwait ;
terminal(0) ; <* initialize terminal *>
terminal(1) ; <* initialize printer *>
hdlcstat ;
minirocs ;
format ;
begin <* illegal command *>
i:= 1;
write(out,<:<10>***ncptest: illegal command , read: :>,
string param(increase(i)),<:<10>:>);
end;
end case;
goto next_line;
end conv_mode ;
repeat
case convert_to_number(param) of
begin
<* typein *>;
<* end *> ;
commands ;
info ;
host ;
core ;
set ;
prog ;
proc ;
table ;
devicetable;
bufferpool ;
buf ;
dump ;
movedump ;
diagnostic ;
sendwait ;
terminal(0); <* initialize terminal *>
terminal(1); <* initialize printer *>
hdlcstat ;
minirocs ;
format ;
begin <* illegal fpparameter *>
i:= j:= 1;
write(out,<:<10>***:>,string ncptest_name(increase(i)),
<:: illegal command, fpparameter no. :>,paramno,
<: , read: :>,string param(increase(j)),nl,1);
goto endprogram;
end;
end case;
type:=anything
until -,ok or -,next_param(type);
endprogram:
if ok then errorbits:= 0; <* ok.yes *>
after_error:
if syntax_error and ncptest then
write(out,nl,1,<:try 'ncptest commands' and 'ncptest info <commands>':>,nl,1);
if host_connected then remove_link;
end;
▶EOF◀