|
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: 62208 (0xf300)
Types: TextFile
Names: »tncp1«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »tncp1«
begin <* this program is used for ncp testing *>
integer array kind(0:100),alphabet(0:127),shdescr(1:12),zdescr(1:20);
real array ra(0:100),param(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,
record_length,giveup;
boolean ok,not_online,morelines,sp,nl,host_connected,coredump,
ncptest;
zone supdev(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);
end;
\f
procedure info;
begin
next_param(s_text);
write(out,<:call:<10>:>,sp,16,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>) ,
(format.octal.decimal.byte.bit.text.all),
(words.<words per line>)<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 <content>.. ':>,
<:prog.<item> <first address>(.<last address>) ,
(format.octal.decimal.bytes.bit.text.all),
(words.<words per line>)<10>
' prints from <first address> to <last address>
relative to program <item> ':>,
<:proc.<item> <first address>(.<last address>) ,
(format.octal.decimal.bytes.bit.text.all),
(words.<words per line>)<10>
' prints from <first address> to <last address>
relative to process <item> ':>,
<:table.<table number> (entry.<first entry>(.<last entry>)) ,
(<first address>(.<last address>)) ,
(format.octal.decimal.bytes.bit.text.all),
(words.<words per line>)<10>
' prints <first entry> to <last entry> of NCP's table no <table no> ':>,
<:devicetable (<first entry>(.<last entry>))<10>
' prints <first entry> to <last entry> of NCP's devicetable ':>,
<: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 <mt name> <bs name><10>
' moves a rc3600 coredump from the tape <mt name> to
the bs file <bs name> ':>,
<:diagnostic (process.all!<proc name>(.event)) (running) (delay)<10>
' prints a diagnostic of process description and their event
queue, the running queue and the delay queue ':>,
<:sendwait name.<name> mess.<mess0>.<mess1>.<mess2>.<mess3><10>
' send a message and waits for an answer ':>,
<:terminal (driver.<name>) chan.<channo> (type.<termtype>) (timer.<timer>)
(s.<stopbits>) (p.<parity>) (l.<charlength>) (r.<bitrate>)<10>
' initialises the terminalcoroutine connected via <name> and <channo> ':>,
<::>,<::>,<::>),nl,1);
write(out,nl,1,sp,16,<:all addresses and words are in octal numbers:>,nl,1);
end;
\f
procedure host;
begin
integer devicehost;
next_param(s_number);
if coredump then close(supdev,true);
coredump:=false;
devicehost:=round param(1);
link_host(devicehost);
supdev_pointer:=0;
end host;
procedure link_host(devicehost);
value devicehost;
integer devicehost;
begin
integer peripherals,i,j,hoststatus;
integer array start(1:2),process_description(0:5);
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);
system(5)copy core:(start(1),nametable);
for i:=0,i+1 while (-,host_connected and i<=peripherals) do
begin
system(5)copy core:(nametable(i),process_description);
if process_description(0)=82 then <* kind=subhost *>
begin
j:=linkup(i,devicehost);
if j<>-1 then hoststatus:=j;
end;
end;
if -,host_connected then
begin
if hoststatus = -1 then write(out,<:devicehost no :>,devicehost,<: not found:>,nl,1) else
write(out,<:link error : :>,case hoststatus extract 4 of (
<: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:>),
<:<10>connecting to devicehost no :>,devicehost,nl,1);
ok:= false;
end;
end;
end link_host;
\f
procedure core;
begin
integer first,last,mask,words;
check_host_online;
write(out,nl,1,<:*** core ***:>,nl,1);
core_specifications(first,last);
first:=octal_to_decimal(first);
last:=octal_to_decimal(last);
format_specifications(mask,words);
print_core(0,first,last,mask,words);
end;
procedure prog;
begin
check_host_online;
write(out,nl,1,<:*** program :>);
print_item(12 shift 12);
end prog;
procedure proc;
begin
check_host_online;
write(out,nl,1,<:*** process :>);
print_item(10 shift 12);
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);
set_3600_address(i);
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,if -,coredump then <:no devicehost connected:>
else <:coredump mode:>,nl,1);
ok:= false;
end;
end set;
\f
procedure table;
begin
integer tabno,first,last,word,first_entry,last_entry,mask,words;
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);
format_specifications(mask,words);
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 if get_tabdescr;
end table;
\f
procedure typein;
begin
integer i,j;
if -,not_online then
begin
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 devicetable;
begin
integer first,last,word,i;
integer array tabdescr(0:5);
boolean first_type;
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;
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);
for j:=1 step 1 until 13 do
begin
case j of
begin
begin
write(out,nl,1,<: 0: device semaphore:>,sp,4,<:: :>);
write_formatted(get_3600_word,octal);
end;
begin
word:=get_3600_word;
write(out,nl,1,<: 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;
end case;
end for j;
end for i;
end if get_tabdescr;
end devicetable;
\f
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:>,<:rtco:>,<:rtci:>,<:test:>,<:xmt hdlc:>,<:rec hdlc:>),
<: 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 if get_tabdescr;
end bufferpool;
\f
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 114) 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 118) and (param(2)=real<:er:>) then
begin
next_param(p_text);
receiver:=description(param,10 shift 12);
end else paramno:=paramno-1;
param(1):=sender;
addr:=description(param,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;
\f
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 close(supdev,true);
coredump:=true;
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(supdev,modekind,string tail.raf(increase(j)),giveup);
end
else
open(supdev,4,string param(increase(j)),giveup);
j:=1;
write(out,nl,1,<:dump : :>,string param(increase(j)),nl,1);
setposition(supdev,0,0);
record_length:=inrec6(supdev,0);
max_link:=((record_length*3)//4) shift (-1) shift 1;
supdev_pointer:=0;
end
else
begin
coredump:= false;
write(out,nl,1,<:dumpentry not found:>,nl,1);
end;
end dump;
\f
procedure movedump;
begin
zone savezone(2*128,2*1,stderror),dumpzone(2*128,2*1,blockproc);
integer field iff;
integer i,j,transferred,words,halfwords;
integer array tail(1:10);
procedure blockproc(z,s,b);
zone z;
integer s,b;
if s shift 7 < 0 then
goto end_move else
if s shift 16 > 0 then
stderror(z,s,b);
next_param(s_text);
i:=1;
open(dumpzone,18,string param(increase(i)),giveup);
next_param(s_text);
i:=1;
open(savezone,4,string param(increase(i)),0);
i:=monitor(42)lookup entry:(savezone,1,tail);
if i=0 and tail(1)<0 then
write(out,nl,1,<:not bs entry:>,nl,1)
else
if i<>0 then
begin
tail(1):=87;
tail(2):=1;
for i:=3 step 1 until 10 do tail(i):=0;
tail(6):=systime(7,0,0.0);
i:=monitor(40)create entry:(savezone,1,tail);
end;
if i=0 then
begin
setposition(dumpzone,0,0);
setposition(savezone,0,0);
transferred:=0;
halfwords:=inrec6(dumpzone,0);
words:=((halfwords*3)//4) shift (-1) shift 1;
inrec6(dumpzone,halfwords);
while transferred < 32767 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;
end_move:
write(savezone,false,768);
end
else
write(out,nl,1,<:error in create entry:>,nl,1);
close(savezone,true);
close(dumpzone,true);
end movedump;
\f
procedure diagnostic;
begin
integer word,process;
boolean first_type,event,all_process;
check_host_online;
event:=all_process:=false;
first_type:=true;
type:=anything;
next_param(type);
if type=s_text and param(1)=(real<:proce:> add 115) 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,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
word:=44;
set_3600_address(word);
word:=get_3600_word;
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 paramno:=paramno-1;
type:=anything;
next_param(type);
if type=s_text and param(1)=(real<:runni:> add 110) and param(2)=real<:g:> then
begin
write(out,nl,1,<:*** processes in running queue ***:>,nl,1);
print_process_queue(32);
end else paramno:=paramno-1;
type:=anything;
next_param(type);
if type=s_text and param(1)=real<:delay:> and param(2)=real<::> then
begin
write(out,nl,1,<:*** processes in delay queue ***:>,nl,1);
print_process_queue(39);
end else paramno:=paramno-1;
end diagnostic;
\f
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 *>
shdescr(8):= (octal_to_decimal(round param(1))) shift 8;
next_param(p_number); <* mess1 *>
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 shdescr(1)<>0 then
write(out,nl,1,<:sequence error:>,nl,1)
else
begin
write(out,nl,1,<:*** answer ***:>,nl,2,<:mess0: :>);
write_formatted(shdescr(8) shift (-8),all);
write(out,nl,1,<:mess1: :>);
write_formatted(shdescr(9),all);
write(out,nl,1,<:mess2: :>);
write_formatted(shdescr(10) shift (-8),all);
write(out,nl,1,<:mess3: :>);
write_formatted(shdescr(11),all);
write(out,nl,1);
end;
end else paramno:=paramno-1;
end else paramno:=paramno-1;
end else
begin
write(out,nl,1,if -,coredump then <:no devicehost connected:>
else <:coredump mode:>,nl,1);
ok:= false;
end;
end sendwait;
\f
procedure terminal;
begin
if host_connected then
begin
integer channo,timer,termtype,spec,i,j,k;
real drivername;
spec:= 1 shift 15;
drivername:= real<:amx:>;
timer:= 60; termtype:= 0;
next_param(s_text);
if param(1)=real<:drive:> add 114 and param(2)=real<::> then
begin
next_param(p_text);
drivername:=param(1);
end else paramno:=paramno-1;
for i:= 1 step 1 until 6 do
begin
j:=drivername shift (-40) extract 8;
if j>= 97 and j<= 122 then j:=j-32;
drivername:= (drivername shift 8) add j;
end;
next_param(s_text);
if param(1)=real<:chan:> and param(2)=real<::> then
begin
next_param(p_number);
channo:= round param(1);
type:=anything;
next_param(type);
if type=s_text and param(1)=real<:type:> and param(2)=real<::> then
begin
next_param(p_number);
termtype:=round param(1);
end else paramno:=paramno-1;
type:=anything;
next_param(type);
if type=s_text and param(1)=real<:timer:> and param(2)=real<::> then
begin
next_param(p_number);
timer:=round param(1);
end else paramno:= paramno-1;
type:=anything;
next_param(type);
i:=2;
if type=s_text and param(1)=real<:s:> and param(2)=real<::> then
begin
next_param(p_number);
i:=round param(1);
end else paramno:=paramno-1;
spec:=spec + (i-1) shift 12;
type:=anything;
next_param(type);
i:=1;
if type=s_text and param(1)=real<:p:> and param(2)=real<::> then
begin
next_param(p_text);
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
if param(1)=real<:e:> and param(2)=real<::> then i:=1;
end else paramno:=paramno-1;
spec:=spec + i shift 10;
type:=anything;
next_param(type);
i:=7;
if type=s_text and param(1)=real<:l:> and param(2)=real<::> then
begin
next_param(p_number);
i:=round param(1);
end else paramno:=paramno-1;
if i<=8 then
begin
case i of
begin
;
;
;
;
spec:= spec + 0 shift 8;
spec:= spec + 2 shift 8;
spec:= spec + 1 shift 8;
spec:= spec + 3 shift 8;
end case;
end;
type:=anything;
next_param(type);
i:=2400; k:=2;
if type=s_text and param(1)=real<:r:> and param(2)=real<::> then
begin
next_param(p_number);
i:= round param(1);
end else paramno:= paramno-1;
for j:=1 step 1 until 14 do
if i= (case j of (9600,4800,2400,1200,600,300,220,200,
150,134,110,75,50,40)) then k:=j-1;
spec:= spec + k shift 4 + k;
getshare6(supdev,shdescr,1);
shdescr(4):= 16 shift 12;
shdescr(5):= termtype;
shdescr(6):= drivername shift (-24) extract 24;
shdescr(7):= drivername extract 24;
shdescr(8):= channo shift 16;
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,<:line and driver not found:>,nl,1);
end else write(out,nl,1,<:no channelnumber specified:>,nl,1);
end else
begin
write(out,nl,1,if -,coredump then <:no devicehost connected:>
else <:coredump mode:>,nl,1);
ok:= false;
end;
end terminal;
\f
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 *> word:=57 else word:=44;
next:= -1; found:=false;
set_3600_address(word);
word:=get_3600_word;
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
own integer firstcore,lastcore;
own boolean init;
type:=anything;
next_param(type);
if type=s_number then
begin
init:=true;
lastcore:=firstcore:=round param(1);
type:=anything;
next_param(type);
if type=p_number then
lastcore:=round param(1)
else
paramno:=paramno-1; <* try again *>
end
else
paramno:=paramno-1;
if -,init then
begin
firstcore:=0;
lastcore:=25;
end;
if firstcore>lastcore then firstcore:=lastcore;
first:=firstcore;
last:=lastcore;
end core_specifications;
\f
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 format_specifications(mask,words);
integer mask;
integer words;
begin
own boolean mask_set,words_set;
own integer omask,owords;
type:=anything;
next_param(type);
if (type=s_text) and (param(1)=real<:forma:> add 116) then
begin
omask:=0;
mask_set:=true;
type:=anything;
next_param(type);
while type=p_text do
begin
case format of
begin
omask:=omask add octal;
omask:=omask add int;
omask:=omask add byte;
omask:=omask add bit;
omask:=omask add text;
omask:=all;
type_text(<:illegal format:>);
end case;
type:=anything;
next_param(type);
end while type;
paramno:=paramno-1;
end else paramno:=paramno-1;
type:=anything;
next_param(type);
if type=s_text and param(1)= real<:words:> then
begin
next_param(p_number);
words_set:=true;
owords:=round param(1);
end else paramno:=paramno-1;
if -,mask_set then mask:=all else mask:=omask;
if -,words_set then words:=1 else words:=owords;
end format_specifications;
\f
procedure print_item(mode);
value mode;
integer mode;
begin
integer first,last,mask,addr,words;
next_param(p_text);
write(out,string param(1),<: ***:>,nl,1);
addr:=description(param,mode);
if addr <> 0 then
begin
core_specifications(first,last);
first:=octal_to_decimal(first);
last:=octal_to_decimal(last);
format_specifications(mask,words);
print_core(addr,first,last,mask,words);
end
else
write(out,<:not found:>,nl,1);
end print_item;
procedure print_event(process);
value process;
integer process;
begin
integer event,last_event,i;
integer array messbuf(1:10);
boolean first_type;
first_type:=true;
set_3600_address(process+7);
event:=get_3600_word;
last_event:=get_3600_word;
messbuf(1):=event;
if event=last_event then write(out,nl,1,<:event queue empty:>,nl,1);
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 print_event;
\f
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_event(process);
end;
end print_process;
\f
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);
write_formatted(first,octal);
for k:=0,1,2 do
write_formatted(get_3600_word,text);
write(out,nl,1);
end;
end print_process_queue;
\f
integer procedure get_3600_word;
begin
integer i;
real field rf;
if supdev_pointer>=max_link then
begin
inrec6(supdev,record_length);
supdev_pointer:=0;
end;
i:=(2-supdev_pointer mod 3)*16;
rf:=(supdev_pointer//3+1)*4;
get_3600_word:=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
setposition(supdev,0,addr//max_link);
supdev_pointer:=addr mod max_link;
inrec6(supdev,record_length);
end
else
begin
setposition(supdev,0,0);
getshare6(supdev,shdescr,1);
shdescr(4):=8 shift 12;
shdescr(5):=addr;
setshare6(supdev,shdescr,1);
monitor(16)send message:(supdev,1,shdescr);
monitor(18)wait answer:(supdev,1,shdescr);
supdev_pointer:=max_link;
end;
end set_3600_address;
\f
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;
param(1):= real<:ncp:>;
param(2):=real<::>;
addr:=description(param,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
begin
get_tabdescr:=false;
type_text(<:table not found:>);
end
else
get_tabdescr:=true;
end get_tabdescr;
\f
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;
\f
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,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):=10000; <* 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 shdescr(1) extract 12<>0 then
linkup:=shdescr(1) extract 12
else if i = 1 then
begin
process:=z.iaf(11);
max_link:= (z.iaf(3)//6)*3;
getzone6(supdev,zdescr);
if zdescr(20)<max_link//3 then
max_link:=zdescr(20)*3;
record_length:=(max_link//3)*4;
system(5,process,process_description);
raf:=2;
close(z, true);
i :=1; open(z, 12, string process_description.raf(increase(i)),0);
getshare6(z, shdescr, 1);
shdescr(4) := 8 shift 12; shdescr(5) := 0;
setshare6(z, shdescr, 1);
monitor(16)send_message:(z, 1, shdescr);
i := monitor(18)wait_answer:(z, 1, shdescr);
if i > 1 or shdescr(1)<>0 then
monitor(64)remove_process:(z, 1, shdescr) else
begin
linkup := 0;
host_connected := true;
i:=1;
open(supdev,12,string process_description.raf(increase(i)),giveup);
write(out,nl,1,<:connected to devicehost no: :>,devicehost,nl,1);
end end;
end linkup;
\f
procedure link_to_console;
begin
integer array process_description(0:25),name(1:12);
zone z(6,1,stderror);
open(z,8,<:console1:>,0);
if monitor(4,z,1,name)<>0 then
begin
system(5,monitor(4,z,1,name),process_description);
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;
array name;
begin
real work;
work:=name(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; <* 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;
\f
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;
\f
integer procedure format;
format:= if param(1) = real<:octal:> then 1 else
if param(1) = real<:decim:> add 97 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 7;
procedure check_host_online;
begin
if -,host_connected and -,coredump then
begin
link_to_console;
if -,host_connected then
begin
write(out,<:no devicehost connected:>,nl,1);
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;
\f
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>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 :>);
ok:=false;
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
ok:= sep = space_name;
ok:= sep = point_name;
ok:= sep = space_integer;
ok:= 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;
ok:= sep=0 or type<5 ;
end;
end;
if -,ok 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 ;
write(out,<:<10>*** 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));
goto endprogram;
end -, ok;
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
ok:=false;
goto next_line;
end;
next_param:= number = paramno;
end conversational mode;
paramno:= paramno + 1;
end next_param;
\f
integer procedure convert_to_number(param);
array param ;
begin
integer i,j;
j:= 21;
for i:= 1 step 1 until 20 do
begin
if param(1) = ( case i of ( real<:typei:> add 110 ,
real<:end:> ,
real<:comma:> add 110 ,
real<:info:> ,
real<:host:> ,
real<:core:> ,
real<:set:> ,
real<:prog:> ,
real<:proc:> ,
real<:table:> ,
real<:devic:> add 101 ,
real<:buffe:> add 114 ,
real<:buf:> ,
real<:dump:> ,
real<:moved:> add 117 ,
real<:diagn:> add 111 ,
real<:sendw:> add 97 ,
real<:termi:> add 110 ,
real<::> ,
real<::> )) 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<::> ,
real<::> ))
then
j:= i;
end;
if -,ncptest and j<>5 and j<>18 then
j:= 21;
ok:= j<>21;
convert_to_number:= j;
end convert_to_number;
\f
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;
\f
trapmode:= 0; <* write all alarms *>
trap(after_error);
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;
not_online:= true;
host_connected:= false;
coredump:= false;
supdev_pointer:=0;
kind(0):= 7; <* delimiter *>
ra(0):= 32 ; <* space *>
system(4,0,param);
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 *>
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 -,ok then
write(out,nl,1,<:try 'commands' and 'info <commands>':>,nl,1);
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 ;
;;
begin <* illegal command *>
i:= 1;
write(out,<:<10>*** illegal command : :>,
string param(increase(i)),<:<10>:>);
end;
end case;
goto next_line;
end conv_mode ;
\f
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 ;
;;
begin <* illegal fpparameter *>
write(out,<:<10>*** illegal fpparameter no. :>,paramno);
goto endprogram;
end;
end case;
type:=anything;
until -,ok or -,next_param(type);
after_error: errorbits:= 1;
endprogram:
if -,ok and ncptest then
write(out,nl,1,<:try 'ncptest commands' and 'ncptest info <commands>':>,nl,1);
if host_connected then remove_link;
end;
▶EOF◀