|
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: 327168 (0x4fe00)
Types: TextFile
Names: »tcomal«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »tcomal«
begin
write(out,false add 10,1);
message version 2.3 d.801121.1345 ;
write(out,<:version 2.3 d.801121.1345 <10>:>);
setposition(out,0,0);
begin
boolean sp,nl,ff,za1discconn,att_status,za1timeout,newincarnation,locked,
hotnews,testbit1,testbit2,testbit3,testbit1or2,
testbit13,testbit24,testbit28,testbit29;
integer maxkit,users_in_core,catalogsize,no_of_zones,zasize,bufs,primoindex,
incarn,maxincarn,contextmode,i,j,k,k1,x,
storelength,storesize,segments_user,no_of_user_zones,zaindex,
discno,recno,zablprocerror,
maxnames,scantablelength,syntaxtablelength,createsize,
poolbuffer,qlength,waitinglines,inroom,max_on_userkit,basicusers;
real r,r1, basicstarttime,tmcpu,tmbase,tmtime,sys14,sys15;
long entrytime,timeslice;
integer field inf,if2,if4,if6,if8,
flag,rnd,esc,err,lowbound,programstart;
integer array ia(1:20), owncatbase(1:2),iso(0:255);
long field lf4,lf6,lf8;
real field determinant;
integer array field fcttable,editarea;
long array field laf0,laf2,laf8,laf16;
real array field raf0,raf2;
boolean array temst(13:23);
long array la,ystdkit,usercat,filerouter,basicerror,comalacc(1:2),
syntaxerror(1:8);
zone ownprocess(1,1,stderror),
ztem(1,1,stderror),
zph(1,1,stderror),
zhelp(26,1,stderror);
\f
boolean procedure weekandday(yymmdd, weeknumber, weekday);
integer yymmdd, weeknumber, weekday;
<*
weekandday (return, boolean) true=>legal date, false=>illegal date
yymmdd (call and return, integer)
if call value is 0 then return
value is actual date
weeknumber (return, integer) weeknumber 1 is first week with a thursday
illegal date: weeknumber -1
weekday (return, integer) 1: monday,...,7: sunday, 8: illegal date
*>
begin integer d,m,y,w;
boolean leap;
if yymmdd=0 then yymmdd:=systime(5,0,0.0);
d:=yymmdd mod 100;
m:=(yymmdd//100) mod 100;
y:=1900 + yymmdd//10000;
leap:=y mod 100<>0 and y mod 4=0 or y mod 400=0;
if m<1 or m>12 then goto illegal;
if d>(case m of(31,if leap then 29 else 28,31,30,31,30,31,31,30,31,30,31))
then goto illegal;
w:=(if m>2 then (if leap then 29 else 28) else 0) +
(case m of
(0,
31,
31,
31+31,
31+31+30,
31+31+30+31,
31+31+30+31+30,
31+31+30+31+30+31,
31+31+30+31+30+31+31,
31+31+30+31+30+31+31+30,
31+31+30+31+30+31+31+30+31,
31+31+30+31+30+31+31+30+31+30)) + d - 1;
\f
if m>2 then m:=m-3 else
begin m:=m+9; y:=y-1; end;
d:=(146097*(y//100))//4+(1461*(y mod 100))//4
+(153*m+2)//5+d+1721119;
d:=d mod 7+1;
w:=w+4-d;
weekandday:=true;
weeknumber:=if w<0 then 0 else (w//7+1);
weekday:=d;
if false then
begin
illegal:
weekandday:=false; weeknumber:=-1; weekday:=8
end;
end weekandday;
procedure texterror(z,s,b);
zone z; integer s,b;
begin
b:=512;
z(1):=real<::>; z(2):=real<::> add 25;
end texterror;
\f
procedure outermost_init;
begin integer array ia(1:20);
real r; array ra(1:2);
long array field laf;
zone z(128,1,texterror);
systime(1,0,basicstarttime);
if -,week_and_day(0,i,i) then
begin
write(out,<:<10>system date is illegal: :>);
writedate(out,systime(5,0,0.0),0,20);
write(out,<:<10>sorry<10>:>);
setposition(out,0,0);
goto stop;
end;
<*find size of catalog*>
open(zhelp,0,<:catalog:>,0);
close(zhelp,true);
monitor(42<*lookup*>,zhelp,0,ia);
catalogsize:=ia(1)*15;
open(ownprocess,0,<::>,0); <*for set catalog base*>
<*find maxkit*>
system(5<*move core*>,92,ia);
maxkit:=(ia(3)-ia(1))/2 - 1;
basicerror(1):=long<:basic:> add 101<*e*>;
basicerror(2):=long<:rror:>;
usercat(1):=long<:userc:> add <*a*>97;
usercat(2):=long<:t:>;
comalacc(1):=long<:comal:> add <*a*>97;
comalacc(2):=long<:cc:>;
filerouter(1):=long<:primo:>;
filerouter(2):=long<::>;
ystdkit(1):=long<:disc:>; ystdkit(2):=0;
createsize:=168;
maxincarn:=5;
no_of_zones:=32;
no_of_user_zones:=7;
storelength:=7000;
users_in_core:=3;
basicusers:=400;
max_on_userkit:=100;
timeslice:=4000;
system(4,0,ra);
open(zhelp,0,ra,0); close(zhelp,false);
monitor(42<*lookup*>,zhelp,0,ia);
write(out,<:compiled :>);
writedate(out,systime(6,ia(6),r),r,9);
setposition(out,0,0);
i:=1;
read_fp_param:
if system(4,i,ra)=0 then goto finis_read_fp_param;
i:=i+1;
r:=ra(1);
j:=system(4,i,ra);
if r=real<:testb:> add 105<*i*> then
begin
i:=i+1;
for j:=system(4,i,ra) while j<>0 and
j shift (-12)<>4 do i:=i+1;
i:=i-1;
end
else
if r=real<:basic:> add 101<*e*> then
begin
basicerror(1):=long ra(1);
basicerror(2):=long ra(2);
end
else
if r=real<:userc:> add 97<*a*> then
begin
usercat(1):=long ra(1);
usercat(2):=long ra(2);
end
else
if r=real<:accou:> add <*n*>110 then
begin
comalacc(1):=long ra(1);
comalacc(2):=long ra(2);
end
else
if r=real<:filer:> add 111<*o*> then
begin
filerouter(1):=long ra(1);
filerouter(2):=long ra(2);
end
else
if r=real<:stdki:> add 116<*t*> then
begin
ystdkit(1):=long ra(1);
ystdkit(2):=long ra(2);
end
else
if r=real<:wrksi:> add 122<*z*> then createsize:=ra(1)
else
if r=real<:users:> then maxincarn:=ra(1)
else
if r=real<:files:> then no_of_user_zones:=ra(1)-1
else
if r=real<:zones:> then no_of_zones:=ra(1)
else
if r=real<:store:> then storelength:=ra(1)
else
if r=real<:basic:> add 117<*u*> then basicusers:=ra(1)
else
if r=real<:maxon:> add 107<*k*> then max_on_userkit:=ra(1)
else
if r=real<:times:> add 108<*l*> then timeslice:=ra(1)
else
if r=real<:corer:> add 101<*e*> then users_in_core:=ra(1)
else
begin
i:=i-1; system(4,i,ra);
i:=1; write(out,<:<10>error in fpparam: :>,
string ra(increase(i)),<:<10>:>);
setposition(out,0,0);
goto stop;
end;
i:=i+1;
if j<>0 then
goto read_fpparam;
finis_read_fpparam:
storelength:=((storelength*2+511)//512*512)//2;
zasize:=(22+(no_of_zones-1)*128+no_of_zones-1)//no_of_zones;
if i<>1 then
begin
write(out,<:
basicerror: :>,basicerror,<:
usercat: :>,usercat,<:
filerouter: :>,filerouter,<:
stdkit: :>,ystdkit,<:
wrksize: :>,<<d>,createsize,<:
users: :>,maxincarn,<:
files: :>,no_of_user_zones,<:
zones: :>,no_of_zones,<:
store: :>,storelength,<:
basicusers: :>,basicusers,<:
maxonkit: :>,maxonuserkit,<:
coreresident::>,users_in_core,<:
timeslice: :>,timeslice,<:<10>:>);
setposition(out,0,0);
end;
begin
integer array descr(0:39);
integer entr0,entr3,segm0,segm3,sll;
boolean procedure claimproc
(bsno,bsname,entries0,entries3,segm0,segm3,slicelength);
integer bsno,entries0,entries3,segm0,segm3,slicelength;
long array bsname;
<*
claimproc(return, boolean) true if bsno>=0 and bsno<=max bsno
and keyno is legal
else false. If claimproc is false then
all return parameters are zero.
keyno (call, integer) 0=temp
2=login
3=user/project
bsno (call, integer) main bsdevice is 0
bsname (return, long array 1:2) name of called device
entries (return, integer) no. of entries of key=keyno on called
device
segm (return, integer) no. of segm. of key=keyno on called
device
slicelength (return, integer) slicelength on called device
*>
begin
own boolean init;
own integer bsdevices,firstbs,ownadr;
integer i;
long array field name;
integer array core(1:18);
if -,init then
begin
init:=true;
system(5,92,core);
bsdevices:=(core(3)-core(1))//2;
firstbs:=core(1);
ownadr:=system(6,i,bsname);
end;
if bsno<0 or bsno>=bsdevices then
begin
claimproc:=false;
goto exitclaim
end;
claimproc:=true;
begin integer array nametable(1:bsdevices);
name:=18;
system(5,firstbs,nametable);
system(5,nametable(bsno+1)-36,core);
if core(10)=0 then goto exitclaim;
bsname(1):=core.name(1); bsname(2):=core.name(2);
slicelength:=core(15);
system(5,ownadr+core(1),core);
entries0:=core(1) shift (-12);
entries3:=core(4) shift (-12);
segm0:=core(1) extract 12 * slicelength;
segm3:=core(4) extract 12 * slicelength;
end;
if false then
begin
exitclaim:
slicelength:=0;
bsname(1):=bsname(2):=0;
end;
end claimproc;
\f
system(5<*move*>,system(6<*own process*>,i,la),descr);
bufs:=(descr(13) shift (-12)) - 4 - maxincarn;
if -,testbit(0) then goto exit_testbit0;
write(out,<<d>,<:
size: :>,descr(12)-descr(11),<:
buf: :>,descr(13) shift (-12),<:
area: :>,descr(13) extract 12,<:
cat base::>,<<-ddddddd>,descr(34),descr(35),<:
std base::>,descr(38),descr(39),<:
max base::>,descr(36),descr(37),<:<10>:>);
i:=-1;
for i:=i+1 while
claimproc(i,la,entr0,entr3,segm0,segm3,sll) do
begin
if la(1)<>0 then
begin
write(out,<:<10><10>:>,la,<:: :>,sll,<: segm/slice:>);
if entr0=0 and segm0=0 then
write(out,<: no resources:>)
else
write(out,<:<10> temp: :>,<<dddddd>,segm0,<: segm:>,
entr0,<: entr<10> perm :>,segm3,<: segm:>,
entr3,<: entr:>);
end
end;
write(out,false add 10,1);
setposition(out,0,0);
exit_testbit0:
end testbit0;
open(zhelp,0,usercat,0); close(zhelp,true);
if monitor(42<*lookup*>,zhelp,0,ia)<>0 then
begin
write(out,<:<10>usercat: :>,usercat,<: not found<10>:>);
setposition(out,0,0);
goto stop;
end;
open(z,4,basicerror,0);
if monitor(42<*lookup*>,zhelp,0,ia)<>0 then
begin
write(out,<:<10>basicerror: :>,basicerror,<: not found<10>:>);
setposition(out,0,0);
goto stop;
end;
laf:=2*32;
inrec6(z,512);
tofrom(syntaxerror,z.laf,32);
close(z,true);
open(zhelp,0,comalacc,0); close(zhelp,true);
if monitor(42<*lookup*>,zhelp,0,ia)<>0 then
begin
ia(1):=1;
for i:=2 step 1 until 10 do ia(i):=0;
i:=monitor(40<*create*>,zhelp,0,ia);
if i=0 then i:=monitor(50<*perm*>,zhelp,3,ia);
if i<>0 then
begin
write(out,<:<10>accountfile: :>,comalacc,<: not found<10>:>);
setposition(out,0,0);
goto stop;
end;
end;
open(zhelp,0,<:basichotnew:>,0); close(zhelp,true);
hotnews:=monitor(42<*lookup*>,zhelp,0,ia)=0;
open(zhelp,0,filerouter,0); close(zhelp,true);
if monitor(4<*process descr*>,zhelp,0,ia)=0 then
begin
write(out,<:<10>filerouter: :>,filerouter,<: process does not exist<10>:>);
setposition(out,0,0);
goto stop;
end;
open(ztem,0,<:tem:>,0);
if monitor(4<*process descr*>,ztem,0,ia)=0 then
begin
write(out,<:<10>tem process does not exist<10>:>);
setposition(out,0,0);
goto stop;
end;
system(11<*bases*>,0,ia); i:=ia(7); j:=ia(8);
owncatbase(1):=ia(1);
owncatbase(2):=ia(2);
isotable(iso);
for i:=128 step 1 until 255 do
iso(i):=iso(i-128);
intable(iso);
qlength:=maxincarn;
syntaxtablelength:=1030;
scantablelength:=244;
storesize:=storelength*2;
segments_user:=storesize//512;
flag:=2;
editarea:=0;
fcttable:=editarea+132;
rnd:=fcttable+60;
esc:=rnd+2;
err:=esc+2;
lowbound:=err+2;
determinant:=lowbound+4;
programstart:=determinant;
sp:=false add 32;
nl:=false add 10;
ff:=false add 12;
locked:=false;
zablprocerror:=0;
sys14:=4*arctan(1);
sys15:=exp(1);
if2:=2;
if4:=4;
if6:=6;
if8:=8;
lf4:=4;
lf6:=6;
lf8:=8;
laf0:=0;
laf2:=2;
laf8:=8;
laf16:=16;
raf0:=0;
raf2:=2;
testbit1:=testbit(1);
testbit2:=testbit(2);
testbit1or2:=testbit1 or testbit2;
testbit3:=testbit(3);
testbit13:=testbit(13);
testbit24:=testbit(24);
testbit28:=testbit(28);
testbit29:=testbit(29);
end outermost_init;
\f
trap(syserr);
if false then
begin
syserr:
if poolbuffer=0 then else
begin
ia(9):=1;
monitor(22,ztem,poolbuffer,ia);
end;
goto stop;
end;
outermost_init;
\f
begin
integer array kittable(0:maxkit,1:4);
<*kitno,1:3 = kitname
kitno,4 = slicelength *>
procedure init_kittable;
<* initializes the array kittable(0:maxkit,1:4)
so that kittable(kitno,1:3) contains kitname
and kittable(kitno,4) contains slicelength
global variables:
integer array kittable
integer array kitlimits
integer maxkit
*>
begin
integer i,lim;
long array field laf;
system(5<*move core*>,92,ia);
lim:=ia(1)-2;
for i:=0 step 1 until maxkit do
begin <*prepare table of kitnames and slicelength*>
laf:=i*8; <* 8 is 2*4 because kittable(0:maxkit,1:4 *>
lim:=lim+2; <* next chain *>
system(5<*move core*>,lim,ia); <*ia(1)=addr next chain*>
system(5,ia(1)-28,ia); <*kitname, slicelength*>
tofrom(kittable.laf,ia.laf2,6); <*kitname*>
kittable(i,4):=ia(11);<*slicelength*>
if ia(1)=0 then
kittable(i,1):=kittable(i,2):=kittable(i,3):=kittable(i,4):=0;
if kittable.laf(1)=long<:disc:> then discno:=i;
end;
end init_kittable;
\f
procedure usercat_update;
<*
phase 1:
usercat is scanned and each user with userclaim is stored in array updat.
updat(1:2)=bases, updat(3:4)=max entries, max slices on kit0 etc.
phase 2:
catalog is scanned and for each area entry (i.e. non area entries are
of the corresponding kit is reduced (i.e. remaining is found).
phase 3:
usercat is scanned as in phase 1 and the remaining claims are swopped
back from array updat.
*>
begin integer ii, i,j,k,fil,b1,b2,index,kitno;
integer field inf,infx,infz;
boolean recs;
long array field laf;
integer array updat(1:basicusers,1:(maxkit+1)*2+2);
zone z(128,1,stderror);
boolean procedure findkitno(kitname);
long array kitname;
begin long array field laf;
for kitno:=0 step 1 until maxkit do
begin
laf:=kitno*8;
if kittable.laf(1)=kitname(1) and
kittable(kitno,3)=kitname.if6 then goto found;
end;
findkitno:=false;
if false then
found: findkitno:=true;
end findkitno;
open(z,4,usercat,0);
fil:=0;
for i:=inrec6(z,2),inrec6(z,2) while z.if2<1 do
fil:=fil+1;
setposition(z,0,fil);
inrec6(z,512);
index:=0;
inf:=2;
projectloop1:
infx:=inf+2;
if z.infx=8388607 then goto finis1;
inf:=inf+z.inf extract 12;
userloop1:
recs:=false;
if z.inf=0 then
begin inrec6(z,512); inf:=2 end;
if z.inf shift (-12)<>2 then
begin
inf:=inf+z.inf extract 12;
goto userloop1;
end;
infx:=inf+10;
i:=z.infx;
if index=basicusers then
begin
write(out,<:<10>initial value of basicusers too small<10>:>);
setposition(out,0,0);
goto stop;
end;
index:=index+1;
updat(index,1):=i;
infx:=infx+2;
infz:=infx+2;
updat(index,2):=i+z.infx+z.infz-2;
loop1:
inf:=inf+z.inf extract 12;
if z.inf=0 then
begin inrec6(z,512); inf:=2 end;
i:=z.inf shift (-12);
if i=0 then
begin
if -,recs then index:=index+1;
goto projectloop1;
end
else
if i=2 then
begin
if -,recs then index:=index-1;
goto userloop1;
end
else
if i<>6 and i<>34 then goto loop1 else
if i=6 then
begin
laf:=inf;
if -,findkitno(z.laf) then goto loop1;
infx:=inf+12;
end
else
begin
kitno:=discno;
infx:=inf+8;
end;
recs:=true;
updat(index,(kitno+1)*2+1):=z.infx shift (-12)<*entries*>;
updat(index,(kitno+1)*2+2):=z.infx extract 12; <*slices*>
goto loop1;
finis1:
close(z,true);
inf:=16; laf:=16;
open(z,4,<:catalog:>,0);
for ii:=1 step 1 until catalogsize do
begin
inrec6(z,34);
i:=z.inf;
if i>=0 and z.if2 shift (-12)<>4095<*cleared*> then
begin
b1:=z.if4; b2:=z.if6;
j:=0;
for j:=j+1 while j<=index and
-,(b1=updat(j,1) and b2=updat(j,2)) do;
if j<=index then
begin
findkitno(z.laf);
i:=(i-1+kittable(kitno,4))//kittable(kitno,4);
updat(j,(kitno+1)*2+1):=
updat(j,(kitno+1)*2+1) - 1;
updat(j,(kitno+1)*2+2):=
updat(j,(kitno+1)*2+2) - i;
end;
end;
end;
close(z,true);
open(z,4,usercat,0);
setposition(z,0,fil);
swoprec6(z,512);
inf:=2;
k:=index;
index:=0;
projectloop2:
infx:=inf+2;
if z.infx=8388607 then goto finis2;
inf:=inf+z.inf extract 12;
userloop2:
if z.inf=0 then
begin swoprec6(z,512); inf:=2; end;
if z.inf shift (-12)<>2 then
begin
inf:=inf+z.inf extract 12;
goto userloop2;
end;
if k=index then goto finis2;
index:=index+1;
infx:=inf+10;
i:=z.infx;
infx:=infx+2;
infz:=infx+2;
if updat(index,1)<>i or updat(index,2)<>i+z.infx+z.infz-2 then
begin
inf:=inf+z.inf extract 12;
index:=index-1;
goto userloop2;
end;
loop2:
inf:=inf+z.inf extract 12;
if z.inf=0 then
begin swoprec6(z,512); inf:=2; end;
i:=z.inf shift (-12);
if i=0 then goto projectloop2 else
if i=2 then goto userloop2 else
if i<>6 and i<>34 then goto loop2 else
if i=6 then
begin
laf:=inf;
if -,findkitno(z.laf) then goto loop2;
infx:=inf+10;
z.infx:=updat(index,(kitno+1)*2+1) shift 12 +
updat(index,(kitno+1)*2+2) extract 12;
end
else
begin
infx:=inf+6;
z.infx:=updat(index,(discno+1)*2+1) shift 12 +
updat(index,(discno+1)*2+2) extract 12;
end;
goto loop2;
finis2:
close(z,true);
end usercat_updat;
init_kittable;
usercat_update;
\f
begin
boolean attmod, loginsyntax, ignorestopatt;
integer attmess, termproc,linestoterm, termroom, termno,
lstchoosen, actions, lastinqueue, firstinqueue, position,
mainproc, mainno, oprno, act, lineclass, buffer, myselfproc,runlimit,
worki,workj,workk,basebuf,usercount,used,zno;
zone array za(no_of_zones,zasize,1,zablproc),zprimo(bufs,9,1,stderror),
store(users_in_core,storesize//4,1,stderror);
integer array syntaxtable(1:syntaxtablelength),
zonestate(1:2,1:users_in_core),
terminals(0:maxincarn,1:2),
executequeue(0:qlength-1),
class(1:155),
char(1:155),
loginkind(1:5),
userclaim(1:maxincarn+1,0:maxkit,1:2,1:2),
<*incarn,kitno,1,1 = max.entries
1,2 = max slices
incarn,kitno,2,1 = restentries
2,2 = restslices *>
zainf(1:no_of_zones+1,1:5),
<*zaindex,1 = incarn
zaindex,2 = kitno
zaindex,3 = mode
zaindex,4 = reclength
zaindex,5 = max recno *>
primoia(1:bufs+1,1:7);
<*bufaddr,transportno,projectno,bases
slices<12+kitno,supermode<12+segments *>
long array userident(1:maxincarn+1,1:3),
<*incarn,1:2 = initials
incarn,3 = projectno *>
primola(1:bufs,1:4),<*filename,username*>
names(1:scantablelength),
loginval(1:5);
real array cpu,realtime,logintime,lasttime(1:maxincarn);
boolean array killed(1:maxincarn+1);
\f
procedure zablproc(z,s,b);
zone z; integer s,b;
begin integer more, mode, sl, newsize,kitno,supermode;
<*: if testbit1 then
begin
write(out,<: block procedure status: :>,s,b,nl,1);
setposition(out,0,0);
end;:*>
if testbit1 then
begin long array field laf;
laf:=2;
getzone6(z,ia);
write(out,ia.laf,<: s=:>,s,<: b=:>,b,<:<10>:>);
setposition(out,0,0);
end;
if s shift (23-21)<0 then za1timeout:=true
else
if s shift (23-16)<0 then att_status:=true
else
if s shift (23-18)<0 <*em*> then
begin
kitno:=zainf(zaindex,2) ;
monitor(42<*lookup*>,z,0,ia);
sl:=kittable(kitno,4);
mode:=zainf(zaindex,3);
supermode:=mode//100;
mode:=mode mod 100;
newsize:=if mode<>0 then ia(1)+sl else
(zainf(zaindex,5)-1)//(512//ia(10) extract 12) + 1;
more:=if mode<>0 then 1 else
(newsize-1+sl)//sl-(ia(1)-1+sl)//sl;
if supermode>0 then
begin
ia(1):=newsize;
monitor(44<*change*>,z,0,ia);
monitor(16,z,1,ia);
check(z);
end
else begin
i:=userclaim(incarn,kitno,2,2);
if i>=more then
begin
ia(1):=newsize;
if mode=0 then ia(7):=zainf(zaindex,5);
monitor(44<*change*>,z,0,ia);
userclaim(incarn,kitno,2,2):=
userclaim(incarn,kitno,2,2) - more;
monitor(16,z,1,ia);
check(z);
end
else
zablprocerror:=1;
end;
end
else
begin
getzone6(z,ia);
if basebuf=ia(19) then
begin
zablprocerror:=0;
if s shift(23-5)<0 or s shift (23-4)<0 then
begin
za1discconn:=true;
b:=4;
end;
end
else
if ia.laf2(1)=long <:primo:> then zablprocerror:=0 else
begin
if s shift (23-5) < 0 then zablprocerror:=4
else
zablprocerror:=
if s shift (23-2)<0 then 2 else 3;
b:=512;
end;
end
end zablproc;
\f
procedure outer_init;
begin
integer array bufsize,shares(1:no_of_zones);
bufsize(1):=22;
for i:=2 step 1 until no_of_zones do bufsize(i):=128;
for i:=1 step 1 until no_of_zones do shares(i):=1;
initzones(za,bufsize,shares);
getzone6(za(1),ia);
basebuf:=ia(19);
for i:=1 step 1 until bufs do
begin
open(zprimo(i),0,<:primo:>,0);
close(zprimo(i),true);
end;
for i:=1 step 1 until bufs do primoia(i,1):=0;
for i:=1 step 1 until maxincarn+1 do killed(i):=false;
for i:=1 step 1 until maxincarn+1 do
for j:=1 step 1 until 3 do userident(i,j):=0;
for zaindex:=1 step 1 until no_of_zones+1 do
zainf(zaindex,1):=0;
open(za(2),4,<:scantable:>,0);
maxnames:=-1;
for maxnames:=maxnames+2 while
read(za(2),names(maxnames),names(maxnames+1))>0 do;
maxnames:=maxnames-2;
close(za(2),true);
open(za(2),4,<:syntaxtable:>,0);
i:=0;
for i:=i+1 while read(za(2),syntaxtable(i))>0 do;
close(za(2),true);
incarn:=0;
for i:=1 step 1 until users_in_core do
begin
open(store(i),4,<:basicswop:>,0);
zonestate(1,i):=zonestate(2,i):=0;
end;
usercount:=0;
ia(1):=segments_user*maxincarn;
ia(2):=1;
for i:=3 step 1 until 10 do ia(i):=0;
i:=monitor(40)create entry:(store(1),0,ia);
if i<>0 then
begin
if i=3 then i:=monitor(44)change entry:(store(1),0,ia);
if i>0 then
begin
write(out,<:***basic: create swoparea impossible<10>:>);
goto stop;
end;
end;
end outer_init;
\f
integer
procedure scan_usercat
(initials,projectno,base,type,curkitno,entries,slices,incarn,stdkit);
value curkitno,entries,slices,incarn,projectno;
long array initials,stdkit; integer array base;
integer projectno,type,curkitno,entries,slices,incarn;
begin
<*
scan_usercat (return, integer) 0 ok
1 project or user unknown
2 entry claims exceeded
(only for type=3)
3 slice claims exceeded
(only for type=3)
initials (call, long array) contains the user ident
projectno (call, integer) contains the project number
base (return, integer array)
catalog base for above user
type (call, integer) 1 used by login_user;
finds user and base and moves
maxclaim from usercat to
array userclaim
2 used by scope
finds user and base
3 used by newclaim to change
maxclaim in usercat
4 used by scope if scope=user and
user not running; finds free claim
5 outputs usercat
6 updates free claim at logout
curkitno (call, integer) only relevant for type=3
entries (call, integer) only relevant for type=3
slices (call, integer) only relevant for type=3
incarn (call, integer) the param is needed because
stdkit (return, long array) only set if type=1
when type is 4, incarn is not
equal to current incarn
*>
\f
boolean procedure findkitno(kitname);
long array kitname;
<* findkitno (return, boolean) true=>found, false=>not found
kitname (call, long array) contains the kitname
kitno (return, integer) current number of kit
*>
begin
for kitno:=0 step 1 until maxkit do
begin
laf:=kitno*8;
if kittable.laf(1)=kitname(1) and
kittable(kitno,3)=kitname.if6 then goto found;
end;
findkitno:=false;
if false then
found: findkitno:=true;
end findkitno;
procedure outusercat0;
begin integer field ifx1,ifx2;
integer i; integer array ia(1:2);
ifx1:=infx+2;
ifx2:=infx+4;
if zaindex=1 then write(za(1),<<zdd>,incarn);
write(za(zaindex),<:<13><10>project no.:>,<<-dddddd>,z.infx,sp,22,
<:base::>,z.ifx1,sp,1,z.ifx2,<:<13><10>:>);
ifx1:=infx+8;
ia(1):=z.ifx1 extract 12; ia(2):=z.ifx1 shift (-12);
for i:=1 step 1 until 2 do if ia(i)>=2048 then ia(i):=ia(i)-4096;
if z.ifx1<>0 then
write(za(zaindex),<:disc :>,<<-dddd>,
ia(1),ia(2),kittable(discno,4),<:<13><10>:>);
if zaindex=1 then setposition(za(1),0,0);
end outusercat0;
procedure outusercat2;
begin integer field ifx1,ifx2,ifx3;
ifx1:=inf+10;
ifx2:=inf+12;
ifx3:=inf+14;
if zaindex=1 then write(za(1),<<zdd>,incarn);
write(za(zaindex),<:<13><10>:>);
laf:=inf;
write(za(zaindex),sp,45-write(za(zaindex),z.laf),
<<-dddddd>,z.ifx1,sp,1,
z.ifx1+z.ifx2+z.ifx3-2,<:<13><10>:>);
if zaindex=1 then setposition(za(1),0,0);
end outusercat2;
procedure outusercat6;
begin integer field ifx,infx1,infx2;
integer i; integer array ia(1:4);
ifx:=inf+12; infx2:=inf+10;
infx1:=inf+14;
laf:=inf;
ia(1):=z.ifx extract 12; ia(2):=z.infx2 extract 12;
ia(3):=z.ifx shift (-12); ia(4):=z.infx2 shift (-12);
for i:=1 step 1 until 4 do if ia(i)>=2048 then ia(i):=ia(i)-4096;
if zaindex=1 then write(za(1),<<zdd>,incarn);
write(za(zaindex),sp,9-write(za(zaindex),z.laf),<<-dddd>,
ia(1),<:/:>,ia(2),sp,2,
ia(3),<:/:>,ia(4),sp,2,
z.infx1,<:<13><10>:>);
if zaindex=1 then setposition(za(1),0,0);
end outusercat6;
procedure outusercat34;
begin integer field ifx,infx2;
integer i; integer array ia(1:4);
ifx:=inf+8; infx2:=inf+6;
ia(1):=z.ifx extract 12; ia(2):=z.infx2 extract 12;
ia(3):=z.ifx shift (-12);ia(4):=z.infx2 shift (-12);
for i:=1 step 1 until 4 do if ia(i)>=2048 then ia(i):=ia(i)-4096;
if zaindex=1 then write(za(1),<<zdd>,incarn);
write(za(zaindex),<:disc :>,<<-dddd>,
ia(1),<:/:>,ia(2),sp,2,
ia(3),<:/:>,ia(4),sp,2,
kittable(discno,4),<:<13><10>:>);
if zaindex=1 then setposition(za(1),0,0);
end outusercat34;
procedure update(rectype); integer rectype;
begin
i:=z.infx; j:=i extract 12; i:=i shift (-12);
if i<-entries and entries<0 then
begin
scan_usercat:=2;
goto exit_scan_usercat;
end;
if j<-slices and slices<0 then
begin
scan_usercat:=3;
goto exit_scanusercat;
end;
z.infx:=(i+entries) shift 12 + ((j+slices) extract 12);
infx:=infx-2;
i:=z.infx; j:=i extract 12; i:=i shift (-12);
z.infx:=(i+entries) shift 12 + ((j+slices) extract 12);
setposition(z,0,k);
outrec6(z,512);
k:=savedk; inf:=savedinf;
setposition(z,0,k);
inrec6(z,512);
loop03:
inf:=inf+z.inf extract 12;
if z.inf=0 then
begin inrec6(z,512); inf:=2; k:=k+1; end;
if z.inf shift (-12)<>2<*user*> then goto loop03;
lf:=inf+4;
if z.lf<>userident(incarn,1) then goto loop03
else
begin
lf:=lf+4;
if z.lf<>userident(incarn,2) then goto loop03;
end;
loop04:
inf:=inf+z.inf extract 12;
if z.inf=0 then
begin inrec6(z,512); inf:=2; k:=k+1; end;
i:=z.inf shift (-12);
if -,(i=6 or i=34) then goto loop04;
if i=6 then
begin
laf:=inf;
findkitno(z.laf);
infx:=inf+12;
end
else
begin
kitno:=discno;
infx:=inf+8;
end;
i:=z.infx; j:=i extract 12; i:=i shift (-12);
z.infx:=(i-entries) shift 12 + ((j-slices) extract 12);
infx:=infx-2;
i:=z.infx; j:=i extract 12; i:=i shift (-12);
z.infx:=(i-entries) shift 12 + ((j-slices) extract 12);
setposition(z,0,k);
outrec6(z,512);
userclaim(incarn,kitno,1,1):=
userclaim(incarn,kitno,1,1)-entries;
userclaim(incarn,kitno,1,2):=
userclaim(incarn,kitno,1,2)-slices;
userclaim(incarn,kitno,2,1):=
userclaim(incarn,kitno,2,1)-entries;
userclaim(incarn,kitno,2,2):=
userclaim(incarn,kitno,2,2)-slices;
goto exit_scan_usercat;
end update;
integer savedk,savedinf,kitno;
integer field infx,infx1;
long array field laf; long field lf;
boolean mounted;
zone z(128,1,stderror);
open(z,4,usercat,0);
scan_usercat:=0;
k:=0;
for i:=inrec6(z,2), inrec6(z,2) while z.if2<projectno do
k:=k+1;
setposition(z,0,k);
inrec6(z,512);
inf:=2;
goto loop2a;
loop1:
<*project record*>
infx:=inf+2;
if z.infx=projectno then
begin
savedk:=k; savedinf:=inf;
if type=5 then outusercat0;
goto loop3;
end
else
if z.infx>projectno then
begin
scan_usercat:=1;
goto exit_scan_usercat;
end;
loop2:
inf:=inf+z.inf extract 12;
loop2a:
if z.inf shift (-12)=0 <*project*> then
goto loop1 else goto loop2;
loop3:
inf:=inf+z.inf extract 12;
if z.inf=0 then
begin inrec6(z,512); inf:=2; k:=k+1; end;
if z.inf shift (-12)=0<*project*> then
begin
scan_usercat:=1;
goto exit_scanusercat;
end;
if z.inf shift (-12)=6 then
begin
if type=5 then outusercat6;
if type=1 then
begin
laf:=inf;
stdkit(1):=z.laf(1);
stdkit(2):=z.laf(2);
end;
end;
if z.inf shift (-12) <> 2<*user*> then goto loop3;
if type=5 then outusercat2;
lf:=inf+4;
if type<>5 then
begin
if z.lf<>initials(1) then goto loop3
else
begin
lf:=lf+4;
if z.lf<>initials(2) then goto loop3;
end;
end;
infx:=inf+10;
base(1):=z.infx;
infx:=infx+2;
infx1:=infx+2;
base(2):=base(1)+z.infx+z.infx1-2;
if type=2 then goto exit_scan_usercat;
loop4:
inf:=inf+z.inf extract 12;
if z.inf=0 then
begin inrec6(z,512); inf:=2; k:=k+1; end;
i:=z.inf shift (-12);
if i=0<*project*> or type<>5 and i=2<*next user*> then
goto exit_scan_usercat;
mounted:=true;
if -,(i=6 or i=34) then
begin
if i=2 then outusercat2;
goto loop4;
end;
if i=6 then
begin
laf:=inf;
mounted:=findkitno(z.laf);
if type=5 then outusercat6;
infx:=inf+12;
end
else
begin
kitno:=discno;
if type=5 then outusercat34;
infx:=inf+8;
end;
if type=5 then goto loop3;
if type=3 and curkitno=kitno then update(i);
if type=6 then
begin
infx:=infx-2;
z.infx:=userclaim(incarn,kitno,2,1) shift 12 +
userclaim(incarn,kitno,2,2) extract 12;
setposition(z,0,k); outrec6(z,512);
setposition(z,0,k); inrec6(z,512);
end
else
if mounted then
begin
if type=1 or type=4 then
begin
i:=z.infx; j:=i extract 12; i:=i shift (-12);
userclaim(incarn,kitno,1,1):=i;
userclaim(incarn,kitno,1,2):=j;
infx:=infx-2;
i:=z.infx; j:=i extract 12; i:=i shift (-12);
if j>2047 then j:=j-4096; if i>2047 then i:=i-4096;
userclaim(incarn,kitno,2,1):=i;
userclaim(incarn,kitno,2,2):=j;
end;
end;
if type=4 and curkitno=kitno then goto exit_scan_usercat;
goto loop4;
exit_scan_usercat:
close(z,true);
end scan_usercat;
\f
boolean
procedure logged_in(initials,projectno,inc);
value projectno;
long array initials; integer projectno, inc;
begin
userident(maxincarn+1,1):=initials(1);
userident(maxincarn+1,2):=initials(2);
userident(maxincarn+1,3):=projectno;
inc:=0;
for inc:=inc+1 while
-,(userident(inc,1)=initials(1) and
userident(inc,2)=initials(2) and
userident(inc,3)=projectno ) do;
logged_in:=inc<>maxincarn+1;
end logged_in;
\f
procedure hardinoutput_account(userid,projectno,type,segm);
value type,segm,projectno;
long array userid;
integer type,segm,projectno;
begin integer i;
integer array ia(1:10);
integer array c(1:6);
real r,r1,r2; long l;
real array field raf;
zone z(128,1,stderror);
r1:=systime(5,0,r2);
open(z,4,comalacc,0);
monitor(42<*lookup*>,z,0,ia);
i:=ia(7)//11;
raf:=(ia(7) mod 11) * 44;
setposition(z,0,i);
if raf<>0 then
begin
inrec6(z,512);
setposition(z,0,i);
end
else
if ia(1)<i+1 then ia(1):=i+1;
outrec6(z,512);
z.raf(1):=projectno;
for j:=1,2 do
begin
l:=userid(j);
for i:=1 step 1 until 6 do
begin
c(i):=k:=l shift(-48+i*8) extract 8;
if k=0 then c(i):=32;
end;
if j=1 then
begin
z.raf(2):=real<::> add c(1) shift 12 add
c(2) shift 12 add c(3) shift 12 add c(4);
z.raf(3):=real<::> add c(5) shift 12 add
c(6) shift 12;
end
else
begin
z.raf(3):=z.raf(3) add c(1) shift 12 add c(2);
z.raf(4):=real<::> add c(3) shift 12 add c(4)
shift 12 add c(5) shift 12;
end
end;
z.raf(5):=type;
z.raf(6):=r1;
z.raf(7):=r2;
z.raf(8):=segm;
z.raf(9):=real<::>;
z.raf(10):=real<::>;
z.raf(11):=real<::>;
if raf+44>512 then
begin
for i:=12 step 1 until 19 do z.raf(i):=real<::>;
end;
close(z,true);
ia(6):=systime(7,0,0.0);
ia(7):=ia(7)+1;
ia(9):=3;
ia(10):=44;
monitor(44<*change*>,z,0,ia);
end hardinoutput_account;
\f
boolean procedure lookup_pool;
begin
getshare6(ztem,ia,1);
ia(4):=94 shift 12;
ia(8):=<:tph:> shift (-24) extract 24;
ia(9):=ia(10):=ia(11):=0;
setshare6(ztem,ia,1);
monitor(16)sendmess:(ztem,1,ia);
if monitor(18)waitansw:(ztem,1,ia)<>1 then trap(4) else
begin waitinglines:=0;
lookup_pool:=ia(1) shift (-8) extract 1 = 0;
if ia(1) shift (-8) extract 1 = 0 then
begin
waitinglines:=ia(6); inroom:=ia(7);
end;
end;
end proc lookup_pool;
\f
procedure delay;
begin
open(zhelp,2,<:clock:>,0);
getshare6(zhelp,ia,1);
ia(4):=2;
ia(5):=0; ia(6):=1000;
setshare6(zhelp,ia,1);
monitor(16)sendmess:(zhelp,1,ia);
if monitor(18)waitansw:(zhelp,1,ia)<>1 then trap(9);
close(zhelp,true);
end proc delay;
boolean procedure lookup_terminal;
begin
boolean lkterm;
getshare6(ztem,ia,1);
ia(4):=106 shift 12;
ia(6):=termproc;
setshare6(ztem,ia,1);
monitor(16)sendmess:(ztem,1,ia);
if monitor(18)waitansw:(ztem,1,ia)<>1 then trap(5) else
begin
temst(16):=ia(1) shift (-7) extract 1 = 1; <* no link *>
temst(19):=ia(1) shift (-4) extract 1 = 1; <* not mine *>
temst(21):=ia(1) shift (-2) extract 1 = 1; <* term unknown *>
lkterm:= -,(temst(16) or temst(19) or temst(21));
if -,lkterm then else
begin
linestoterm:=ia(6); termroom:=ia(7);
termno:=(ia(2) shift (-16) extract 8 - 48)*100 +
(ia(2) shift (-8) extract 8 - 48)*10 +
(ia(2) extract 8 - 48);
end;
lookup_terminal:=lkterm;
end;
end proc lookup_terminal;
\f
boolean procedure waitinlist(termno,incarn);
value termno, incarn; integer termno, incarn;
begin
integer i, j;
waitinlist:=false; i:=0;
repeat
j:=i;
i:=-terminals(j,2);
until
i=termno or i<=0;
if termno<=0 then terminals(j,2):=-incarn
else
if i<=0 then else
begin
terminals(j,2):=terminals(termno,2);
terminals(termno,2):=6;
waitinlist:=true;
end;
end proc waitinlist;
procedure clearterm;
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,termno,<:<1><1><1>:>);
getzone6(za(1),ia);
getshare6(za(1),ia,1);
ia(4):=9 shift 12 + 4;
ia(5):=ia(19)+1;
ia(6):=ia(5)+2;
setshare6(za(1),ia,1);
monitor(16,za(1),1,ia);
monitor(18,za(1),1,ia);
setposition(za(1),0,0);
end proc clearterm;
\f
boolean procedure getterm;
begin
i:=0;
repeat
lstchoosen:=lstchoosen + 1;
if lstchoosen<=maxincarn then else lstchoosen:=1;
i:=i+1;
until
terminals(lstchoosen,2)=0 or i>maxincarn;
if terminals(lstchoosen,2)=0 then
begin
termno:=lstchoosen;
getterm:=true;
end
else getterm:=false;
end proc getterm;
procedure nocore;
begin
getzone6(zhelp,ia);
ia(1):=8; <* mode=0 kind=tw *>
ia(10):=0; <* giveup mask = 0 *>
ia(13):=0; <* state=after open *>
ia(14):=ia(19); <* record base = base buffer area *>
ia(16):=0; <* record length = 0 *>
setzone6(zhelp,ia);
write(zhelp,<:***basic no core<10>:>);
setposition(zhelp,0,0);
close(zhelp,true);
end proc nocore;
\f
boolean procedure insert;
begin
if actions >= qlength then insert:=false else
begin
lastinqueue:=(lastinqueue+1) mod qlength;
executequeue(lastinqueue):=termno;
insert:=true;
actions:=actions+1;
terminals(termno,2):=terminals(termno,2) extract 1 + 8;
end;
end proc insert;
integer procedure removefirst;
begin
if actions <= 0 then removefirst:=0 else
begin
removefirst:=executequeue(firstinqueue);
firstinqueue:=(firstinqueue+1) mod qlength;
actions:=actions-1;
end;
end proc removefirst;
\f
boolean procedure anyactions;
begin
lookup_pool; <* uses ia *>
anyactions:=anyevents or waitinglines>0 or actions>0;
end;
<**>
boolean procedure searchandremove;
begin
boolean found;
found:=false; position:=firstinqueue;
if actions <= 0 then else
begin
while executequeue(position)<>termno and position<>lastinqueue
do position:= (position +1) mod qlength;
found:=executequeue(position)=termno;
end;
if found then
begin actions:=actions-1; j:= (position+1) mod qlength;
while position<>lastinqueue do
begin
executequeue(position):=executequeue(j);
position:= (position+1) mod qlength; j:= (j+1) mod qlength;
end;
lastinqueue:=if position>0 then position-1 else qlength-1;
end;
searchandremove:=found;
end proc searchandremove;
\f
procedure rdtline;
begin
setposition(za(1),0,0);
za1discconn:=attstatus:=za1timeout:=false;
i:=0;
repeat
i:=i+1;
class(i):=readchar(za(1),char(i));
until
class(i)=8 or i=3;
if class(i)=8 then trap(13);
termno:=(char(1)-48)*100+(char(2)-48)*10+(char(3)-48);
end proc rdtline;
<**>
procedure startinput;
begin
<*:if testbit1 then write(out,sp,32,<:startinput:>,nl,2);:*>
getshare6(zph,ia,1);
ia(4):=110 shift 12;
ia(5):=terminals(incarn,1);
ia(7):=1 shift 12;
setshare6(zph,ia,1);
monitor(16,zph,1,ia);
if monitor(18,zph,1,ia)<>1 then killed(incarn):=true;
end;
<**>
procedure psouterinit;
begin
poolbuffer:=0;
for i:=13 step 1 until 23 do temst(i):=false;
<* end initialization of variables in outmostblock *>
mainproc:=system(7,i,la);
<*:if testbit1 then begin
write(out,<:process name of mainconsole: :>,la,
nl,1);
setposition(out,0,0);
end;:*>
<* create pool *>
if lookup_pool then else
begin
getshare6(ztem,ia,1);
ia(4):=90 shift 12;
ia(8):=<:tph:> shift (-24) extract 24;
ia(9):=ia(10):=ia(11):=0;
setshare6(ztem,ia,1);
monitor(16)sendmess:(ztem,1,ia);
if monitor(18)waitansw:(ztem,1,ia)<>1 then trap(1) else
begin
temst(13):=ia(1) shift (-10) extract 1 = 1;
temst(17):=ia(1) shift (-6) extract 1 = 1;
if -,(temst(13) or temst(17)) then
begin
repeat monitor(20)waitmess:(ztem,poolbuffer,ia) until ia(1)<0;
end else
if temst(17) then trap(2) else trap(3);
end;
end create pool;
open(zph,0,<:tph:>,0);
open(za(1),4 shift 12 + 8,<:tph:>,-1 shift 2);
getzone6(za(1),ia);
basebuf:=ia(19);
\f
terminals(0,1):=terminals(0,2):=0;
for i:=1 step 1 until maxincarn do
begin
terminals(i,1):=(i//100+48) shift 8 add
((i mod 100)//10+48) shift 8 add
(i mod 10 + 48);
terminals(i,2):=0;
end;
lstchoosen:=actions:=firstinqueue:=mainno:=oprno:=0;
lastinqueue:=-1; attmod:=false;
if testbit3 then systime(1,0,tmbase);
end proc psouterinit;
outer_init;
psouterinit;
<*:if testbit2 then
begin
write(out,<:**statistics**:>,nl,1,
<: blocksread after initiation: :>,blocksread,nl,2);
setposition(out,0,0);
end;:*>
\f
goto examinqueue;
delayme: delay;
examinqueue:
ignorestopatt:=false;
monitor(72,ownprocess,0,owncatbase);
<*:if testbit3 then tmcpu:=systime(1,tmbase,tmtime);:*>
if incarn>0 then
begin
cpu(incarn):=cpu(incarn)+systime(1,0,r);
realtime(incarn):=realtime(incarn)+r;
lasttime(incarn):=r;
incarn:=0;
end;
<*:if testbit2 then
begin
write(out,<:**statistics**:>,nl,1,
<: blocksread after entry at examinqueue: :>,
blocksread,nl,2);
setposition(out,0,0);
end;:*>
contextmode:=3; <* write, read *>
termno:=-1; <* no events *>
myselfproc:=
system(6,buffer,la); <* any message *>
if buffer<=0 then else
begin
mess_received: <* temporary solution from wait_event *>
monitor(20)waitmess:(zhelp,buffer,ia);
for i:=2 step 1 until 8 do ia(1):=ia(1)+ia(i);
i:=ia(1);
ia(9):=if i=0 then 1 else 2;
monitor(22)sendansw:(zhelp,buffer,ia);
if i=0 then else goto examinqueue;
<*:if testbit1 then
begin
getzone6(zhelp,ia);
la(1):=(la(1) shift 24 add ia(2)) shift 24 add ia(3);
la(2):=(la(2) shift 24 add ia(4)) shift 24 add ia(5);
write(out,<:att from: :>,la,nl,2);
setposition(out,0,0);
end;:*>
termproc:=monitor(4)procdescrp:(zhelp,buffer,ia);
if lookup_terminal then
begin <* terminal already in link *>
i:=terminals(termno,2);
if i<0 or i extract 1 = 0 then
begin
if waitinlist(termno,0) then i:=6
else
if i=8 then searchandremove else;
if terminals(termno,2)=4 and linestoterm<=12 then
begin
system(5<*move core*>,termproc+16,ia);
if ia(1)<>termproc+16 then goto examinqueue;
end;
if terminals(termno,2)<9 then clearterm;
terminals(termno,2):=i+1;
<*: if testbit1 then write(out,<:stop att bit added - value: :>,
i+1,nl,1);:*>
end;
goto examinqueue;
end
<**>
else
begin <* terminal not logged in *>
if -,temst(16) then trap(10);
if getterm then terminals(termno,2):=2 else
begin
nocore;
goto examinqueue;
end;
newincarnation:=true;
if termproc=mainproc then mainno:=termno;
<*: if testbit1 then
begin
write(out,<: mainno: :>,mainno,nl,1);
setposition(out,0,0);
end;:*>
end;
end any message;
<*:if testbit1 then
begin
if termno=-1 then
write(out,sp,2,<: no message received:>,nl,1)
else
begin
case terminals(termno,2) of
begin
write(out,sp,2,<:termno: :>,termno,<: procdescrp :>,
termproc,nl,1,sp,2,<: linestoterm: :>,
linestoterm,<: termroom: :>,termroom,nl,2);
write(out,sp,2,<:termno: :>,termno,<: to bee logged in. :>,
<: procdescrp :>,termproc,nl,1,sp,2,
<: contextmode: :>,contextmode,nl,2)
end;
end;
end;:*>
<**>
if termno>=0 then else
begin <* any input *>
if -,lookup_pool then trap(12);
<*:if testbit1 then
begin
write(out,<: test for lines waitinglines: :>,waitinglines,nl,1);
setposition(out,0,0);
end;:*>
if waitinglines>0 then
begin
rdtline;
ignorestopatt:=false;
i:=terminals(termno,2);
if i>0 and i extract 1=1 then
begin <* stop att received *>
i:=0; j:=1;
while j=1 and i<3 do
begin
readchar(za(1),j);
i:=i+1;
end;
if j=1 then
begin
<*: if testbit1 then
begin
write(out,<: simulated input line received:>,nl,1,
<: terminal st. :>,terminals(termno,2),nl,1);
setposition(out,0,0);
end;:*>
if terminals(termno,2)>9 then
goto examinqueue; <* terminal waiting for *>
<* answer from primo *>
if terminals(termno,2)=5 and -, killed(termno) then
begin
incarn:=termno;
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,if incarn<>mainno then <:<13><10>* :>
else <:* :>);
setposition(za(1),0,0);
startinput;
terminals(incarn,2):=4;
incarn:=0;
goto examinqueue;
end;
end
else
begin
<*: if testbit1 then
begin
write(out,<: attention for :>,termno,<: ignored:>,nl,1);
setposition(out,0,0);
end;:*>
ignorestopatt:=true; repeatchar(za(1));
end;
end;
if za1timeout and -, killed(termno) then
begin
<*: if testbit1 then
begin
write(out,<: line with timeout status received:>,nl,1);
setposition(out,0,0);
end;:*>
incarn:=termno;
setposition(za(1),0,0);
startinput;
incarn:=0;
goto examinqueue;
end;
if za1discconn then killed(termno):=true;
<*: if testbit1 then
begin
write(out,sp,2,<:line to termno: :>,termno,nl,2);
setposition(out,0,0);
end;:*>
if terminals(termno,2)>9 then
goto examinqueue; <* terminal waiting for *>
<* answer from primo *>
waitinlist(termno,0);
end;
end any input;
<*:if testbit1 then
begin
if termno=-1 then write(out,sp,2,<: no input line:>,nl,1);
setposition(out,0,0);
end;:*>
<**>
if termno>=0 then else
begin <* any franswers *>
i:=myselfproc+14;
system(5,i,ia);
j:=ia(1); <* first buffer *>
k:=ia(2); <* last buffer *>
if j=k then <* queue empty - only spare *> else
begin <* scan queue *>
buffer:=0;
repeat
i:=monitor(24,zhelp,buffer,ia);
<*: if testbit1 then
begin
write(out,<: mess=0 answ=1: :>,i,<: bufadr: :>,
buffer,nl,1);
setposition(out,0,0);
end;:*>
if i=0 then goto mess_received;
if i=1 then
begin <* answer *>
<* search franswer *>
i:=0;
repeat
i:=i+1;
j:=terminals(i,2)-buffer;
until
j=1 or j=0 or i=maxincarn;
if j=1 or j=0 then termno:=i
else
begin
primoindex:=0;
primoia(bufs+1,1):=buffer;
for primoindex:=primoindex+1 while
buffer<>primoia(primoindex,1) do;
if primoindex=bufs+1 then goto examinqueue;
monitor(18<*wait answer*>,zprimo(primoindex),1,ia);
la(1):=primola(primoindex,1);
la(2):=primola(primoindex,2);
ia(1):=primoia(primoindex,4);
ia(2):=primoia(primoindex,5);
monitor(72<*set catbae*>,ownprocess,0,ia);
open(zhelp,0,la,0); close(zhelp,true);
message primoerror;
repeat
i:=monitor(48<*remove*>,zhelp,0,ia);
until i=0 or i=3;
primoia(primoindex,1):=0;
for i:=1 step 1 until 7 do ia(i):=-1;
ia(2):=primoia(primoindex,2);
transfer(8<*release*>,ia,7,ia,6);
la(1):=primola(primoindex,3);
la(2):=primola(primoindex,4);
hardinoutput_account(la,primoia(primoindex,3),
primoia(primoindex,7) shift (-12),primoia(primoindex,7) extract 12);
goto examinqueue;
end;
end;
<*: if testbit1 then
begin
write(out,<: answtermno: :>,termno,nl,1);
setposition(out,0,0);
end;:*>
until termno>0 or buffer=k;
if termno>0 then
terminals(termno,2):=terminals(termno,2) extract 1 + 8;
end;
end any franswers;
if termno>0 then else
begin
i:=0;
for i:=i+1 while (-,killed(i) and i<=maxincarn) do ;
if i < maxincarn + 1 then
begin
termno:=i;
if terminals(termno,2)=8 then searchandremove;
if terminals(termno,2)>9 then terminals(termno,2):=8;
if terminals(termno,2)<0 then
begin
waitinlist(termno,0);
terminals(termno,2):=8;
end;
end;
end;
<*:if testbit1 then
begin
if termno=-1 then write(out,sp,2,<: no franswers:>,nl,1);
end;:*>
<**>
incarn:=if termno<0 then removefirst else termno;
<*:if testbit1 then
begin
if incarn>0 then
write(out,sp,2,<:incarn: :>,incarn,<: terminal state: :>,
terminals(incarn,2),nl,2)
else
write(out,sp,2,<:incarn: :>,incarn,nl,2);
setposition(out,0,0);
end;:*>
if incarn=0 then
begin
if anyactions then goto examinqueue
else goto delayme;
end;
<*:if testbit3 then
begin
tmcpu:=systime(1,tmbase,tmbase)-tmcpu;
tmtime:=tmbase-tmtime;
write(out,<:**time measure**:>,nl,1,<: selection of incarnation:>,nl,1,
<: cputime: :>,<<dddd.dd>,tmcpu,nl,1,
<: realtime: :>,tmtime,nl,2);
setposition(out,0,0);
end;
if testbit2 then
begin
write(out,<:**statistics**:>,nl,1,
<: blocksread after selection of incarnation: :>,
blocksread,nl,2);
setposition(out,0,0);
end;
if testbit3 then
begin
systime(1,0,tmbase);
tmcpu:=systime(1,tmbase,tmtime);
end;:*>
used:=8000000;
usercount:=usercount+1;
for i:=1 step 1 until users_in_core do
begin
if zonestate(1,i)=incarn then
begin
zonestate(2,i):=zonestate(2,i)+1;
zno:=i;
goto runincarn;
end;
if zonestate(2,i)<used then
begin
used:=zonestate(2,i);
zno:=i;
end;
end;
for i:=1 step 1 until users_in_core do
zonestate(2,i):=zonestate(2,i)-used;
usercount:=usercount-used;
zonestate(1,zno):=incarn;
zonestate(2,zno):=usercount;
setposition(store(zno),0,(incarn-1)*segmentsuser);
swoprec6(store(zno),storesize);
runincarn:
cpu(incarn):=cpu(incarn)-systime(1,0,r);
realtime(incarn):=realtime(incarn)-r;
\f
begin <*context*>
context(incarn,maxincarn,contextmode);
boolean stop_att,running,exitexamine,boo,output,created,auto,
error_called,copy_currout,punching;
boolean field bf,bfx;
integer stdkitno,fileno, currin, currout,sys6,sys7,sys8,sys16,
runsum,mode,supermode,primoindex,savedzaindex,kitno,i,j,k,ch,cl,siz,
upi,upj,index,base1,base2,slices,cindex;
integer field this_statement, next_statement,
upiaddr,upjaddr,inf,len;
real r,r1;
real field rf,rfa;
long l,projectnumber;
long field lf;
long array field laf;
boolean array eof(-1:no_of_user_zones+1),compline(1:132);
integer array pagetabpos(-1:no_of_user_zones),
printdigits(-1:no_of_user_zones),
base(1:2),zaindextable(0:no_of_user_zones),
carr(1:30),ia(1:20);
real array printeps(-1:no_of_user_zones);
long array stdkit(1:2),la,name(1:2);
\f
procedure init_context;
begin
<* init context kc *>
restcore:=store_length shift 1-
programstart-10;
lastdata:=storelength shift 1+2;
lastprogram:=programstart;
for i:=1 step 1 until 29 do
store(zno).fcttable(i):=0;
nametable:=
pstack:=
(program_start+rest_core shift (-1)+3) shift (-1) shift 1;
pstacktop:=plevel:=0;
store(zno).lowbound:=1;
lastname:=1;
alfalock:=0;
<* slut init context kc *>
sys6:=sys7:=sys8:=sys16:=0;
currin:=1;
auto:=false;
currout:=1;
running:=scannerbackup:=stop_att:=error_called:=copy_currout:=
punching:=false;
for i:=-1 step 1 until no_of_user_zones do
begin
if i>-1 then zaindextable(i):=0;
eof(i):=false;
printdigits(i):=6;
printeps(i):='-10;
pagetabpos(i):=72 shift 8 add 14 shift 8;
end;
<*:if testbit2 then
begin
write(out,<:**statistics**:>,nl,1,
<: blocksread after init context: :>,
blocksread,nl,2);
setposition(out,0,0);
end;:*>
end init_context;
\f
procedure error(errorno); value errorno; integer errorno;
begin
sys7:=errorno;
if running and this_statement <> 0 then
sys16:=store(zno).this_statement;
error_called:=true;
end error;
procedure errorout(errorno);
value errorno; integer errorno;
begin
if currout=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
write(za(currout),<:<13><10>***basic :>,<<zddd>,errorno,sp,2);
if errorno=2 then write(za(currout),syntaxerror)
else
begin zone z(128,1,texterror);
procedure texterror(z,s,b); zone z; integer s,b;
begin
b:=512;
z.laf(1):=real<::>;
end texterror;
open(z,4,basicerror,0);
setposition(z,0,errorno//16);
laf:=(errorno mod 16)*32;
inrec6(z,512);
write(za(currout),z.laf);
close(z,true);
end;
write(za(currout),<:<13><10>:>);
if currout=1 then setposition(za(1),0,0);
error_called:=false;
end errorout;
\f
boolean procedure findkitno(kitname);
long array kitname;
<* findkitno (return, boolean) true=>found, false=>not found
kitname (call, long array) contains the kitname
kitno (return, integer) current number of kit
*>
begin
for kitno:=0 step 1 until maxkit do
begin
laf:=kitno*8;
if kittable.laf(1)=kitname(1) and
kittable(kitno,3)=kitname.if6 then goto found;
end;
findkitno:=false;
if false then
found: findkitno:=true;
end findkitno;
\f
boolean
procedure createentry(name,kitname,size,reclength);
value size,reclength; integer size,reclength;
long array name,kitname;
begin integer segm;
if -,findkitno(kitname) then
begin
i:=7;
goto exit_createentry;
end;
if size<0 then
begin
i:=8;
goto exit_createentry;
end;
if reclength<0 or reclength>512 then
begin
i:=9;
goto exit_createentry;
end;
i:=0;
segm:=if reclength=0 then size else
(size-1)//(512//reclength) + 1;
j:=userclaim(incarn,kitno,2,1);
if j<1 then i:=1;
j:=userclaim(incarn,kitno,2,2);
if j*kittable(kitno,4)<segm then i:=5;
if i<>0 then goto exit_createentry;
ia(1):=segm;
tofrom(ia.laf2,kitname,8);
ia(6):=systime(7,0,0.0);
ia(7):=if reclength=0 then 0 else size;
ia(8):=0;
ia(9):=if reclength<>0 then 3 else 0;
ia(10):=reclength;
open(zhelp,0,name,0);
close(zhelp,true);
i:=monitor(40<*create entry*>,zhelp,0,ia);
if i<>0 then goto exit_createentry;
monitor(50<*perm*>,zhelp,3,ia);
userclaim(incarn,kitno,2,1):=
userclaim(incarn,kitno,2,1) - 1;
userclaim(incarn,kitno,2,2):=
userclaim(incarn,kitno,2,2)
- (segm+kittable(kitno,4)-1)//kittable(kitno,4);
exit_createentry:
createentry:=i=0;
if i<>0 then
error(case i of (0103,0100,0105,0100,0104,0106,0107,0101,0102));
end createentry;
\f
procedure closeza(zaindex);
value zaindex; integer zaindex;
begin integer mode,base1,base2;
exitexamine:=false;
if fileno<>-1 then sys8:=fileno;
sys6:=sys6+1;
supermode:=zainf(zaindex,3) ;
mode:=supermode mod 100;
supermode:=supermode//100;
getzone6(za(zaindex),ia);
tofrom(name,ia.laf2,8);
l:=name(1);
if mode=0 or mode=2 or mode=3 or mode=11 then
begin
if mode=11 and ia(13<*zonestate*>)<>4<*after declaration*> then
begin
write(za(zaindex),false add 25<*em*>,1);
getzone6(za(zaindex),ia);
i:=ia(12<*partial*>);
i:=(if i=1 then 3 else
if i shift (-8)=1 then 2 else 1)
+ 1.5*(510 - ia(14<*recbase*>)+ia(19<*base buf*>));
write(za(zaindex),false,i);
end;
close(za(zaindex),true);
after_io;
if i<>0 then
begin
if i=1 then eof(fileno):=true;
goto exit_closeza;
end;
i:=ia(9<*segcount*>);
j:=ia(14<*recbase*>)-ia(19<*base buf*>)+ia(16<*reclength*>);
if mode=11 then
begin
j:=j+(if ia(12)=1 then 0 else 2);
if j=0 then
begin j:=512; i:=i-1; end;
end;
if ia(13<*zonestate*>)<>0<*after open*> then
begin
monitor(42<*lookup*>,za(zaindex),0,ia);
if mode<>0 then
begin
k:=ia(1);
ia(1):=ia(7):=i+1;
bf:=20; ia.bf:=false add j;
if supermode=0 then
begin
kitno:=zainf(zaindex,2);; j:=kittable(kitno,4);
k:=(k-1+j)//j;
i:=(i+j)//j;
userclaim(incarn,kitno,2,2):=
userclaim(incarn,kitno,2,2)+(k-i);
end;
end
else ia(7):=zainf(zaindex,5);
ia(6):=systime(7,0,0.0);
monitor(44<*change*>,za(zaindex),0,ia);
end;
end
else
begin
close(za(zaindex),true);
after_io;
end;
if supermode>0 then
begin
monitor(42<*lookup*>,za(zaindex),0,ia);
siz:=ia(1);
slices:=(siz-1+kittable(stdkitno,4))//kittable(stdkitno,4);
end;
if supermode>2 then monitor(48<*remove*>,za(zaindex),0,ia)
else
if supermode=1 or supermode=2 then
begin
carr(1):=carr(2):=-1;
carr.laf0(2):=projectnumber;
carr.laf0(3):=0;
for i:=7 step 1 until 20,25,30 do carr(i):=-1;
carr.laf0(5):=userident(incarn,1);
carr.laf0(6):=userident(incarn,2);
carr.laf0(11):=name(1);
carr.laf0(12):=name(2);
carr.laf2(13):=if supermode=1 then long <:lp:> else
if mode>8 then long <:tpe:> else long <:tpn:>;
carr.laf2(14):=0;
i:=transfer(2<*define*>,carr,30,carr,11);
if i<>0 then
begin
error(if i=4 then 164 else if i=6 then 165 else 166);
goto exit_closeza;
end;
if carr(1)<*reply code*> <>0 then
begin
i:=carr(1);
error(if i=3 then 167 else if i=5 then 168 else 169);
goto exit_closeza;
end;
primoindex:=0;
for primoindex:=primoindex+1 while primoia(primoindex,1)<>0 do;
if primoindex>bufs then
begin
error(170);
goto exit_closeza;
end;
<*wait and get state of transport *>
getzone6(zprimo(primoindex),ia);
i:=ia(19);
getshare6(zprimo(primoindex),ia,1);
ia(4):=7 shift 12;
ia(5):=i+2;
ia(6):=ia(5)+4;
ia(7):=ia(5);
ia(8):=ia(5)+28;
zprimo(primoindex,1):=real<::> add 6 shift 24
add 3 shift 4 add 1 shift 8 add 1;
zprimo(primoindex,2):=real<::> add carr(2) shift 24;
setshare6(zprimo(primoindex),ia,1);
primoia(primoindex,1):=
monitor(16<*send mess*>,zprimo(primoindex),1,ia);
primoia(primoindex,2):=carr(13);
primoia(primoindex,3):=userident(incarn,3);
primoia(primoindex,4):=base(1);
primoia(primoindex,5):=base(2);
primoia(primoindex,6):=slices shift 12 + stdkitno;
primoia(primoindex,7):=supermode shift 12 + siz;
primola(primoindex,1):=name(1);
primola(primoindex,2):=name(2);
primola(primoindex,3):=userident(incarn,1);
primola(primoindex,4):=userident(incarn,2);
end;
exit_closeza:
zainf(zaindex,1):=0;
end closeza;
\f
procedure login_user(initials);
long array initials;
begin
integer projectno;
long procedure conv(n); value n; integer n;
conv:=if n<10 then long <:00000:> add (n+48)
else
conv(n//10) shift 8 add (n mod 10 + 48);
if locked then
begin
error(0000);
i:=0;
goto exit_login_user;
end;
projectno:=if initials(4)>999999 then -1 else initials(4);
if logged_in(initials,projectno,i) then
begin
i:=1;
goto exit_login_user;
end;
userident(incarn,1):=initials(1);
userident(incarn,2):=initials(2);
userident(incarn,3):=projectno;
projectnumber:=conv(projectno);
for i:=0 step 1 until maxkit do
for j:=1,2 do
for k:=1,2 do userclaim(incarn,i,j,k):=0;
stdkit(1):=ystdkit(1);
stdkit(2):=ystdkit(2);
if scan_usercat(initials,projectno,base,1,0,0,0,incarn,stdkit)<>0 then
begin
userident(incarn,1):=0;
i:=2;
goto exit_login_user;
end;
monitor(72<*set catbase*>,ownprocess,0,base);
link(3);
system(5,termproc,ia);
ia(1):=1 shift 23 + 4 shift 12 + 8;
ia(6):=systime(7,0,0.0);
for i:=7 step 1 until 10 do ia(i):=0;
open(zhelp,0,<:term:>,0); close(zhelp,true);
if monitor(40<*create*>,zhelp,0,ia) <> 0
then monitor(44<*change*>,zhelp,0,ia);
cpu(incarn):=-systime(1,0,logintime(incarn));
realtime(incarn):=-logintime(incarn);
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,<:logged in at :>);
writedate(za(1),systime(5,0,r),r,9);
write(za(1),<:<13><10>:>);
setposition(za(1),0,0);
if hotnews then
begin zone z(128,1,texterror);
open(z,4,<:basichotnew:>,0);
write(za(1),<<zdd>,incarn,<:<13><10>hotnews:<13><10>:>);
for i:=readchar(z,j) while j<>25 do
begin
if j=10 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,<:<13>:>);
end;
write(za(1),false add j,1);
end;
write(za(1),<:<13><10>:>);
setposition(za(1),0,0);
close(z,true);
end hotnews;
if -,findkitno(stdkit) then
begin
userident(incarn,1):=0;
i:=3;
goto exit_login_user;
end
else
stdkitno:=kitno;
i:=0;
exit_login_user:
if i<>0 then
error(66+i);
end login_user;
\f
integer procedure openinternal(name,zaindex,type,mode);
long array name;
integer type,zaindex,mode;
<*
openinternal (integer, return) 0 ok
1 illegal name
2 device area exists
3 area does not exist
4 no entries
5 no slices
6 no zones
7 area not created
8 hard error in input device
9 work area for input too small
name (long array, call) contains the name
zaindex (integer, return) index in zone array za
type (integer, call) 1 name must be lpt
2 name must be ptr or
existing area
3 name must be ptp or area
4 name must be ptp/lpt or area
5 name must be ptr/cdr/mcdr/term or
existing area
mode (integer, call) 1 binary input
3 binary output
9 text input
11 text output
type 1 called with mode 11 from runl,conl,batch,search,claim,scanclaim
type 2 called with mode 1 from load
type 3 called with mode 3 from save
type 4 called with mode 11 from list
type 5 called with mode 9 from enter
*>
begin
boolean indevice, outdevice;
exitexamine:=false;
zaindex:=0;
l:=name(1);
indevice:=outdevice:=false;
open(zhelp,0,name,0); close(zhelp,true);
if type=1 then
begin
if l=long<:lpt:> then outdevice:=true
else
begin
i:=1;
goto exit_openinternal;
end;
end
else
if type=2 then
begin
if l=long<:ptr:> then indevice:=true
else
if l=long<:lpt:> or l=long<:ptp:> or
l=long<:cdr:> or l=long<:mcdr:> then
begin
i:=1;
goto exit_openinternal;
end
else
begin
i:=monitor(42<*lookup*>,zhelp,0,ia);
if i<>0 then
begin
i:=3;
goto exit_openinternal;
end;
if ia(9)<>4 then
begin
i:=8;
goto exit_openinternal;
end;
end
end
else
if type=3 then
begin
if l=long<:ptp:> then outdevice:=true
else
if l=long<:ptr:> or l=long<:lpt:> or
l=long<:cdr:> or l=long<:mcdr:> then
begin
i:=1;
goto exit_openinternal;
end
end
else
if type=4 then
begin
if l=long<:ptp:> or l=long<:lpt:> then outdevice:=true
else
if l=long<:ptr:> or l=long<:cdr:> or l=long<:mcdr:> then
begin
i:=1;
goto exit_openinternal;
end
end
else
begin <*type=5 *>
if l=long<:ptr:> or l=long<:cdr:> or l=long<:mcdr:> or
l=long<:term:> then
indevice:=true
else
if l=long<:lpt:> or l=long<:ptp:> then
begin
i:=1;
goto exit_openinternal;
end
else
begin
i:=monitor(42<*lookup*>,zhelp,0,ia);
if i<>0 then
begin
i:=3;
goto exit_openinternal;
end;
end;
end;
supermode:=if l=long<:lpt:> then 1 else
if l=long<:ptp:> then 2 else
if l=long<:ptr:> then 3 else
if l=long<:cdr:> then 4 else
if l=long<:mcdr:> then 5 else
if l=long<:term:> then 6 else 0;
zaindex:=1;
for zaindex:=zaindex+1 while zainf(zaindex,1)<>0 do;
if zaindex>no_of_zones then
begin
i:=6;
goto exit_openinternal;
end;
zainf(zaindex,1):=incarn;
zainf(zaindex,2):=stdkitno;
zainf(zaindex,3):=mode+100*supermode ;
zainf(zaindex,4):=zainf(zaindex,5):=0;
open(za(zaindex),4,name,if mode=3 or mode=11 then 1 shift 18 else 0);
i:=monitor(76<*head and tail*>,za(zaindex),0,ia);
if i=0 then
begin
if ia(2)<>base(1) or ia(3)<>base(2) then i:=1; if supermode>=4 then i:=2;
end;
if i=0 and (outdevice or indevice) then
begin
i:=2;
goto exit_openinternal;
end;
if i<2 and ia(8)<0 then
begin
if i=0 or i=1 and (mode=1 or mode=9) then
begin
i:=9;
goto exit_openinternal;
end;
end;
if i=0 then
begin
findkitno(ia.laf16);
zainf(zaindex,2):=kitno;
end;
if i<>0 and (mode=3 or mode=11 or indevice) then
begin <*create*>
if -,(outdevice or indevice or mode=3 or mode=11) then
goto exit_openinternal;
if -,(outdevice or indevice) then
begin
ia(1):=createsize;
tofrom(ia.laf2,stdkit,8);
ia(6):=systime(7,0,0.0);
ia(7):=ia(8):=ia(10):=0;
ia(9):=if type=3 then 4 else
if mode<9 then 2 else 1;
k:=j:=0;
i:=userclaim(incarn,stdkitno,2,2);
if i*kittable(stdkitno,4)>createsize then
i:=(createsize+kittable(stdkitno,4)-1)//kittable(stdkitno,4);
k:=i;
ia(1):=i*kittable(stdkitno,4);
if i<1 then
begin
i:=5;
goto exit_openinternal;
end;
j:=userclaim(incarn,stdkitno,2,1);
if j<1 then
begin
i:=4;
goto exit_openinternal;
end;
userclaim(incarn,stdkitno,2,1):=
userclaim(incarn,stdkitno,2,1) - 1;
userclaim(incarn,stdkitno,2,2):=
userclaim(incarn,stdkitno,2,2) - k;
j:=1;
i:=monitor(40<*create*>,za(zaindex),0,ia)
+monitor(50<* perm *>,za(zaindex),3,ia);
if i<>0 then
begin
userclaim(incarn,stdkitno,2,1):=
userclaim(incarn,stdkitno,2,1)+ j;
userclaim(incarn,stdkitno,2,2):=
userclaim(incarn,stdkitno,2,2)+k;
i:=7;
goto exit_openinternal;
end;
goto exit_openinternal;
end;
l:=name(1);
i:=createwrk(name,(if type=3 then 4 else
if mode<9 then 2 else 1)
+100*supermode);
if i<>0 then
begin
i:=if i=1 then 4 else if i=2 then 5 else 7;
goto exit_openinternal;
end;
close(za(zaindex),false);
open(za(zaindex),4,name,if mode=3 or mode=11 then 1 shift 18 else 0);
if indevice then
begin
close(za(zaindex),true);
open(za(zaindex),0,<:primo:>,0);
carr(1):=carr(2):=-1;
carr.laf0(2):=projectnumber;
carr.laf0(3):=0;
for i:=7 step 1 until 20,25,30 do carr(i):=-1;
carr.laf0(5):=userident(incarn,1);
carr.laf0(6):=userident(incarn,2);
carr.laf2(13):=name(1);
carr.laf2(14):=name(2);
carr.laf0(11):=if l=long <:ptr:> and mode>2 then long <:tre:> else
if l=long <:ptr:> then long <:trn:> else
if l=long <:term:> then l else l;
carr.laf0(12):=0;
i:=transfer(2<*define*>,carr,30,carr,11);
if i<>0 then
begin
i:=if i=4 then 11 else if i=6 then 12 else 13;
goto exit_open_internal;
end;
if carr(1)<*reply code*> <>0 then
begin
i:=carr(1);
i:=if i=3 then 14 else if i=5 then 16 else 15;
goto exit_open_internal;
end;
outrec6(za(zaindex),24);
getzone6(za(zaindex),ia);
i:=ia(19);
<*wait and get state of transport*>
getshare6(za(zaindex),ia,1);
ia(4):=7 shift 12;
ia(5):=i+2;
ia(6):=ia(5)+4;
ia(7):=ia(5);
ia(8):=ia(5)+28;
za(zaindex,1):=real<::> add 6 shift 24
add 3 shift 4 add 1 shift 8 add 1;
za(zaindex,2):=real<::> add carr(2) shift 24;
setshare6(za(zaindex),ia,1);
terminals(incarn,2):=
monitor(16<*send mess*>,za(zaindex),1,ia);
exitexamine:=true;
savedzaindex:=zaindex;
end;
end
else
if (type=3 or type=4) and i=0 then
begin
monitor(42<*lookup*>,zhelp,0,ia);
j:=kittable(kitno,4);
ia(1):=(ia(1)+j-1)//j*j;
ia(9):=if type=3 then 4 else 1;
monitor(44<*change*>,zhelp,0,ia);
end;
i:=0;
exit_openinternal:
openinternal:=i;
if i=0 and -,indevice then
begin
if monitor(52<*create area process*>,za(zaindex),0,ia)>0 then
begin
i:=10;
goto exit_openinternal;
end;
end;
if i<>0 then
begin
if zaindex<>0 then
begin
close(za(zaindex),true);
zainf(zaindex,1):=0;
end;
error(case i of(147,148,149,150,151,152,100,161,162,163,
164,165,166,167,168,169));
end;
end openinternal;
\f
procedure open_after_exit(name);
long array name;
begin
zaindex:=savedzaindex;
monitor(18<*wait answer*>,za(zaindex),1,ia);
close(za(zaindex),true); open(za(zaindex),4,name,0);
for i:=3 step 1 until 9 do carr(i):=-1;
i:=transfer(6<*getstate*>,carr,9,carr,26);
if i<>0 then
begin
i:=if i=4 then 164 else if i=6 then 165 else 166;
goto removewrk;
end;
if carr(1)<*reply code*> <>0 then
begin
i:=carr(1);
i:=if i=3 then 167 else if i=5 then 169 else 168;
removewrk: ;
message primoerror;
repeat until 0=monitor(48<*remove*>,za(zaindex),0,ia);
goto exit_open_after_exit;
end;
j:=carr(23);
i:=(carr(23)+767)//768;
j:=j mod 768;
j:=(j+2)//3*2;
transfer(8<*release*>,carr,7,carr,6);
monitor(42<*lookup*>,za(zaindex),0,ia);
ia(1):=ia(7):=i;
ia(10):=j;
message primoerror;
repeat until 0=monitor(44<*change*>,za(zaindex),0,ia);
la(1):=userident(incarn,1); la(2):=userident(incarn,2);
hardinoutput_account(la,userident(incarn,3) extract 24,supermode,i);
i:=0;
exit_open_after_exit:
if i<>0 then error(i);
end open_after_exit;
\f
boolean procedure before_io(iotype);
integer iotype;
begin
iotype:=iotype mod 100;
before_io:=true;
if fileno=-1 then goto exit_before_io;
zaindex:=zaindextable(fileno);
if zaindex=0 then
begin
error(0129);
before_io:=false;
goto exit_before_io;
end;
i:=zainf(zaindex,3) mod 100;
if iotype<>i and -,(iotype=4 and i=0) then
begin
error(0130);
before_io:=false;
end;
exit_before_io:
end before_io;
procedure after_io;
begin
i:=zablprocerror;
zablprocerror:=0;
if i<>0 and zaindex<>1 then
error(case i of (0134,0140,0141,0173));
end after_io;
\f
boolean procedure testline(page,pos,linepos);
integer page,pos,linepos;
begin
testline:=true;
if page>0 then
begin
if pos>page-linepos then
begin
linepos:=0;
write(za(zaindex),<:<13><10>:>);
if zaindex=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
end;
if pos>page then
begin
linepos:=pos:=0;
error(0133);
testline:=false;
end;
end;
end testline;
\f
boolean procedure print_number(number,page,pos,linepos);
value number;
real number;
integer page,pos,linepos;
begin
long n,max,front;
integer digits, d,exppart,frontd,backd,firstlet,signum,start;
real absnumber,layout,min,r;
printnumber:=true;
digits:=printdigits(fileno);
start:=1;
max:=10**digits;
min:=1/max;
number:=number+0.5*min*number;
firstlet:=0<*d*>;
signum:=1<*-*>;
absnumber:=abs number;
exppart:=0;
if absnumber<printeps(fileno) then
begin
d:=1; frontd:=1;
backd:=0;
number:=0;
goto finis_layout;
end;
if absnumber+0.5>=max then
begin
if absnumber<'14 then
begin
n:=absnumber;
exppart:=-1;
for exppart:=exppart+1 while n>=10 do n:=n//10;
n:=10**exppart;
number:=number/n;
absnumber:=abs number;
end
else
begin
r:=absnumber;
exppart:=-1;
for exppart:=exppart+1 while r>=10 do r:=r/10;
r:=10**exppart;
number:=number/r;
absnumber:=abs number;
end;
end
else
if absnumber<0.1 then
begin
exppart:=1;
for exppart:=exppart-1 while absnumber<1 do
absnumber:=absnumber*10;
number:=sign(number)*absnumber;
end;
front:=n:=absnumber-0.5;
if n=0 then
begin
start:=if number<0 then 2 else 3;
front:=n:=absnumber*max;
number:=absnumber:=n;
frontd:=digits;
while n//10*10=n do
begin
n:=n//10;
frontd:=frontd-1;
end;
number:=absnumber:=n;
backd:=0; d:=frontd;
firstlet:=2<*z*>;
signum:=0<*no sign*>;
goto finis_layout;
end
else
begin
frontd:=-1;
for frontd:=frontd+1 while n>0 do n:=n//10;
end;
if frontd=digits then
begin
backd:=0; d:=frontd;
goto finis_layout;
end;
n:=(absnumber-front)*10**(digits-frontd);
if n=0 then backd:=0 else
begin
backd:=digits-frontd+1;
for backd:=backd-1 while n mod 10 = 0 do n:=n//10;
end;
d:=frontd+backd;
finis_layout:
layout:=real<::> add 1 shift 29 add
d shift 4 add
frontd shift 4 add
backd shift 2 add
firstlet shift 2 add
signum shift (2+2+2);
pos:=(if start=1 then 0 else 2) +
d + 1 + signum +
(if backd<>0 then 1 else 0) +
(if exppart=0 then 0 else 4);
if -,testline(page,pos,linepos) then
begin printnumber:=false; goto exit_printnumber; end;
write(za(zaindex),case start of (<::>,<:-.:>,<: .:>));
write(za(zaindex),string layout,number);
if exppart<>0 then write(za(zaindex),<:E:>,<<+zd>,exppart);
write(za(zaindex),sp,1);
exit_printnumber:
end print_number;
\f
boolean procedure getdevorname(devno,name,auxname);
integer devno;
real array name,auxname;
begin
integer chainentry, firstdeviceinnametable, device;
integer array coreword(1:1), bspointers(1:3), chainhead(1:17);
real field docname1, docname2, auxcatname1, auxcatname2;
integer field documentnametableaddress;
docname1 := 20; docname2 := docname1 + 4;
documentnametableaddress := docname1 + 6;
auxcatname1:= 10; auxcatname2:= 14;
<* get nametable address of first,top chain *>
system(5, 92, bspointers);
<* get nametable address of first device *>
system(5, 74, coreword);
firstdeviceinnametable := coreword(1);
<* scan all chaintables to find the rigth one *>
for chainentry := bspointers(3) - 2 <* last chaintable *>
step - 2 <* size of nametable entry *>
until bspointers(1) <* first chaintable *>
do
begin
<* get chaintable address *>
system(5, chainentry, coreword);
<* get chainhead from chaintable *>
system(5, coreword(1) - 34, chainhead);
<* compute devicenumber of discdrive *>
device := (chainhead.documentnametableaddress
- firstdeviceinnametable
) // 2;
if chainhead.docname1 shift (-24) extract 24 <> 0 and device=devno
then
goto chaintablefound;
<* this chaintable was not the rigth one *>
end;
<* no chaintables was found good enough *>
getdevorname := true;
goto exit_getdevorname;
chaintablefound:
devno := device;
name(1) := chainhead.docname1;
name(2) := chainhead.docname2;
auxname(1):= chainhead.auxcatname1;
auxname(2):= chainhead.auxcatname2;
kitno:=(chainentry-bspointers(1))/2;
getdevorname := false;
exit_getdevorname:
end procedure getdevorname;
\f
\f
integer procedure createwrk(name,m); long array name; integer m;
begin integer i;
i:=(createsize+kittable(stdkitno,4)-1)//kittable(stdkitno,4);
createwrk:=0;
open(zhelp,0,<::>,0); close(zhelp,true);
ia(1):=i*kittable(stdkitno,4);
tofrom(ia.laf2,stdkit,8);
ia(6):=systime(7,0,0.0);
ia(7):=ia(8):=ia(10):=0;
ia(9):=m;
if monitor(40<*create*>,zhelp,0,ia)<>0 then
begin
createwrk:=3;
goto exitcreatewrk;
end;
if monitor(50<*perm*>,zhelp,3,ia)<>0 then
begin
monitor(48<*remove*>,zhelp,0,ia);
createwrk:=3;
goto exit_createwrk;
end;
getzone6(zhelp,ia);
name(1):=ia.laf2(1);
name(2):=ia.laf2(2);
slices:=i;
exit_createwrk:
end createwrk;
\f
boolean scannerbackup;
integer symbol,prevsymbol,linenumber1,linenumber2;
integer alfalock,lastname,commandcode,restcore,lastdata;
integer lastprogram,pstacktop,plevel;
integer list1,list2; <* work for list *>
integer field listf; <* work for list *>
integer array identifier(1:6); <* insymbol,getline *>
integer array field nametable,pstack;
boolean field pc,obc; <* programcounter
outputbytecounter (getline) *>
integer array subscripts(1:8);
integer field data_line; boolean field data_byte; <* read *>
\f
procedure search_for_code_after_then(p);
boolean field p;
<* the procedure scans the statement pointed
to by p until a then is found (1033).
at return, p points to the code following
then.
*>
begin
boolean done;
done:=false;
repeat
case store(zno).p shift (-9) extract 3+1 of
begin
<* 0: *> ;
<* 1: *> ;
<* 2: *> done:=store(zno).p extract 12=1033; <* then *>
<* 3: *> case store(zno).p extract 9 of
begin
<* string *> begin
p:=p+1;
p:=p+store(zno).p extract 12
end;
<* real *> p:=(p+5) shift (-1) shift 1;
<* integer *> p:=p+1;
<* false *> ;
<* true *>
end;
<* 4: *> ;
<* 5: *> ;
<* 6: *> ;
<* 7: *>
end;
p:=p+1
until done
end;
\f
procedure list_a_line(pointer,z);
value pointer; integer pointer;
zone z;
begin
integer field linenumber;
real field rf;
long array name(1:2);
integer code,i,chr,linenumber_count;
boolean done,on_statement,mat_statement;
boolean field p,ch;
integer array s(1:20),triple(1:50,1:3),cs(1:40);
integer sp,tp,csp;
\f
procedure print_item(code);
value code; integer code;
begin
boolean parentesis;
integer i,j,ch,class,fct;
boolean field bf;
real field rf;
long array name(1:2);
parentesis:=code>4095;
fct:=code extract 9;
class:=code shift (-9) extract 3;
if parentesis then write(z,<:(:>);
if class<>0 then
begin
case class-1 of
begin
<* 2: *> write(z,<: FILE:>);
<* 3: *> begin <* constants *>
if fct<=3 then csp:=csp+2;
case fct of
begin
<* 1: *> begin <* string *>
write(z,<:":>);
bf:=cs(csp);
j:=cs(csp-1);
for i:=1 step 1 until j do
begin
ch:=store(zno).bf extract 12;
if ch<32 or ch=34 or ch>=127 then
write(z,<:<60>:>,<<d>,ch,<:>:>)
else
outchar(z,ch);
bf:=bf+1
end;
write(z,<:":>)
end; <* string *>
<* 2: *> begin <* real *>
rf:=csp shift 1;
print_max_prec(z,cs.rf)
end;
<* 3: *> begin <* integer *>
write(z,<<d>,cs(csp))
end;
<* 4: *> write(z,<:FALSE:>);
<* 5: *> write(z,<:TRUE:>)
end; <* case fct of *>
end; <* constants *>
\f
<* 4: *> begin <* variables *>
i:=(fct-1)*10+1+nametable;
for bf:=i step 1 until i+7 do
if store(zno).bf extract 7<>0 then
outchar(z,store(zno).bf extract 7);
bf:=i;
if store(zno).bf shift (-8) extract 1=1 then
outchar(z,36<* dollar *>)
end; <* variables *>
<* 5: *> begin <* userdefined functions *>
write(z,<:FN:>,false add (fct+64),1)
end;
<* 6: *> begin <* standard functions *>
search_name(name,code) get name :(2);
write(z,name)
end;
<* 7: *> begin <* operators *>
if fct<=39 then write(z,case fct of(
<::>,<:NOT :>,<:-:>,<:,:>,<:^:>,
<:*:>,<:/:>,<: DIV :>,<: MOD :>,<:+:>,
<:-:>,<:<>:>,<:<60>:>,<:<=:>,<:=:>,
<:>=:>,<:>:>,<:<>:>,<:<60>:>,<:<=:>,
<:=:>,<:>=:>,<:>:>,<: AND :>,<: OR :>,
<:=:>,<:=:>,<::>,<::>,<::>,
<::>,<::>,<::>,<::>,<::>,
<::>,<::>,<::>,<:,:>))
end <* operators *>
end <* case class of *>
end; <* if class<>0 *>
if parentesis then write(z,<:):>)
end; <* print_item *>
\f
\f
procedure print_expression;
begin
integer class,fct;
real field rf,rf1;
procedure traverse(tp);
value tp; integer tp;
begin
boolean parentesis;
parentesis:=triple(tp,1)>4095;
if parentesis then write(z,<:(:>);
if triple(tp,2)<0 then
traverse(-triple(tp,2))
else
print_item(triple(tp,2));
print_item(triple(tp,1) extract 12);
if triple(tp,3)<0 then
traverse(-triple(tp,3))
else
print_item(triple(tp,3));
if parentesis then write(z,<:):>)
end; <* traverse *>
\f
p:=p-1; sp:=csp:=tp:=0;
rep:
code:=store(zno).p extract 12;
class:=code shift (-9);
fct:=code extract 9;
if class<3 and code<>1028 then goto exit_pr;
case class-1 of
begin
<* 2 *> goto variable; <* file *>
<* 3 *> begin <* constants *>
if fct<=3 then
begin
csp:=csp+2;
case fct of
begin
begin <* string *>
p:=p+1;
cs(csp):=p+1;
cs(csp-1):=store(zno).p extract 12;
p:=p+cs(csp-1);
end;
begin <* real *>
rf:=(p+5) shift (-1) shift 1;
p:=rf;
rf1:=csp shift 1;
cs.rf1:=store(zno).rf;
end;
begin <* integer *>
p:=p+1;
cs(csp):=store(zno).p extract 12;
end
end <* case fct of *>
end; <* if fct<=3 *>
sp:=sp+1;
s(sp):=code
end; <* constants *>
<* 4 *> begin
variable: sp:=sp+1;
s(sp):=code;
end;
<* 5 *> begin
case_5: tp:=tp+1;
triple(tp,1):=code;
triple(tp,2):=0;
triple(tp,3):=s(sp);
s(sp):=-tp;
end;
<* 6 *> goto case_5;
<* 7 *> begin
if fct>=1 and fct<=3 then goto case_5;
if fct>=4 and fct<=27 or fct=39 then
case_7_1: begin
tp:=tp+1;
triple(tp,1):=code;
triple(tp,2):=s(sp-1);
triple(tp,3):=s(sp);
sp:=sp-1;
s(sp):=-tp;
end
else
if fct=28 or fct=30 then
begin
if s(sp)<0 then
begin
i:=-s(sp);
triple(i,1):=triple(i,1)+1 shift 12;
end
else
s(sp):=s(sp)+1 shift 12;
end;
if fct=30 then
begin
code:=0;
fct:=0;
goto case_7_1;
end;
if code=3615 then
begin
p:=p+1;
goto exit_pr;
end;
end; <* case 7 *>
end; <* case class *>
p:=p+1;
goto rep;
exit_pr: csp:=0; if s(sp)<0 then traverse(-s(sp))
else print_item(s(sp))
end; <* print expression *>
\f
done:=on_statement:=mat_statement:=false;
p:=pointer;
repeat
code:=store(zno).p extract 12;
p:=p+1;
case code shift (-9)+1 of
begin
<* class0 *> if code=0 then write(z,<:variable:>)
else write(z,<:CON:>);
<* class1 *> begin
search_name(name,code) get name:(2);
write(z,name);
if code=557 <* on *> then
begin
linenumber_count:=store(zno).p extract 12;
p:=p+1;
on_statement:=linenumber_count<>0
end;
if code=540 then mat_statement:=true;
if code>=518 and code<=522 or
code>=526 and code<=530 then
begin
while store(zno).p extract 12<>0 do
begin
outchar(z,store(zno).p extract 12);
p:=p+1
end;
write(z,<:<13><10>:>);
done:=true
end
else
if code<>543 and code<>550 and code<>553 then
outchar(z,32);
if code=552 <* def *> then
begin
write(z,<:FN:>);
outchar(z,store(zno).p extract 9 +64);
p:=p+1;
write(z,<:(:>,store(zno).p,1,<:):>);
store(zno).nametable(1):=store(zno).p extract 12 shift 12;
p:=p+1
end;
\f
if code=555 or code=556 or code=548 then
begin <* gosub, goto and restore *>
linenumber:=(p+2) shift (-1) shift 1;
if -, (store(zno).linenumber=0 and code=548) then
write(z,<<zddd>,store(zno).linenumber);
if on_statement then
begin
linenumber_count:=linenumber_count-1;
while linenumber_count>0 do
begin
linenumber:=linenumber+2;
write(z,<:,:>,<<zddd>,store(zno).linenumber);
linenumber_count:=linenumber_count-1
end
end;
p:=linenumber+1
end
end;
<* class2 *> begin
if code=1028 then print_expression else
write(z,case code extract 9 of (
<: DO:>,
<:ERR:>,
<:ESC:>,
<: FILE:>,
<:IDN:>,
<:INV:>,
<: OF:>,
<: STEP :>,
<: THEN :>,
<: TO :>,
<:TRN:>,
<:USING :>,
<:ZER:>,
<:;:>,
<:,:>,
<:<13><10>:>,
<:MATER :>,
<:USER :>,
<:SOLVE :>,
<:(:>,
<:):>,
<:=:>));
if code=1044 and mat_statement then
begin
code:=store(zno).p extract 12;
p:=p+1;
print_expression;
end;
done:=code=1040
end;
\f
<* class3 *> print_expression;
<* class4 *> if mat_statement then print_item(code)
else print_expression;
<* class5 *> print_expression;
<* class6 *> print_expression;
<* class7 *> if mat_statement then print_item(code)
else print_expression
end; <* case class of *>
until done
end; <* list a line *>
\f
procedure movetables;
<* moves the nametable and the program stack
into the middle of the free core area in store(zno).
the procedure is called whenever the data segment
or the program segment colides when the segment is
expanded.
*>
begin
integer tofield,fromfield,count;
tofield:=
1+(lastprogram+restcore shift (-1))shift(-1)shift 1;
fromfield:=1+pstack-pstacktop shift 1;
count:=pstacktop shift 1 + lastname*10;
if testbit28 then
write(out,<:bmove::>,<<__ddddd>,tofield,
fromfield,count,restcore,nl,1);
pstack:=nametable:=nametable+(tofield-fromfield);
basicmove(store(zno),tofield,fromfield,count);
end;
\f
boolean procedure allocate(var,claim);
value var,claim;
integer var,claim;
<* this procedure allocates claim halfwords
in the data segment to the variable var, and stores
the address of the first word as an integer field in
the variable name table.
*>
begin
integer err,i;
real field rf;
err:=0;
if claim>restcore then
err:=1
else
begin
i:=(claim+1) shift (-1) shift 1;
restcore:=restcore-i;
lastdata:=lastdata-i;
if nametable+lastname*10>=lastdata then
movetables;
store(zno).nametable(var extract 9*5):=
lastdata-storelength shift 1;
rf:=lastdata+2; store(zno).rf:=0.0;
end;
allocate:=err=0;
if err<>0 then error(case err of
(0023))
end;
\f
boolean procedure packname(name,text);
value text; real text;
long array name;
<* the procedure packs a basic string into a normal
rc 8000 string (3 bytes per word). capital letters are
converted into small letters.
an error message is output if the length of the string
is greater then 11 or is 0.
*>
begin
integer i,length,err,j,k,ch;
boolean field address;
err:=0; name(2):=0;
i:=text shift (-24) extract 24;
length:=text extract 24;
if length>11 or length=0 then
err:=1
else
if length=-1 then
begin
if i>=65 and i<=93 then i:=i+32;
name(1):=extend i shift 40
end
else
begin
j:=1; k:=0;
for address:=i step 1 until i+length-1 do
begin
ch:=store(zno).address extract 7;
if ch>=65 and ch<=93 then ch:=ch+32;
name(j):=name(j) shift 8 add ch;
k:=k+1;
if k=6 then j:=2
end;
k:=k mod 6;
if k<>0 then name(j):=name(j) shift (8*(6-k))
end;
packname:=err=0;
if err<>0 then error(case err of
(0018))
end;
\f
real procedure comparestring(s1,s2,operator);
value s1,s2,operator;
real s1,s2;
integer operator;
begin
boolean field a1,a2;
integer l1,l2,minl,compare,i,j;
l1:=s1 extract 24;
if l1=-1 then
begin
l1:=1;
store(zno).editarea(1):=s1 shift (-24) extract 24;
a1:=2
end
else
a1:=s1 shift (-24) extract 24;
l2:=s2 extract 24;
if l2=-1 then
begin
l2:=1;
store(zno).editarea(2):=s2 shift (-24) extract 24;
a2:=4
end
else
a2:=s2 shift (-24) extract 24;
minl:=if l1<l2 then l1
else l2;
\f
compare:=0;
if alfalock=0 then
begin
while minl>0 and compare=0 do
begin
compare:=store(zno).a1 extract 12-
store(zno).a2 extract 12;
a1:=a1+1; a2:=a2+1;
minl:=minl-1
end
end else
while minl>0 and compare=0 do
begin
i:=store(zno).a1 extract 12; j:=store(zno).a2 extract 12;
if i>=97 and i<=125 then i:=i-32;
if j>=97 and j<=125 then j:=j-32;
compare:=i-j;
a1:=a1+1; a2:=a2+1;
minl:=minl-1
end;
if compare=0 then compare:=l1-l2;
comparestring:=if (case operator of(
<* <> *> compare<>0,
<* < *> compare< 0,
<* <= *> compare<=0,
<* = *> compare= 0,
<* >= *> compare>=0,
<* > *> compare> 0))
then 1.0
else 0.0
end;
\f
boolean procedure readreal(z,r);
zone z;
real r;
begin
integer ch,i,e,charclass;
long a;
real y;
boolean s,ss,ok;
trap(overflow);
trapmode:=1 shift 7;
repeat
charclass:=readchar(z,ch); k:=k+1;
if copy_currout then copy_char(ch);
until ch<>32;
if ch=45 <* - *> then
begin
s:=true;
charclass:=readchar(z,ch); k:=k+1;
if copy_currout then copy_char(ch);
end
else
begin
s:=false;
if ch=43 <* + *> then
begin
charclass:=readchar(z,ch); k:=k+1;
if copy_currout then copy_char(ch)
end
end;
a:=0; e:=0; ok:=charclass=2;
while charclass=2 do
begin
if a<extend (-1) shift (-13)//5 then
a:=a*10+ch-48
else
e:=e+1;
charclass:=readchar(z,ch); k:=k+1;
if copy_currout then copy_char(ch);
end;
if ch=46 <* . *> then
begin
charclass:=readchar(z,ch); k:=k+1;
if copy_currout then copy_char(ch);
ok:=charclass=2 or ok;
while charclass=2 do
begin
if a<extend (-1) shift (-13)//5 then
begin
a:=a*10+ch-48;
e:=e-1
end;
charclass:=readchar(z,ch); k:=k+1;
if copy_currout then copy_char(ch)
end
end;
\f
if ch=69 or ch=101 <* e,E *> then
begin
i:=0;
charclass:=readchar(z,ch); k:=k+1;
if copy_currout then copy_char(ch);
if ch=45 <* - *> then
begin
ss:=true;
charclass:=readchar(z,ch); k:=k+1;
if copy_currout then copy_char(ch)
end
else
begin
ss:=false;
if ch=43 <* + *> then
begin
charclass:=readchar(z,ch); k:=k+1;
if copy_currout then copy_char(ch);
end
end;
if charclass<>2 then
ok:=false
else
while charclass=2 do
begin
if i<extend (-1) shift (-13)//5 then
i:=i*10+ch-48;
charclass:=readchar(z,ch); k:=k+1;
if copy_currout then copy_char(ch)
end;
e:=if ss then e-i
else e+i
end;
repeatchar(z); k:=k-1;
cindex:=cindex-1;
if e<-616 then
begin
a:=0;
e:=0
end;
y:=if a>=extend (-1) shift (-13) then
((a+1) shift (-1))*2.0
else
a;
if s then y:=-y;
if e<0 then r:=y/10**(-e) else
if e<>0 then r:=y*10**e else
r:=y;
readreal:=ok;
if false then
begin
overflow: error(16)
end
end;
\f
procedure search_name(name,code,fct);
value fct;
long array name;
integer code,fct;
begin
\f
case fct of
begin
<* search name *>
begin
i:=1; j:=maxnames shift (-1)+1;
repeat
k:=(i+j) shift (-1);
if name(1)<=names(k shift 1-1) then
j:=k-1;
if name(1)>=names(k shift 1-1) then
i:=k+1
until i>j;
code:=names(k shift 1) extract 12;
if -, (i-1>j and name(2)=names(k shift 1)-code)
then code:=0
end;
<* get name *>
begin
i:=0;
for i:=i+2 while names(i)
extract 12<>code do;
name(1):=names(i-1);
name(2):=names(i)-code
end
end; <* case *>
end; <* procedure search_name *>
\f
boolean procedure insymbol(z);
zone z;
<* gets the next symbol from the file described
by z. the value found will be placed in the context
variable symbol, and possibly in identifier.
the following special codes are delivered:
2048: numeric variable, the name will be in identifier.
2049: string variable, -- '' -- .
0000: number.
2560: user function.
*>
begin
boolean field character;
integer class,ch,i,j,err,spaces;
long array name(1:2);
err:=0; spaces:=10;
if scannerbackup then
symbol:=prevsymbol
else
begin
for class:=readchar(z,ch) while ch=32 or
ch<32 and class=7 do
if copy_currout then copy_char(ch);
if copy_currout then copy_char(ch);
case class of
begin
<* 1: *> ;
<* 2: *> begin
repeatchar(z);
cindex:=cindex-1;
symbol:=0 <* number *>
end;
<* 3: *> symbol:=if ch=43 then 3594 <* + *>
else 3595 <* - *>;
<* 4: *> begin
repeatchar(z);
cindex:=cindex-1;
symbol:=0 <* number *>
end;
<* 5: *> err:=1;
\f
<* 6: *> begin <* letter *>
for i:=1 step 1 until 6 do identifier(i):=0;
character:=0; name(1):=name(2):=0;
j:=1;
repeat
if ch>96 then ch:=ch-32;
character:=character+1;
identifier.character:=false add ch;
name(j):=name(j) shift 8 add ch;
if character=6 then j:=2;
class:=readchar(z,ch);
if copy_currout then copy_char(ch);
until class<>6 and class<>2 or character=11;
i:=character mod 6;
if i<>0 then name(j):=name(j) shift (8*(6-i));
if character=11 then
err:=2
else
if character=3 and name(1) shift (-32)=
long <:FN:> shift (-32) then
begin
repeatchar(z);
cindex:=cindex-1;
symbol:=2560;
identifier(1):=name(1) shift (-24)
extract 8 shift 12;
identifier(2):=0
end
else
begin
if testbit24 then
begin
i:=1;
spaces:=spaces-
write(out,string name(increase(i)))
end;
searchname(name,i,1);
if i=0 then
begin
if character>8 then
err:=2
else
if ch=36 <* dollar *> then
begin
symbol:=2049; <* string name *>
identifier(1):=identifier(1) add
(1 shift 20)
end
else
begin
repeatchar(z);
cindex:=cindex-1;
symbol:=2048 <* variable *>
end
end
else
begin
repeatchar(z);
cindex:=cindex-1;
symbol:=i
end
end
end; <* letter *>
\f
<* 7: *> begin
if ch=34 then
symbol:=1537 <* string literal *>
else
if ch=40 then
symbol:=1044 <* ( *>
else
if ch=41 then
symbol:=1045 <* ) *>
else
if ch=42 then
symbol:=3590 <* * *>
else
if ch=44 then
symbol:=1039 <* , *>
else
if ch=47 then
symbol:=3591 <* / *>
else
if ch=59 then
symbol:=1038 <* ; *>
else
if ch=94 then
symbol:=3589 <* ** *>
else
if ch>62 or ch<60 then
err:=1
else
\f
begin
readchar(z,i);
if copy_currout then copy_char(ch);
case ch-59 of
begin
<* 1: *> if i=61 then
symbol:=3598 <* <= *>
else
if i=62 then
symbol:=3596 <* <> *>
else begin repeatchar(z);
cindex:=cindex-1;
symbol:=3597 <* < *>
end;
<* 2: *> if i=60 then
symbol:=3598 <* =< *>
else
if i=62 then
symbol:=3600 <* => *>
else begin repeatchar(z);
cindex:=cindex-1;
symbol:=3599 <* = *>
end;
<* 3: *> if i=60 then
symbol:=3596 <* >< *>
else
if i=61 then
symbol:=3600 <* >= *>
else begin repeatchar(z);
cindex:=cindex-1;
symbol:=3601 <* > *>
end
end
end
end; <* 7 *>
<* 8: *> symbol:=1040 <* eos *>
end; <* case *>
if testbit24 then
begin
write(out,sp,spaces,<:.:>,<<zddd>,symbol,<:.:>,nl,1);
setposition(out,0,0)
end
end; <* if scanner backup *>
scannerbackup:=false;
prevsymbol:=symbol;
insymbol:=err=0;
if err<>0 then error(case err of
(0001,0011))
end; <* procedure insymbol *>
\f
integer procedure expression(result1,result2);
real result1,result2;
begin
boolean load,numeric;
integer i,j,k,n,subs,count,first,second,sp,sp1,
code,class,fct,from,size,maxlen;
long l1,l2;
real x;
integer array s(1:99),subscount(1:20);
boolean field b,straddrs;
integer field inf,descriptor;
real field rf,rf1,rf2,address;
integer array field iaf;
sp:=sp1:=0; expression:=-2; <* assume error *>
code:=store(zno).pc extract 12;
if code shift (-9)<3 and code<>1028 <* file *> then
begin
expression:=-1; <* no expression *>
goto exit_expression;
end;
trap(oflow);
\f
rep:
code:=store(zno).pc extract 12;
class:=code shift (-9);
fct:=code extract 9;
case class+1 of
begin
<* 0: *> goto exit_with_expression;
<* 1: *> goto exit_with_expression;
<* 2: *> goto if code=1028 then variable else exit_with_expression;
<* 3: *> begin <* constants *>
if sp=99 then goto too_complicated;
rf1:=(sp+2) shift 1;
case fct of
begin
<* 1: *> begin <* string literal *>
s(sp+1):=pc+2; <* address *>
pc:=pc+1;
s(sp+2):=i:=store(zno).pc extract 12;
pc:=pc+i;
s(sp+3):=4; <* string *>
end;
<* 2: *> begin <* real constant *>
rf:=pc:=(pc+5) shift (-1) shift 1;
s.rf1:=store(zno).rf;
s(sp+3):=1; <* real *>
end;
<* 3: *> begin <* integer constant *>
pc:=pc+1;
s.rf1:=store(zno).pc extract 12;
s(sp+3):=1; <* real *>
end;
<* 4: *> begin <* false *>
s.rf1:=0.0;
s(sp+3):=2; <* boolean *>
end;
<* 5: *> begin <* true *>
s.rf1:=1.0;
s(sp+3):=2; <* boolean *>
end
end; <* case *>
sp:=sp+3;
end; <* constants *>
\f
<* 4: *> begin <* variables *>
if sp=99 then goto too_complicated;
iaf:=(fct-1)*10;
s(sp+1):=store(zno).nametable.iaf(1) shift (-20);
variable: s(sp+2):=code;
s(sp+3):=5; <* variable *>
sp:=sp+3;
end;
<* 5: *> begin <* user defined functions *>
if sp=99 then goto too_complicated;
i:=store(zno).fcttable(fct);
if i=0 then
begin
error(0032);
goto exit_expression;
end;
s(sp+1):=pc;
s(sp+2):=store(zno).nametable(5);
s(sp+3):=6; <* exit user function information *>
store(zno).nametable(5):=(sp-1) shift 1;
sp:=sp+3;
pc:=i+5;
end; <* user defined functions *>
\f
<* 6: *> begin <* standard functions *>
i:=subscount(sp1);
sp1:=sp1-1;
if i>2 or i=2 and fct<>12 then
begin
error(0034);
goto exit_expression;
end;
sp:=sp-i*3+3;
rf1:=(sp+2) shift 1;
rf2:=rf1-6;
case fct+1 of
begin
<* 0: *> s.rf2:=abs s.rf2;
<* 1: *> s.rf2:=arctan(s.rf2);
<* 2: *> s.rf2:=cos(s.rf2);
<* 3: *> s.rf2:=store(zno).determinant;
<* 4: *> s.rf2:=if eof(entier s.rf2) then 1.0 else 0;
<* 5: *> begin
if s.rf2>1000 then
begin
error(0034);
goto exit_expression;
end;
s.rf2:=exp(s.rf2);
end;
<* 6: *> begin <* int *>
l1:=s.rf2-0.5;
s.rf2:=l1;
end;
<* 7: *> begin
if s.rf2<=0 then
begin
error(0034);
goto exit_expression;
end;
s.rf2:=ln(s.rf2);
end;
<* 8: *> s.rf2:=random(store(zno).rnd);
<* 9: *> s.rf2:=sign(s.rf2);
<* 10: *> s.rf2:=sin(s.rf2);
<* 11: *> begin
if s.rf2<0 then
begin
error(0034);
goto exit_expression;
end;
s.rf2:=sqrt(s.rf2);
end;
\f
<* 12: *> begin <* sys *>
j:=entier s.rf2;
if j<0 or j>21 then
begin
error(0034);
goto exit_expression;
end;
case j+1 of
begin
<* 0: *> begin
systime(5,0,x);
j:=x;
s.rf2:=60*60*(j//10000)+
60*((j//100) mod 100)+
j mod 100;
end;
<* 1: *> s.rf2:=round systime(5,0,0.0) mod 100;
<* 2: *> s.rf2:=round systime(5,0,0.0)//100 mod 100;
<* 3: *> s.rf2:=round systime(5,0,0.0)//10000;
<* 4: *> s.rf2:=cpu(incarn)+systime(1,0,x);
<* 5: *> begin
systime(1,logintime(incarn),x);
systime(4,x,s.rf2);
end;
<* 6: *> s.rf2:=sys6;
<* 7: *> s.rf2:=sys7;
<* 8: *> s.rf2:=sys8;
<* 9: *> begin
i:=if i=1 then -1 else entier s.rf1;
if i<-1 or i>no_of_userzones then
begin
error(0027);
goto exit_expression;
end;
s.rf2:=pagetabpos(i) shift (-16);
end;
\f
<* 10: *> begin
i:=if i=1 then -1 else entier s.rf1;
if i<-1 or i>no_of_userzones then
begin
error(0027);
goto exit_expression;
end;
s.rf2:=pagetabpos(i) shift (-8) extract 8;
end;
<* 11: *> begin
systime(5,0,x);
s.rf2:=round x//10000;
end;
<* 12: *> begin
systime(5,0,x);
s.rf2:=round x//100 mod 100;
end;
<* 13: *> begin
systime(5,0,x);
s.rf2:=round x mod 100;
end;
<* 14: *> s.rf2:=sys14;
<* 15: *> s.rf2:=sys15;
<* 16: *> s.rf2:=sys16;
<* 17: *> s.rf2:=systime(5,0,0.0);
<* 18: *> systime(5,0,s.rf2);
<* 19: *> begin
i:=if i=1 then 0 else entier s.rf1;
week_and_day(i,j,k);
s.rf2:=k;
end;
<* 20: *> begin
i:=if i=1 then 0 else entier s.rf1;
week_and_day(i,j,k);
s.rf2:=j;
end;
<* 21: *> begin
i:=if i=1 then -1 else entier s.rf1;
if i<-1 or i>no_of_userzones then
begin
error(0027);
goto exit_expression;
end;
s.rf2:=printdigits(i);
end
end <* case j of *>
end; <* sys *>
\f
<* 13: *> begin <* tan *>
x:=cos(s.rf2);
s.rf2:=if x=0 then '600
else sin(s.rf2)/x;
end;
<* 14..28: *> ;;;;;;;;;;;;;;; <* 15 *>
<* 29: *> begin <* chr *>
s(sp-2):=entier s.rf2 extract 7;
s(sp-1):=-1; <* for compare_string *>
s(sp):=3; <* char *>
end;
<* 30: *> <* ord *>
if s(sp)=3 then s.rf2:=s(sp-2)
else
begin
b:=s(sp-2);
s.rf2:=store(zno).b extract 12;
end;
<* 31: *> <* len *>
s.rf2:=if s(sp)=3 then 1.0 else s(sp-1)
end; <* case fct of *>
if fct<>29 then s(sp):=1;
if fct=4 then s(sp):=2; <* eof, boolean *>
end; <* standard functions *>
\f
<* 7: *> begin <* operators *>
rf1:=(sp-1) shift 1;
rf2:=rf1-6;
case fct of
begin
<* 1: *> ; <* dummy, used in list *>
<* 2: *> s.rf1:=if s.rf1<>0 then 0 else 1;
<* 3: *> s.rf1:=-s.rf1;
<* 4: *> ; <* string concatenator *>
<* 5: *> begin <* ** *>
i:=entier s.rf1;
if i=s.rf1 then s.rf2:=s.rf2**i
else if s.rf2>0 then
s.rf2:=s.rf2**s.rf1
else
begin
error(0034);
goto exit_expression;
end;
end;
<* 6: *> s.rf2:=s.rf2*s.rf1;
<* 7: *> s.rf2:=s.rf2/s.rf1;
<* 8: *> begin <* div *>
l2:=s.rf2-0.5;
l1:=s.rf1-0.5;
s.rf2:=l2//l1;
end;
<* 9: *> begin
l2:=s.rf2-0.5;
l1:=s.rf1-0.5;
s.rf2:=l2 mod l1;
end;
<* 10: *> s.rf2:=s.rf2+s.rf1;
<* 11: *> s.rf2:=s.rf2-s.rf1;
<* 12: *> s.rf2:=if s.rf2<>s.rf1 then 1 else 0;
<* 13: *> s.rf2:=if s.rf2< s.rf1 then 1 else 0;
<* 14: *> s.rf2:=if s.rf2<=s.rf1 then 1 else 0;
<* 15: *> s.rf2:=if s.rf2= s.rf1 then 1 else 0;
<* 16: *> s.rf2:=if s.rf2>=s.rf1 then 1 else 0;
<* 17: *> s.rf2:=if s.rf2> s.rf1 then 1 else 0;
<* 18: *> s.rf2:=comparestring(s.rf2,s.rf1,1);
<* 19: *> s.rf2:=comparestring(s.rf2,s.rf1,2);
<* 20: *> s.rf2:=comparestring(s.rf2,s.rf1,3);
<* 21: *> s.rf2:=comparestring(s.rf2,s.rf1,4);
<* 22: *> s.rf2:=comparestring(s.rf2,s.rf1,5);
<* 23: *> s.rf2:=comparestring(s.rf2,s.rf1,6);
\f
<* 24: *> s.rf2:=if s.rf2<>0 and s.rf1<>0 then 1 else 0;
<* 25: *> s.rf2:=if s.rf2<>0 or s.rf1<>0 then 1 else 0;
<* 26: *> begin <* assign, numeric *>
rf:=s(sp-5);
store(zno).rf:=s.rf1;
expression:=0;
pc:=pc+1;
goto exit_expression;
end;
<* 27: *> begin <* assign, string *>
descriptor:=descriptor+2; <* addres of curr len *>
i:=0;
while s(sp)<>5 do
begin
i:=i+1;
sp:=sp-3;
end;
sp:=sp+3;
for j:=1 step 1 until i do
begin
if maxlen>0 then
begin
if s(sp)=3 then <* char *>
begin
maxlen:=maxlen-1;
store(zno).straddrs:=false add s(sp-2);
straddrs:=straddrs+1;
end else
begin <* string *>
from:=s(sp-2);
count:=if maxlen>s(sp-1) then s(sp-1)
else maxlen;
basicmove(store(zno),straddrs,from,count);
maxlen:=maxlen-count;
end;
end; <* if maxlen>0 *>
sp:=sp+3;
end; <* for j *>
if maxlen=0 then <* string filled up *>
begin
if straddrs>descriptor+store(zno).descriptor+1
then store(zno).descriptor:=straddrs-descriptor-1;
end else
store(zno).descriptor:=straddrs-descriptor-1;
expression:=0;
pc:=pc+1;
goto exit_expression;
end;
\f
<* 28: *> ; <* ), blind used in list *>
<* 29: *> begin <* (. *>
if sp1=20 then goto too_complicated;
sp1:=sp1+1;
subscount(sp1):=1;
end;
<* 30: *> begin <* .), generate subscripts *>
if subscount(sp1)>8 then
begin
error(0031);
goto exit_expression;
end;
for i:=subscount(sp1) step -1 until 1 do
begin
subscripts(i):=entier s.rf1;
rf1:=rf1-6;
end;
sp:=sp-3*subscount(sp1);
end;
<* 31: *> begin <* exit with subscripts *>
result2:=subscount(sp1);
expression:=1;
result1:=s(sp-1);
pc:=pc+1;
goto exit_expression;
end;
<* 32: *> begin <* exit with address *>
if numeric then
begin
expression:=1;
result1:=real extend 0 add s(sp-2)
end
else
begin
expression:=2;
result1:=real extend straddrs shift 24
add descriptor;
result2:=real extend maxlen shift 24 add
((if second<store(zno).iaf(1) then second
else store(zno).iaf(1))-first);
end;
pc:=pc+1;
goto exit_expression;
end;
\f
<* 33: *> begin <* load value, simple real *>
inf:=s(sp-1) extract 9 * 10;
rf:=store(zno).nametable.inf;
if rf=-1 then
begin
error(0017);
goto exit_expression;
end;
if s(sp-2)<>0 then <* array and no index *>
begin
error(0031);
goto exit_expression;
end;
if rf>0 then <* dummy variable *>
s.rf1:=s.rf
else
begin
rf:=rf+storelength shift 1+2;
s.rf1:=store(zno).rf;
end;
s(sp):=1; <* real *>
end;
<* 34: *> begin <* load value, real array *>
load:=true;
get_adr1: inf:=s(sp-1) extract 9 * 10;
iaf:=store(zno).nametable.inf+storelength shift 1+2;
n:=s(sp-2) shift (-1);
if n=0 then <* simple real with index *>
begin
error(0064);
goto exit_expression;
end;
if subscount(sp1)<>n then
begin
index_err: error(0031);
goto exit_expression;
end;
sp1:=sp1-1;
size:=store(zno).iaf(store(zno).iaf(0)+1);
subs:=address:=subscripts(1)-store(zno).lowbound;
if subs<0 or subs>=store(zno).iaf(1) then
goto index_err;
for j:=2 step 1 until n do
begin
subs:=subscripts(j)-store(zno).lowbound;
if subs<0 or subs>=store(zno).iaf(j) then
goto index_err;
address:=address*store(zno).iaf(j)+subs;
end;
address:=address*size;
address:=address+store(zno).iaf(0) shift 1+6+iaf;
if load then
begin
s.rf1:=store(zno).address; s(sp):=1
end else s(sp-2):=address;
end; <* load value, real array *>
\f
<* 35: *> begin <* load value, string *>
load:=true;
get_adr2: b:=pc-1;
if store(zno).b extract 12<>3614 <* (. *> then
begin
sp1:=sp1+1;
subscount(sp1):=0;
end;
n:=s(sp-2) shift (-1);
inf:=s(sp-1) extract 9 * 10;
iaf:=store(zno).nametable.inf;
if iaf=-1 then <* undeclared *>
begin
error(0038);
goto exit_expression;
end;
i:=subscount(sp1);
sp1:=sp1-1;
if i<n or i>n+2 then goto index_err;
address:=0;
iaf:=iaf+store_length shift 1+2;
if n>0 then
begin
address:=subs:=subscripts(1)-store(zno).lowbound;
size:=store(zno).iaf(store(zno).iaf(0)+1);
if subs<0 or subs>=store(zno).iaf(1) then
goto index_err;
for j:=2 step 1 until n do
begin
subs:=subscripts(j)-store(zno).lowbound;
if subs<0 or subs>=store(zno).iaf(j) then
goto index_err;
address:=address*store(zno).iaf(j)+subs;
end;
address:=address*size;
end;
\f
address:=address+iaf+store(zno).iaf(0) shift 1+4;
iaf:=address;
first:=if i>n then subscripts(n+1)-1
else 0;
second:=if i=n+2 then subscripts(n+2) else
if i=n then store(zno).iaf(0) else first+1;
if first >= store(zno).iaf(0) or
first > store(zno).iaf(1) or
first < 0 or
second> store(zno).iaf(0) or
second<= first then
goto index_err;
if load then
begin
s(sp-2):=address+first+3;
s(sp-1):=(if second<store(zno).iaf(1) then second
else store(zno).iaf(1))-first;
s(sp):=4; <* string *>
end
else
begin
straddrs:=address+first+3;
descriptor:=address;
maxlen:=second-first;
end;
end; <* load value, string *>
<* 36: *> begin <* get address, simple real *>
inf:=s(sp-1) extract 9 * 10 - 8;
if store(zno).nametable.inf shift (-21) <> 0 then
begin
error(0031);
goto exit_expression;
end;
inf:=inf+8;
rf:=store(zno).nametable.inf;
if rf=-1 then <* no core allocated *>
begin
if -, allocate(s(sp-1),4) then
goto exit_expression;
rf:=store(zno).nametable.inf;
end;
s(sp-2):=rf+store_length shift 1 + 2;
numeric:=true;
end;
\f
<* 37: *> begin <* get address, real array *>
numeric:=true; load:=false;
goto get_adr1;
end;
<* 38: *> begin <* get address, string *>
numeric:=load:=false;
goto get_adr2;
end;
<* 39: *> subscount(sp1):=subscount(sp1)+1
end; <* case fct of *>
if fct>=5 and fct<=26 then sp:=sp-3;
if fct=2 or fct>=12 and fct<=25 then s(sp):=2
else if fct<=25 and fct<>4 then s(sp):=1;
end <* operators *>
end; <* case class of *>
pc:=pc+1;
goto rep;
exit_with_expression:
if (if sp<6 then false else s(sp-3)=6) then
begin <* exit user function *>
store(zno).nametable(5):=s(sp-4);
pc:=s(sp-5)+1;
sp:=sp-6;
s(sp):=s(sp+6); s(sp-1):=s(sp+5); s(sp-2):=s(sp+4);
goto rep;
end;
expression:=s(sp);
rf:=(sp-1) shift 1;
result1:=s.rf;
if false then oflow: error(0016);
if false then too_complicated: error(0029);
exit_expression:
end; <* expression *>
\f
integer procedure getline(z);
zone z;
begin
boolean match,pop,popop,not_found;
boolean field bf,onbf;
integer field intf;
integer next,stp,osp,sp,i,j,k,linenumber,action,node,ch,err;
integer array ops(1:30),s(1:100),b(1:4);
integer array field iaf;
real field rf;
real x;
cindex:=1;
stp:=1; osp:=sp:=0; obc:=editarea+4; err:=0;
store(zno).editarea(1):=store(zno).editarea(2):=0; getline:=5;
store(zno).name_table(1):=2; <* dummy name *>
try: if -, insymbol(z) then
goto line_end;
try1: next:=syntaxtable(stp);
case next shift (-12)+1 of
begin
<* 0: *> match:=symbol=next extract 12;
<* 1: *> begin
sp:=sp+1;
if sp>100 then
begin
err:=5;
goto line_end
end;
s(sp):=stp;
stp:=next extract 12;
goto try1
end;
<* 2: *> case next extract 12 of
begin
<* 1: *> if auto and stp=1 then
begin
match:=scannerbackup:=true;
if linenumber1>9999 then
begin
err:=1;
scannerbackup:=auto:=false;
goto lineend
end;
linenumber:=linenumber1
end
else
if symbol=0 then
begin
match:=true;
linenumber:=0;
while readchar(z,ch)=2 do
begin
if copy_currout then copy_char(ch);
linenumber:=linenumber*10+ch-48;
end;
repeatchar(z);
<* deleted *>
if linenumber=0 or linenumber>9999 then
begin
err:=1;
goto line_end
end
end
else
match:=false;
<* 2: *> match:=symbol<>0 and symbol shift (-9)=0;
<* 3: *> match:=symbol>=3596 and symbol<=3601;
<* 4: *> match:=symbol=3594 or symbol=3595;
<* 5: *> match:=symbol>=3590 and symbol<=3593;
<* 6: *> match:=symbol>=3072 and symbol<=3100
end
end;
\f
match_or_not:
i:=if match then syntaxtable(stp+1)
else syntaxtable(stp+2);
action:=i extract 12;
<* if testbit(25) then
begin
if action<>0 or match then
write(out,<:node: :>,<<zddd>,stp,<: action: :>,
action,<: match: :>,if match then <:true:>
else <:false:>,
nl,1);
setposition(out,0,0)
end;
*>
node:=i shift (-12);
if node=0 then node:=stp+3;
stp:=node;
if action=0 then goto end_case;
\f
case action of
begin
ac1: store(zno).editarea(1):=linenumber;
ac2: begin
if obc>132 then goto too_much;
store(zno).obc:=false add symbol;
obc:=obc+1
end;
ac3: begin
symbol:=544; <* print *>
goto ac2
end;
ac4: begin
if auto then
getline:=1
else
begin
linenumber1:=store(zno).editarea(1);
linenumber2:=linenumber1;
getline:=if linenumber1=0 then 1
else 2;
end;
goto line_end
end;
ac5: begin
if obc>132 then goto too_much;
store(zno).obc:=false add symbol;
obc:=obc+1;
getline:=if store(zno).editarea(1)=0 then 3
else 4;
goto line_end
end;
ac6: begin
err:=2;
goto line_end
end;
ac7: begin
intf:=(obc+2) shift (-1) shift 1;
if intf>132 then goto too_much;
store(zno).intf:=linenumber;
obc:=intf+1
end;
ac8: begin
if obc>132 then goto too_much;
store(zno).obc:=false add 1033; <* then *>
obc:=obc+1
end;
ac9: begin
if obc>132 then goto too_much;
store(zno).obc:=false add 556; <* goto *>
obc:=obc+1;
goto ac7
end;
\f
ac10: begin <* look for variable *>
i:=lastname*10;
iaf:=-10; not_found:=true;
for iaf:=iaf+10 while iaf<i and not_found do
not_found:=
store(zno).nametable.iaf(1) extract 21<>identifier(1)
or store(zno).nametable.iaf(2)<>identifier(2)
or store(zno).nametable.iaf(3)<>identifier(3)
or store(zno).nametable.iaf(4)<>identifier(4);
if iaf>5110 then
begin
ac10a: err:=3; <* too many names *>
goto line_end
end;
if not_found then <* extend nametable *>
begin
if restcore<10 then goto ac10a;
restcore:=restcore-10;
if nametable+iaf+10>=lastdata then
move_tables;
lastname:=lastname+1;
for i:=1 step 1 until 4 do
store(zno).nametable.iaf(i):=identifier(i);
store(zno).nametable.iaf(5):=-1
end
else iaf:=iaf-10;
symbol:=iaf//10+2049;
goto ac2
end;
ac11: begin <* dummy variable *>
symbol:=identifier(1) shift (-12);
for i:=1 step 1 until 4 do
store(zno).nametable(i):=identifier(i);
goto ac2
end;
ac12: begin <* on met *>
if store(zno).editarea(1)=0 then
begin
err:=4;
goto line_end
end;
if obc>132 then goto too_much;
store(zno).obc:=false add symbol;
obc:=onbf:=obc+1;
symbol:=0;
goto ac2
end;
ac13: begin
store(zno).obc:=false add 1537;
obc:=obc+1;
store(zno).obc:=false add 0;
obc:=obc+1;
store(zno).obc:=false add 1040 <* eos *>
end;
\f
ac14: begin
pop:=popop:=false;
ac14a: if -, readreal(z,x) then
begin
err:=2;
goto line_end
end;
if x>=0 and x<=4095 and entier x=x then
begin
if obc>131 then goto too_much;
store(zno).obc:=false add 1539; <* integer constant *>
obc:=obc+1;
store(zno).obc:=false add entier x;
obc:=obc+1
end
else
begin
if obc>128 then goto too_much;
store(zno).obc:=false add 1538; <* real constant *>
rf:=(obc+5) shift (-1) shift 1;
store(zno).rf:=x;
obc:=rf+1
end;
if pop then goto ac23;
if popop then goto ac52;
end;
ac15: begin <* remark *>
if store(zno).editarea(1)=0 then
begin
err:=4;
goto line_end
end;
if obc>132 then goto too_much;
store(zno).obc:=false add symbol;
obc:=obc+1;
while readchar(z,ch)<>8 do
begin
if copy_currout then copy_char(ch);
if obc>131 then goto too_much;
store(zno).obc:=false add ch;
obc:=obc+1
end;
store(zno).obc:=false add 0;
obc:=obc+1;
getline:=4;
goto line_end
end;
ac16: begin
if store(zno).editarea(1)=0 then
begin
err:=4;
goto line_end
end;
goto ac2
end;
ac17: begin
linenumber:=0;
goto ac7
end;
ac18: begin
symbol:=3587; <* monadic - *>
goto ac50
end;
\f
ac19: begin <* read and store string *>
pop:=false;
ac19a: if obc>132 then goto too_much;
store(zno).obc:=false add symbol;
obc:=obc+1;
i:=obc; <* length *>
obc:=obc+1;
for j:=readchar(z,ch) while j<>8 and ch<>34 do
begin
if obc>132 then goto too_much;
if copy_currout then copy_char(ch);
if ch=60 <* < *> then
begin
j:=k:=0;
while readchar(z,ch)=2 and j<=3 do
begin
if copy_currout then copy_char(ch);
j:=j+1;
b(j):=ch; k:=k*10+ch-48
end;
if j>=1 and j<=3 and ch=62 and k<256 then
store(zno).obc:=false add k
else
begin
if obc+j>132 then goto too_much;
store(zno).obc:=false add 60;
for k:=1 step 1 until j do
begin
obc:=obc+1;
store(zno).obc:=false add b(k)
end;
repeatchar(z);
end
end
else
store(zno).obc:=false add ch;
obc:=obc+1
end; <* while *>
if copy_currout then copy_char(ch);
if ch<>34 then
begin
repeatchar(z);
cindex:=cindex-1
end;
bf:=i;
store(zno).bf:=false add (obc-i-1);
store(zno).obc:=false add 1040; <* eos *>
if pop then goto ac23
end;
ac20: begin <* store name of userfunction *>
symbol:=2560+identifier(1) shift (-12) extract 5;
goto ac2
end;
ac21: begin <* store <get addr> stack := *>
if obc>132 then goto too_much;
store(zno).obc:=false add 3620;
obc:=obc+1;
symbol:=3610;
goto ac50;
end;
ac22: begin
symbol:=3613; <* (. *>
goto ac2
end;
ac23: begin
match:=true;
ac23a: stp:=s(sp);
sp:=sp-1;
goto match_or_not
end;
ac24: begin
match:=false;
goto ac23a
end;
ac25: begin
pop:=true;
popop:=false;
goto ac14a;
end;
ac26: begin <* stack user function name *>
symbol:=2560+identifier(1) shift (-12) extract 5;
goto ac50;
end;
ac27: begin
symbol:=3623; <* subscript , *>
goto ac50
end;
ac28: begin
symbol:=3614; <* .) *>
goto ac45
end;
ac29: begin
scannerbackup:=true;
goto ac23
end;
ac30: begin <* store keyboard command *>
commandcode:=symbol
end;
ac31: begin
if obc>132 then goto too_much;
store(zno).obc:=false add 1040; <* eos *>
getline:=6; <* command *>
goto line_end
end;
ac32: linenumber1:=0;
ac33: linenumber2:=if linenumber1=0 then 9999
else linenumber1;
ac34: linenumber1:=10;
ac35: linenumber1:=linenumber;
ac36: linenumber2:=linenumber;
\f
ac37: begin <* increase on_count *>
store(zno).onbf:=store(zno).onbf add 1;
goto ac7
end;
ac38: ;
ac39: begin
bf:=obc-1;
store(zno).bf:=false add (store(zno).bf extract 12+3);
symbol:=3616;
goto ac2;
end;
ac40: begin
rf:=(obc+5) shift (-1) shift 1;
if rf>132 then goto too_much;
readreal(z,store(zno).rf);
obc:=rf+1
end;
ac41: ;
ac42: begin
pop:=true;
goto ac19a
end;
ac43: begin
if obc>132 then goto too_much;
store(zno).obc:=false add 539; <* let *>
obc:=obc+1
end;
ac44: begin
if obc>132 then goto too_much;
store(zno).obc:=false add 556; <* goto *>
obc:=obc+1;
goto ac37
end;
ac45: begin
if obc>132 then goto too_much;
store(zno).obc:=false add symbol;
obc:=obc+1;
goto ac23
end;
ac46: begin
symbol:=3612;
goto ac2;
end;
ac47: begin
if store(zno).editarea(1)=0 or auto then goto ac6;
linenumber1:=9999
end;
ac48: begin
getline:=2; <* delete lines *>
goto line_end
end;
ac49: begin <* scratch *>
end;
ac50: begin <* stack operator *>
osp:=osp+1;
if osp>30 then
begin
err:=5;
goto line_end;
end;
ops(osp):=symbol;
end;
ac51: begin <* unstack *>
symbol:=ops(osp); osp:=osp-1;
goto ac45;
end;
ac52: begin <* unstack *>
if obc>132 then goto too_much;
store(zno).obc:=false add ops(osp); osp:=osp-1;
obc:=obc+1;
end;
ac53: begin
symbol:=symbol+6;
goto ac50;
end;
ac54: begin <* stack := numeric *>
symbol:=3610;
goto ac50;
end;
ac55: begin <* stack := string *>
symbol:=3611;
goto ac50;
end;
ac56: begin <* replace load with get *>
bf:=obc-1;
store(zno).bf:=false add (store(zno).bf extract 12+3);
end;
ac57: begin <* store = not operator *>
symbol:=1046;
goto ac2;
end;
ac58: begin
symbol:=3588; <* string concat *>
goto ac50;
end;
ac59: begin
popop:=true;
pop:=false;
goto ac14a;
end;
ac60: begin
symbol:=3617;
goto ac2;
end;
ac61: begin
symbol:=3618;
goto ac2;
end;
ac62: begin
symbol:=3619;
goto ac2;
end;
ac63: begin
symbol:=3615;
goto ac2;
end;
ac64: begin
symbol:=3618;
goto ac45;
end;
ac65: begin
symbol:=3617;
scannerbackup:=true;
goto ac45;
end;
ac66: begin
symbol:=3619;
goto ac45;
end;
ac67: begin
symbol:=3619;
scannerbackup:=true;
goto ac45;
end;
ac68: begin
if obc>132 then goto too_much;
store(zno).obc:=false add 3612;
obc:=obc+1;
goto ac51;
end;
ac69: begin
symbol:=3612;
goto ac45
end
end; <* case action of *>
end_case:
if match then goto try
else goto try1;
if false then
too_much: err:=6;
line_end:
store(zno).editarea(2):=store(zno).editarea(2) add
(obc shift (-1) shift 13);
if err<>0 then error(case err of
(0005,0002,0006,0012,0029,0009))
end; <* get_line *>
\f
integer procedure search_for_linenumber(line,addr,count);
value line; integer line,count; integer field addr;
begin
integer field p;
boolean field l;
p:=program_start+2;
l:=p+1;
count:=0;
while p<lastprogram and store(zno).p<line do
begin
count:=count+1;
p:=p+store(zno).l extract 12;
l:=p+1
end;
addr:=p;
search_for_linenumber:=if p>lastprogram then 3
else if store(zno).p=line then 1
else 2
end;
\f
procedure delete_line(p);
value p; integer p;
begin
boolean field l;
integer size,address,to,from;
l:=p+1;
size:=store(zno).l extract 12;
address:=p;
to:=p-1;
from:=to+size;
basicmove(store(zno),to,from,lastprogram-from+1);
adjust(address,size,true);
lastprogram:=lastprogram-size;
restcore:=restcore+size
end;
\f
procedure adjust(address,size,delete);
value address,size,delete;
integer address,size;
boolean delete;
begin
integer field inf;
integer i,j,asize;
integer sl,sp;
asize:=if delete then -size
else size;
if data_line=address and delete then
data_byte:=0
else
if data_line>=address then data_line:=data_line+asize;
if (this_statement=address and -, delete) or
(this_statement>address) then
this_statement:=this_statement+asize;
if (next_statement=address and -, delete) or
(next_statement>address) then
next_statement:=next_statement+asize;
for i:=1 step 1 until 29 do
if store(zno).fcttable(i)>=address then
store(zno).fcttable(i):=
if store(zno).fcttable(i)=address and delete then 0
else store(zno).fcttable(i)+asize;
for inf:=esc,err do
if store(zno).inf>=address then
store(zno).inf:=if store(zno).inf=address and delete then 0
else store(zno).inf+asize;
\f
if pstacktop>0 then
begin
sp:=pstacktop;
i:=sl:=plevel;
while i>0 do
begin
j:=-(i-1);
if store(zno).pstack(j)>address then
store(zno).pstack(j):=store(zno).pstack(j)+asize;
i:=store(zno).pstack(j+1);
end;
rep: while sp<>sl do
begin
i:=store(zno).pstack(-(sp-1));
j:=i extract 12;
i:=i shift (-12);
sp:=sp-i;
if j<>513 <*if*> and j<>514 <*proc*> and j<>517 <*case*> then
begin
if j=516 <*while*> then
begin
if store(zno).pstack(-sp)>=address then
store(zno).pstack(-sp):=
if store(zno).pstack(-sp)=address and delete then 0
else store(zno).pstack(-sp)+asize;
end else
begin
i:=sp;
if j>2048 <*for*> then i:=sp+1;
if store(zno).pstack(-i)>address then
store(zno).pstack(-i):=store(zno).pstack(-i)+asize;
end;
end;
end; <* while *>
if sl<>0 then
begin
sp:=sp-2;
sl:=store(zno).pstack(-sp);
goto rep;
end;
end; <* if stack not empty *>
end;
\f
procedure insert_line;
begin
boolean field to,from;
integer i,j,size;
i:=search_for_linenumber(store(zno).editarea(1),to,i);
size:=store(zno).editarea(2) shift (-12);
if i=1 then delete_line(to);
if size>restcore then
error(23)
else
begin
lastprogram:=lastprogram+size;
restcore:=restcore-size;
if lastprogram>=pstack-pstacktop shift 1 then
move_tables;
i:=to+size-1;
j:=to:=to-1;
basicmove(store(zno),i,j,lastprogram-j-size+1);
from:=1; j:=to;
basicmove(store(zno),j,from,size);
adjust(to+1,size,false)
end
end;
\f
integer procedure search_statement(p,stat,inc,alt);
value stat,inc,alt; integer p,stat,inc,alt;
begin
integer level,addr,code;
boolean field bf;
boolean found;
level:=1;
addr:=next_statement;
search_statement:=1; <* initially assume not found *>
found:=false;
while -, found and addr<lastprogram do
begin
bf:=addr+2;
code:=store(zno).bf extract 12;
if code=stat or code=alt then
begin
level:=level-1;
found:=level=0;
if -, found and alt<>0 and code<>alt then
level:=level+1
end
else
if code=inc then
begin
if code<>0513 <* if *> then
level:=level+1
else
begin
while store(zno).bf extract 12=0513 do
search_for_code_after_then(bf);
if store(zno).bf extract 12=1040 then
level:=level+1
end
end;
bf:=addr+1; pc:=bf+1;
addr:=addr+store(zno).bf extract 12
end;
if found then
begin
p:=addr;
search_statement:=if code=stat then 2
else 3
end
end;
\f
boolean procedure pop(type);
value type; integer type;
begin
integer i;
boolean found;
if pstacktop=plevel then
pop:=false
else
begin
repeat
i:=store(zno).pstack(-pstacktop+1);
found:=i extract 12=type;
restcore:=restcore+i shift (-12) shift 1;
pstacktop:=pstacktop-i shift (-12)
until pstacktop=plevel or found;
pop:=found
end
end; <* pop *>
\f
integer procedure search_code_and_var(from,code,var);
value from,code,var; integer from,code,var;
begin
integer array field iaf;
boolean field len,type,vari;
boolean found;
iaf:=from;
len:=1; type:=2; vari:=3;
found:=false;
while -, found and iaf<lastprogram do
begin
found:=store(zno).iaf.type extract 12=code and
store(zno).iaf.vari extract 12=var;
iaf:=iaf+store(zno).iaf.len extract 12
end;
search_code_and_var:=
if found then iaf
else 0
end;
\f
procedure init_run;
begin
for i:=1 step 1 until 29 do
store(zno).fcttable(i):=0;
store(zno).rnd:=store(zno).err:=store(zno).esc:=0;
for i:=1 step 5 until lastname*5 do
begin
store(zno).nametable(i):=
store(zno).nametable(i) extract 21;
store(zno).nametable(i+4):=-1
end;
restcore:=restcore+pstacktop shift 1+
(store_length shift 1+2-lastdata);
pstacktop:=plevel:=0;
for i:=-1 step 1 until no_of_user_zones do
pagetabpos(i):=pagetabpos(i) shift (-8) shift 8;
lastdata:=storelength shift 1+2;
data_line:=0;
end;
boolean procedure load1;
begin
load1:=false;
if expression(r,r)>0 then
begin
if packname(name,r) then
begin
if name(1)=long <:ptr:> then error(0025) else
load1:=openinternal(name,savedzaindex,2,1)=0
end
end
end;
\f
procedure load2;
begin
integer array field iaf;
procedure getsegment(first,last);
value first,last; integer first,last;
begin
iaf:=first;
while last-iaf>=512 do
begin
inrec6(za(zaindex),512);
tofrom(store(zno).iaf,za(zaindex),512);
iaf:=iaf+512
end;
if iaf<>last then
begin
inrec6(za(zaindex),last-iaf);
tofrom(store(zno).iaf,za(zaindex),last-iaf)
end
end; <* getsegment *>
\f
iaf:=0;
zaindex:=savedzaindex;
if inrec6(za(zaindex),0)<100 then
begin
error(0070);
goto exit_load2;
end;
inrec6(za(zaindex),100);
if za(zaindex).if2<>-1 then <* revision of save *>
error(0070)
else
if za(zaindex).if4>store_length shift 1-
program_start then
error(0014)
else
begin
lastdata:=storelength shift 1+2-za(zaindex).if8;
lastprogram:=programstart+za(zaindex).if6;
lastname:=za(zaindex).iaf(6);
pstack:=nametable:=
lastprogram+za(zaindex).iaf(5)-lastname*10;
pstacktop:=za(zaindex).iaf(7);
plevel:=za(zaindex).iaf(8);
this_statement:=za(zaindex).iaf(9);
next_statement:=za(zaindex).iaf(10);
data_line:=za(zaindex).iaf(11);
data_byte:=za(zaindex).iaf(12);
sys7:=za(zaindex).iaf(13);
sys8:=za(zaindex).iaf(14);
sys16:=za(zaindex).iaf(15);
restcore:=store_length shift 1-program_start-
za(zaindex).if4;
iaf:=30;
tofrom(store(zno).fcttable,za(zaindex).iaf,70);
getsegment(programstart,lastprogram);
getsegment(lastdata-2,storelength shift 1);
getsegment(lastprogram,nametable+lastname*10);
end; <* size ok *>
exit_load2:
closeza(zaindex)
end; <* load2 *>
\f
integer procedure get_next_data_item(r);
real r;
begin
integer savepc;
savepc:=pc;
if data_line=0 then
begin
data_line:=program_start+2;
data_byte:=data_line+2;
data_byte:= if store(zno).data_byte extract 12=551 then 3
else 0
end;
if data_byte=0 then
begin
repeat
data_byte:=data_line+1;
data_line:=data_line+store(zno).data_byte extract 12;
data_byte:=data_line+2
until store(zno).data_byte extract 12=551 or
data_line>=last_program;
data_byte:=3;
end;
if data_line>=last_program then
get_next_data_item:=-1
else
begin
pc:=data_line+data_byte;
get_next_data_item:=expression(r,r);
data_byte:=if store(zno).pc extract 12=1040 then 0
else pc-data_line+1;
pc:=savepc
end
end; <* get_next_data_item *>
\f
procedure normalize_decimal(x,l,e);
value x; real x;
long l; integer e;
begin
real log_10_of_2;
trap(oflow);
if x=0 then
begin
oflow: l:=0;
e:=0;
end
else
begin
log_10_of_2:=ln(2)/ln(10);
e:=x extract 12;
if e>=2048 then e:=e-4096;
e:=e*log_10_of_2;
l:=x/10**(e-12)-0.5;
if l>='12 then
begin
l:=l//10;
e:=e+1
end
end
end; <* normalize decimal *>
\f
procedure printmaxprec(z,x);
value x; real x;
zone z;
begin
integer e,i;
long l,l1;
normalize_decimal(x,l,e);
l:=(l+50)//100; <* round *>
if l>='10 then
begin <* post normalization *>
e:=e+1;
l:=l//10
end;
i:=10;
l1:=l;
while l1 mod 10=0 and i>e and i>0 do
begin
i:=i-1;
l1:=l1//10;
end;
if l1=0 then write(z,<:0:>)
else
if e>9 or e-i<=-11 then
begin
while l1 mod 10=0 do begin
i:=i-1;
l1:=l1//10
end;
write(z,<:.:>,case i of (
<<d>,<<zd>,<<zdd>,<<zddd>,<<zdddd>,
<<zddddd>,<<zdddddd>,<<zddddddd>,
<<zdddddddd>,<<zddddddddd>),
l1,<:E:>,<<+zd>,e)
end
else
begin
l:=10**(i-e);
l:=l1//l;
l1:=l1-l*10**(i-e);
if l<>0 then write(z,<<d>,l);
if i-e>0 then write(z,<:.:>,case i-e of (
<<d>,<<zd>,<<zdd>,<<zddd>,<<zdddd>,<<zddddd>,
<<zdddddd>,<<zddddddd>,<<zdddddddd>,
<<zddddddddd>),l1);
end
end; <* printmaxprec *>
\f
integer procedure using(r);
real r;
begin
real x;
long frac,lhelp,l11;
integer flength,wlength,elength,i,ch,inp,state,action,
strlen,help,next_field,prefix_length,dbefore,
dafter,float_char,zero_suppress,expf,e,d1,d2,d3;
boolean field faddr,waddr,eaddr,straddr,prefix_addr;
boolean numeric,sign,format_found;
procedure out_float_char;
begin
if float_char<>0 then
begin
obc:=obc-1;
store_byte(float_char);
float_char:=0;
end;
end;
procedure store_byte(byte);
value byte; integer byte;
begin
if obc>132 then
begin
error(0133);
goto exit_pru;
end;
store(zno).obc:=false add byte;
obc:=obc+1;
end;
\f
procedure next_char;
begin
elength:=elength-1;
if elength=0 then
begin
ch:=0;
inp:=8;
end else
begin
ch:=store(zno).eaddr extract 12;
if ch=43 then inp:=1 else
if ch=45 then inp:=2 else
if ch=36 then inp:=3 else
if ch=35 then inp:=4 else
if ch=46 then inp:=5 else
if ch=44 then inp:=6 else
if ch=94 then inp:=7 else
inp:=8;
end;
eaddr:=eaddr+1;
end;
procedure output_rest_of_format;
begin
while wlength>1 do
begin
store_byte(store(zno).waddr extract 12);
waddr:=waddr+1;
wlength:=wlength-1;
end;
end;
\f
procedure state_action;
begin
action:=case state of (
<* 1 2 3 4 5 6 7 8 *>
<* 1 *> case inp of
( 1, 2, 3, 4, 10, 16, 16, 16),
<* 2 *> case inp of
( 4, 4, 5, 6, 11, 16, 16, 16),
<* 3 *> case inp of
(16, 16, 4, 6, 11, 16, 16, 16),
<* 4 *> case inp of
(12, 12, 4, 7, 11, 8, 13, 14),
<* 5 *> case inp of
( 4, 4, 14, 7, 11, 8, 13, 14),
<* 6 *> case inp of
(12, 12, 14, 4, 11, 8, 13, 14),
<* 7 *> case inp of
(12, 12, 15, 4, 11, 9, 15, 15),
<* 8 *> case inp of
(16, 16, 16, 4, 16, 16, 16, 16),
<* 9 *> case inp of
(12, 12, 15, 4, 15, 15, 13, 15),
<* 10 *> case inp of
(15, 15, 15, 15, 15, 15, 17, 15));
state:=case state of (
<* 1 2 3 4 5 6 7 8 *>
<* 1 *> case inp of
( 2, 2, 3, 6, 8, 1, 1, 1),
<* 2 *> case inp of
( 5, 5, 3, 6, 8, 2, 2, 2),
<* 3 *> case inp of
( 3, 3, 4, 6, 8, 3, 3, 3),
<* 4 *> case inp of
( 4, 4, 4, 7, 9, 4, 10, 4),
<* 5 *> case inp of
( 5, 5, 5, 7, 9, 5, 10, 5),
<* 6 *> case inp of
( 6, 6, 6, 6, 9, 6, 10, 6),
<* 7 *> case inp of
( 7, 7, 7, 7, 9, 7, 7, 7),
<* 8 *> case inp of
( 8, 8, 8, 9, 8, 8, 8, 8),
<* 9 *> case inp of
( 9, 9, 9, 9, 9, 9, 10, 9),
<* 10 *> case inp of
(10, 10, 10, 10, 10, 10, 10, 10));
end; <* state_action *>
\f
<* begin of using *>
using:=-2; <* asume error *>
obc:=3; <* first available hfwd *>
l11:=10**11;
i:=expression(x,x); <* format string *>
if i<0 then goto exit_pru;
if i=3 then <* char *>
begin
wlength:=flength:=2;
waddr:=faddr:=1;
store(zno).editarea(1):=x shift (-12) extract 19;
end else
begin
wlength:=flength:=x extract 24+1;
waddr:=faddr:=x shift (-24) extract 24;
end;
format_found:=false;
repeat <* get expression and edit *>
pc:=pc+1; <* skip terminator *>
if store(zno).pc extract 12=1040 then
begin
pc:=pc-1;
goto endpru
end;
i:=expression(x,x);
if i<0 then goto exit_pru;
if i<3 then <* numeric *>
begin
sign:=x<0;
x:=abs x;
numeric:=true;
end
else <* string or char *>
begin
if i=3 then <* char *>
begin
straddr:=2;
strlen:=1;
store(zno).editarea(1):=store(zno).editarea(1)
shift (-12) shift 12 +
x shift (-24) extract 7;
end else
begin
straddr:=x shift (-24) extract 24;
strlen:=x extract 24;
end;
numeric:=false;
end;
\f
rep_edit_s:
next_field:=eaddr:=waddr;
elength:=wlength;
dbefore:=expf:=0;
dafter:=-1;
state:=1; floatchar:=0;
next_s: next_char;
state_action;
case action of
begin
<* 1 *> float_char:=ch;
<* 2 *> float_char:=ch;
<* 3 *> ;
<* 4 *> dbefore:=dbefore+1;
<* 5 *> ;
<* 6 *> dbefore:=dbefore+1;
<* 7 *> dbefore:=dbefore+1;
<* 8 *> ;
<* 9 *> ;
<* 10 *> begin
dafter:=dbefore; dbefore:=0
end;
<* 11 *> begin
dafter:=dbefore; dbefore:=0
end;
<* 12 *> goto if floatchar=0 then after_edit_s else s14;
<* 13 *> expf:=expf+1;
<* 14 *>s14:begin
eaddr:=eaddr-1; elength:=elength+1;
goto after_edit_s;
end;
<* 15 *> goto s14;
<* 16 *> if ch=0 then
begin
next_field:=0;
goto after_edit_s;
end else
next_field:=eaddr;
<* 17 *> expf:=expf+1
end;
goto next_s;
after_edit_s:
if next_field=0 then
begin
output_rest_of_format;
waddr:=faddr; wlength:=flength; <* start from beginn. *>
if -, format_found then
begin
error(0131);
goto exit_pru;
end;
goto rep_edit_s;
end;
help:=waddr;
waddr:=eaddr;
eaddr:=next_field;
prefix_length:=next_field-help;
prefix_addr:=help;
help:=wlength;
wlength:=elength; <* length of next field *>
elength:=help-wlength-prefix_length+1;
while prefix_length>0 do
begin
store_byte(store(zno).prefix_addr extract 12);
prefix_addr:=prefix_addr+1;
prefix_length:=prefix_length-1;
end;
if numeric then
begin
if dafter=-1 then dafter:=0
else
begin
help:=dafter;
dafter:=dbefore;
dbefore:=help
end;
normalize_decimal(x,frac,e);
if frac<>0 then
begin <* round *>
help:=dafter+(if expf<>0 then dbefore else e);
if help>11 then help:=11; <* number of digits *>
if help>0 then
begin
lhelp:=5*10**(11-help);
frac:=frac+lhelp;
if frac>='12 then
begin <* post normalization *>
e:=e+1;
frac:=frac//10;
end;
lhelp:=10**(11-help);
frac:=frac-frac mod lhelp;
end;
end; <* round *>
if expf<>0 then <* adjust exponent *>
e:=e-dbefore;
<* calculate number of leading zeroes *>
dbefore:=if expf<>0 then 0
else dbefore-e;
if dbefore>0 then goto ok;
if dbefore=0 then
begin
if expf=0 then goto ok;
if expf>2 and e<10 or
expf>3 and e<100 or
expf=5 then goto ok;
end;
while elength>1 do
begin
store_byte(42 <* * *>);
elength:=elength-1;
end;
goto after_edit_n;
ok: state:=1; float_char:=0; zerosuppress:=32;
next_n: next_char;
state_action;
case action of
begin
<* 1 *> begin
float_char:=if sign then 45 <* - *>
else ch;
store_byte(32); <* space *>
end;
<* 2 *> begin
float_char:=if sign then 45 <* - *>
else 32; <* space *>
store_byte(32);
end;
<* 3 *> begin
float_char:=36; <* dollar *>
store_byte(32);
end;
<* 4 *>n4: begin
help:=dbefore;
dbefore:=dbefore-1;
if help>0 then
store_byte(zero_suppress)
else
begin
if help=0 then
out_float_char;
store_byte((frac//l11+48) extract 24); <* digit *>
frac:=frac mod l11*10;
end;
end;
<* 5 *> begin
out_float_char;
float_char:=36; <* dollar *>
store_byte(32);
end;
<* 6 *>n6: begin
out_float_char;
goto n4;
end;
<* 7 *> begin
zero_suppress:=48; <* 0 *>
goto n6;
end;
<* 8 *> store_byte(if dbefore<0 then ch
else 32);
<* 9 *> store_byte(ch);
<* 10 *>n10: begin
zero_suppress:=48; <* 0 *>
store_byte(46); <* . *>
end;
<* 11 *> begin
if float_char<>0 or dbefore>=0 then
begin
if float_char=0 then
float_char:=48; <* 0 *>
out_float_char;
end;
goto n10;
end;
<* 12 *> begin
if ch=45 then ch:=32; <* space *>
if sign then ch:=45; <* - *>
if dbefore<0 then
store_byte(ch)
else
begin
zero_suppress:=ch;
obc:=obc-1;
out_float_char;
store_byte(48);
dbefore:=-1; <* stop zero suppressing *>
store_byte(zero_suppress);
end;
end;
<* 13 *> begin
store_byte(69); <* E *>
float_char:=if e<0 then 45
else 43;
e:=abs e;
if expf>4 then
begin
d3:=e mod 10; e:=e//10;
end;
if expf>3 then
begin
d2:=e mod 10; e:=e//10;
end;
d1:=e;
end;
<* 14 *> begin
if dbefore>=0 then
begin
obc:=obc-1;
out_float_char;
store_byte(48);
end;
goto after_edit_n;
end;
<* 15 *> goto after_edit_n;
<* 16 *> begin
error(0068);
goto exit_pru;
end;
<* 17 *> begin
if float_char<>0 then
begin
store_byte(float_char);
float_char:=0;
end else
begin
store_byte(d1+48); d1:=d2; d2:=d3;
end;
end;
end; <* case *>
goto next_n;
after_edit_n:
end <* numeric *>
else
begin <* string *>
strrep: if strlen=0 then goto end_string;
ch:=store(zno).straddr extract 12;
straddr:=straddr+1;
if ch=0 then goto end_string;
elength:=elength-1;
if elength=0 then goto end_field;
store_byte(ch);
strlen:=strlen-1;
goto strrep;
end_string:
while elength>1 do
begin
store_byte(32);
elength:=elength-1;
end;
end_field:
end; <* string *>
format_found:=true;
until store(zno).pc extract 12<>1039; <* , *>
endpru:
output_rest_of_format;
using:=4; <* string *>
r:=real (extend 3 shift (24) add (obc-3));
exitpru:
end; <* using *>
\f
procedure copy_char(ch);
value ch; integer ch;
if cindex<132 then
begin
compline(cindex):=false add ch;
cindex:=cindex+1
end;
procedure copy_line_out(z);
zone z;
begin
integer i;
if currout=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn)
end;
for i:=1 step 1 until cindex-1 do
write(za(currout),compline(i),1);
repeatchar(z);
if readchar(z,i)<>8 then
begin
while readchar(z,i)<>8 do
outchar(za(currout),i)
end;
write(za(currout),<:<13><10>:>);
if currout=1 then setposition(za(1),0,0);
end;
\f
boolean procedure link(procno);
value procno; integer procno;
begin
integer i;
integer array ia1(1:8);
getshare6(zph,ia,1);
ia(4):=(case procno of (100, 102, 104)) shift 12;
if (procno=2 and killed(incarn)) then ia(4):=ia(4)+1;
ia(5):=terminals(incarn,1);
if procno <> 1 then else
begin
ia(6):=termproc;
ia(7):=0;
end;
setshare6(zph,ia,1);
for i:=1 step 1 until 8 do ia1(i):=ia(i);
monitor(16)sendmess:(zph,1,ia);
if monitor(18)waitansw:(zph,1,ia)<>1 then trap(procno+5) else
begin
temst(14):=ia(1) shift (-9) extract 1 = 1;
temst(15):=ia(1) shift (-8) extract 1 = 1;
temst(16):=ia(1) shift (-7) extract 1 = 1;
temst(18):=ia(1) shift (-5) extract 1 = 1;
temst(19):=ia(1) shift (-4) extract 1 = 1;
temst(21):=ia(1) shift (-2) extract 1 = 1;
temst(23):=ia(1) extract 1 = 1;
link:=temst(13):=case procno of
( -,(temst(14) or temst(15) or temst(18) or temst(19) or temst(21)),
-,(temst(15) or temst(16) or temst(23)),
-,(temst(15) or temst(16)));
if procno=3 and temst(13) then
begin
linestoterm:=ia(6); termroom:=ia(7); termproc:=ia(3);
end;
end;
if -, temst(13) then
begin
write(out,<:<10>*** link error:>);
write(out,<:<10>temst: :>);
for i:=14 step 1 until 16,18,19,21,23 do
if temst(i) then write(out,<<ddddd>,i);
for i:=4 step 1 until 8 do
write(out,<:<10>:>,<<dddddddd>,ia1(i),ia1(i) shift (-12),ia1(i) extract 12);
setposition(out,0,0);
end;
end proc link;
\f
<*:if testbit3 then
begin
tmcpu:=systime(1,tmbase,tmbase)-tmcpu;
tmtime:=tmbase-tmtime;
write(out,<:**time measure**:>,nl,1,
<: for entering context block:>,nl,1,
<: cputime: :>,<<dddd.dd>,tmcpu,nl,1,
<: realtime: :>,tmtime,nl,2);
setposition(out,0,0);
systime(1,0,tmbase);
end;
if testbit2 then
begin
write(out,<:**statistics**:>,nl,1,
<: blocksread after context entry: :>,blocksread,nl,2);
setposition(out,0,0);
end;
if testbit1or2 then
begin
if newincarnation then write(out,<: newincarnation:>,nl,2)
else write(out,<: oldincarnation:>,nl,2);
setposition(out,0,0);
end;
if testbit3 then tmcpu:=systime(1,tmbase,tmtime);
***********:*>
if newincarnation then
begin
init_context;
newincarnation:=false;
end else monitor(72,ownprocess,0,base);
worki:=terminals(incarn,2);
if auto then
begin
worki:=worki-2;
ignorestopatt:=false;
if attstatus then worki:=1;
end;
if worki extract 1 = 1 and -,ignorestopatt then worki:=1
else worki:=(worki shift (-1) shift 1)//2+1;
\f
if -,testbit13 then trap(contexterror);
<*:if testbit1 then
begin
write(out,<: precase caseindex: :>,worki,nl,1);
setposition(out,0,0);
end;:*>
entrytime:=getclock;
case worki of
begin
stopattreceived:
begin
stopatt:=true;
if auto then
begin
auto:=stopatt:=false;
if terminals(incarn,2)=7
then begin
terminals(incarn,2):=5;
goto examinqueue;
end
else goto return_to_user;
end;
continue;
end;
loginattreceived:
begin
if -,link(1) then
begin
trap(14);
terminals(incarn,2):=0;
if incarn=mainno then mainno:=0;
goto examinqueue;
end;
act:=1;
end;
\f
com_or_stm_line_received:
begin
if (attstatus or killed(incarn)) then goto return_to_user;
lineclass:=getline(za(currin));
if auto and lineclass=4 then
linenumber1:=linenumber1+linenumber2;
if lineclass=5 or lineclass=1 then
begin
if lineclass=5 then errorout(sys7);
goto return_to_user;
end else
act:=lineclass;
end;
demanded_input_received:
begin
continue;
end;
executing:
begin
if killed(incarn) then goto bye;
continue;
end;
end precase;
<*:if testbit3 then
begin
tmcpu:=systime(1,tmbase,tmbase)-tmcpu;
tmtime:=tmbase-tmtime;
write(out,<:**time measure**:>,nl,1,
<: for precase and maybe init context:>,nl,1,
<: cputime: :>,<<dddd.dd>,tmcpu,nl,1,
<: realtime: :>,<<dddd.dd>,tmtime,nl,2);
setposition(out,0,0);
systime(1,0,tmbase);
end;
\f
if testbit1 then
begin
write(out,<: action case caseindex: :>,act,nl,1);
setposition(out,0,0);
end;
if testbit2 then
begin
write(out,<:**statistics**:>,nl,1,
<: blocksread after precase: :>,blocksread,nl,2);
setposition(out,0,0);
end;
if testbit3 then
tmcpu:=systime(1,tmbase,tmtime);
**********:*>
case act of
begin
loginact:
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,<:type user name and project number:>,<:<13><10>:>);
setposition(za(1),0,0);
startinput;
waitinlist(0,incarn);
<*: if testbit3 then
begin
tmcpu:=systime(1,tmbase,tmbase)-tmcpu;
tmtime:=tmbase-tmtime;
write(out,<:**time measure**:>,nl,1,<: for login before exit:>,
nl,1,<: cputime: :>,<<dddd.dd>,tmcpu,nl,1,
<: realtime: :>,tmtime,nl,2);
setposition(out,0,0);
systime(1,0,tmbase);
end;:*>
exit (examinqueue);
if att_status or stop_att then
begin
error(0068);
goto exit_login;
end;
if killed(incarn) then
begin
killed(incarn):=false;
link(2);
terminals(incarn,2):=0;
if incarn=mainno then mainno:=0;
goto examinqueue;
end;
\f
<*: if testbit1 then
begin
getshare6(za(1),ia,1);
write(out,<: demanded logininfo received:>,nl,1,
<: mode: :>,ia(4) extract 12,nl,1);
setposition(out,0,0);
end;:*>
worki:=read_all(za(1),loginval,loginkind,1)-3;
if worki=1 or worki=2 then
begin
loginsyntax:=( case worki of
(loginkind(1)=6,
loginkind(1)=6 and loginkind(2)=6) ) and
( loginval(worki+1)=32 and loginkind(worki+2)=2
and loginkind(worki+3)=8 );
end
else
loginsyntax:=false;
if worki=1 then loginval(2):=0;
if loginsyntax then loginval(4):=loginval(worki+2);
setposition(za(1),0,0);
if incarn<>mainno then
begin
write(za(1),<<zdd>,incarn,<:<13><10>:>);
setposition(za(1),0,0)
end;
\f
if loginsyntax then
begin
<*: if testbit1 then
begin
write(out,<: loginval12: :>,loginval,<: loginval4: :>,loginval(4),
nl,1);
setposition(out,0,0);
end;:*>
login_user(loginval);
end else error(0068);
exit_login:
if error_called then
begin
errorout(sys7);
killed(incarn):=false;
link(2); <* remove link *>
terminals(incarn,2):=0;
if incarn=mainno then mainno:=0;
goto examinqueue;
end;
if userident(incarn,1) = long <:opera:> add 116 <*t*> and
userident(incarn,2) = long <:or:>
then oprno:=incarn;
goto return_to_user;
end loginact;
\f
dlte_lines:
begin
if search_for_linenumber(store(zno).editarea(1),listf,0)<>1 then
error(0013)
else
repeat
delete_line(listf);
until store(zno).listf>linenumber1 or listf>lastprogram;
end;
stm_to_be_executed: <* no line number *>
begin
if incarn<>mainno then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,<:<13><10>:>);
setposition(za(1),0,0);
end;
pc:=2;
goto execute;
end;
stm_to_be_inserted: <* with line number *>
begin
insertline;
end;
dummy_action5:
begin
end;
\f
com_to_be_executed:
begin
if incarn<>mainno then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,<:<13><10>:>);
setposition(za(1),0,0)
end;
case commandcode of
begin
autoo:
begin
auto:=true;
end;
batch:
begin
if locked then goto con;
end;
con:
begin
if locked then
begin
error(0000);
goto exit_con;
end;
if this_statement=0 then this_statement:=program_start+2;
running:=true;
exit_con:
end;
conl:
begin
name(1):=long <:lpt:>; name(2):=0;
if open_internal(name,savedzaindex,1,11)=0 then
begin
currout:=savedzaindex;
goto con;
end;
end;
eoj:
begin
end;
\f
list:
begin <* list *>
savedzaindex:=currout;
if search_for_linenumber(linenumber1,listf,0)<3 and
lastprogram>programstart then
begin
list1:=0; <* number of spaces *>
if search_for_linenumber(linenumber2,list2,0)=3 then
list2:=lastprogram;
pc:=5;
if store(zno).pc extract 12<>0 then
begin
pc:=4;
if expression(r,r)>0 and packname(name,r) then
begin
if openinternal(name,savedzaindex,4,11)<>0 then
goto endlist;
end;
end;
zaindex:=savedzaindex;
if punching then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,false,72);
end;
\f
listrep: <*repeat*>
if spoolfull(incarn) then
begin
termno:=incarn;
insert;
exit(examinqueue);
zaindex:=savedzaindex;
goto listrep
end;
if zaindex=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
write(za(zaindex),<<zddd>,store(zno).listf,sp,1);
bf:=listf+2;
worki:=store(zno).bf extract 12;
if worki<=518 then <* indent *>
begin
write(za(zaindex),sp,list1);
if worki>513 then
list1:=list1+2
else
begin
while store(zno).bf extract 12=513 do
search_for_code_after_then(bf);
if store(zno).bf extract 12=1040 then
list1:=list1+2
end
end
else if worki<=524 then
begin
list1:=list1-2;
if list1<0 then list1:=0;
write(za(zaindex),sp,list1)
end
else if worki<=526 then write(za(zaindex),sp,list1-2)
else write(za(zaindex),sp,list1);
bf:=listf+2;
list_a_line(bf,za(zaindex));
\f
if getclock-entrytime>timeslice then
begin
if killed(incarn) then goto bye;
entrytime:=getclock;
if anyactions then
begin
if zaindex=1 then setposition(za(1),0,0);
termno:=incarn;
insert;
exit(examinqueue);
zaindex:=savedzaindex;
end;
end;
bf:=listf+1;
listf:=listf+store(zno).bf extract 12;
<*until*> if -, (listf>list2 or stop_att) then goto listrep;
if stop_att then
begin
stop_att:=false;
terminals(incarn,2):=terminals(incarn,2) shift (-1) shift 1;
end;
if zaindex<>currout then
begin
fileno:=-1;
closeza(zaindex);
end;
if punching then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,false,72);
punching:=false;
end;
end; <* if *>
endlist:
end; <* list *>
\f
load:
begin <* load *>
pc:=4;
if load1 then
begin
if exitexamine then
begin
exit(examinqueue);
open_after_exit(name)
end;
if -, error_called then load2
end
end; <* load *>
\f
mess:
begin
pc:=4;
i:=expression(r,r1);
if i<0 then goto exit_mess;
k:=0;
if store(zno).pc extract 12<>1040<*eos*> then
begin
if -,packname(la,r) then goto exit_mess;
pc:=pc+1;
i:=expression(r,r1);
if i<0 then goto exit_mess;
for k:=1 step 1 until maxincarn do
begin
if userident(k,1)=la(1) and
userident(k,2)=la(2) and
userident(k,3)=r then goto mess_found;
end;
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,
<:<13><10>user not logged in<13><10>:>);
setposition(za(1),0,0);
goto exit_mess;
mess_found:
pc:=pc+1;
i:=expression(r,r1);
if i<0 then goto exit_mess;
end;
j:=((r extract 24 + 1)*2)//6 + 1;
begin long array wrk(1:j);
integer i1,i2,i3;
bf:=r shift (-24) extract 24;
i1:=bf + r extract 24 - 1;
for i:=1 step 1 until j do
begin
wrk(i):=0;
for i3:=1 step 1 until 6 do
begin
i2:=if bf>i1 then 0 else store(zno).bf extract 8;
wrk(i):=wrk(i) shift 8 + i2;
bf:=bf+1;
end
end;
setposition(za(1),0,0);
if k<>0 or k=0 and incarn<>oprno then
begin
j:=1;
write(za(1),<<zdd>,if k<>0 then k else oprno,
<:<13><10>from: :>,
string userident(incarn,increase(j)));
if k=0 then
write(za(1),<<-d>,userident(incarn,3));
write(za(1),<:<13><10>:>,wrk,<:<13><10>:>);
setposition(za(1),0,0);
end
else
begin
for i:=1 step 1 until maxincarn do
begin
j:=1;
if i<>oprno and userident(i,1)<>0 then
write(za(1),<<zdd>,i,
<:<13><10>from: :>,
string userident(incarn,increase(j)),
<:<13><10>:>,wrk,<:<13><10>:>);
setposition(za(1),0,0);
end;
end;
end;
exit_mess:
end;
\f
punch:
begin
punching:=true;
goto list;
end;
\f
renumber:
begin <* renumber *>
search_for_linenumber(10000,listf,list1);
if extend list1*linenumber2+linenumber1>9999 then
linenumber1:=linenumber2:=1;
listf:=programstart+2;
list1:=0; <* on_count *>
while listf<lastprogram do
begin
repeat <* find next linenumber reference *>
if list1>0 then
begin <* processing an on_statement *>
inf:=inf+2;
list1:=list1-1
end
else
begin <* get next line *>
inf:=0;
pc:=listf+1;
listf:=listf+store(zno).pc extract 12;
pc:=pc+1;
while store(zno).pc extract 12=513 <* if *> do
search_for_code_after_then(pc);
ren1: worki:=store(zno).pc extract 12;
if worki=548 or worki=555 or worki=556 then
<* restore gosub goto *>
inf:=(pc+3) shift (-1) shift 1
else
if worki=557 <* on *> then
begin
pc:=pc+1;
list1:=inf:=store(zno).pc extract 12-1;
search_for_code_after_then(pc);
if list1=-1 then <* esc or err *>
goto ren1
else <* inf points at first statement number *>
inf:=(pc+3) shift (-1) shift 1
end <* on *>
end <* if list1>0 *>
until inf>=0;
if inf>0 then <* linenumber found *>
begin <* insert new linenumber *>
if search_for_linenumber(store(zno).inf,list2,worki)<>1 then
store(zno).inf:=0
else
store(zno).inf:=worki*linenumber2+linenumber1
end <* if inf>0 *>
end; <* while listf<lastprogram *>
\f
listf:=programstart+2;
while listf<lastprogram do
begin
store(zno).listf:=linenumber1;
linenumber1:=linenumber1+linenumber2;
pc:=listf+1;
listf:=listf+store(zno).pc extract 12
end
end; <* renumber *>
\f
run:
begin
if locked then
begin
error(0000);
goto exit_run;
end;
if linenumber1<>0 then
begin
if search_for_linenumber(linenumber1,worki,0)<>1 then
error(0013)
else
begin
init_run;
running:=true;
this_statement:=worki;
end
end else
begin
pc:=5;
if store(zno).pc extract 12<>0 then
begin
pc:=4;
if load1 then
begin
if exitexamine then
begin
exit(examinqueue);
open_after_exit(name);
end;
if -, error_called then load2
end
end;
if -, errorcalled then
begin
init_run;
running:=true;
this_statement:=programstart+2;
end;
end;
exit_run:
end;
runl:
begin
if locked then goto run;
name(1):=long <:lpt:>; name(2):=0;
if openinternal(name,savedzaindex,1,11)=0 then
begin
currout:=savedzaindex;
goto run
end
end;
scratch:
begin
end;
size:
begin
worki:=(lastprogram-programstart)+
(store_length shift 1+2-lastdata)+
(pstacktop shift 1+lastname*10);
if currout=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
write(za(currout),<:used::>,<<_ddddd>,worki,
<: halfwords<13><10>:>,
<:left::>,restcore,<: halfwords<13><10>:>);
if currout=1 then setposition(za(1),0,0);
end;
time:
begin
end;
disp:
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,<:<13>
logged in last<13><10>:>);
setposition(za(1),0,0);
for i:=1 step 1 until maxincarn do
if userident(i,1)<>0 then
begin
j:=1;
write(za(1),<<zdd>,incarn,<<dd>,i,<: :>);
write(za(1),sp,12-write(za(1),string userident(i,increase(j))));
if incarn<>oprno or
userident(incarn,1)<>long<:opera:> add <*t*>116 or
userident(incarn,2)<>long<:or:> then j:=0 else
j:=write(za(1),userident(i,3));
write(za(1),sp,8-j);
systime(4,logintime(i),r);
writedate(za(1),r,0,0);
write(za(1),sp,4);
systime(4,lasttime(i),r);
writedate(za(1),r,0,0);
write(za(1),<:<13><10>:>);
setposition(za(1),0,0);
end;
end display;
\f
kill:
begin
if userident(incarn,1)<>long<:opera:> add <*t*>116 or
userident(incarn,2)<>long<:or:> then
begin
error(0026);
goto exit_kill;
end;
pc:=4;
i:=expression(r,r1);
if i<0 then goto exit_kill;
if -,packname(la,r) then goto exit_kill;
pc:=pc+1;
i:=expression(r,r1);
if i<0 then goto exit_kill;
for k:=1 step 1 until maxincarn do
begin
if userident(k,1)=la(1) and
userident(k,2)=la(2) and
userident(k,3)=r then goto kill_found;
end;
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,
<:<13><10>user not logged in<13><10>:>);
setposition(za(1),0,0);
goto exit_kill;
kill_found: <*now k is the incarn to be killed*>
killed(k):=true;
exit_kill:
end kill;
\f
lock:
if userident(incarn,1)<>long<:opera:> add <*t*>116 or
userident(incarn,2)<>long<:or:> then error(0026)
else locked:=true;
unlock:
if userident(incarn,1)<>long<:opera:> add <*t*>116 or
userident(incarn,2)<>long<:or:> then error(0026)
else locked:=false;
end commandcase;
end;
end;
\f
<*:if testbit3 then
begin
tmcpu:=systime(1,tmbase,tmbase)-tmcpu;
tmtime:=tmbase-tmtime;
write(out,<<dddd.dd>,<:**time measure**:>,nl,1,
<: at start of runloop:>,nl,1,
<: cputime: :>,tmcpu,nl,1,
<: realtime: :>,tmtime,nl,2);
setposition(out,0,0);
systime(1,0,tmbase);
end;:*>
runloop: runsum:=0;
<*:if testbit3 then tmcpu:=systime(1,tmbase,tmtime);:*>
runrep: if this_statement<lastprogram and running then
begin
<*: if testbit29 then
begin
write(out,<:lc::>,<<_ddddd>,this_statement,nl,1);
setposition(out,0,0);
end;:*>
bf:=this_statement+1;
next_statement:=this_statement+store(zno).bf extract 12;
pc:=this_statement;
execute: pc:=pc+2;
worki:=store(zno).pc extract 9;
pc:=pc+1;
<*: if testbit2 then
begin
write(out,<:**statistics**:>,nl,1,
<: blocksread before caseout: :>,
blocksread,nl,2);
setposition(out,0,0);
end;
if testbit1or2 then
write(out,<: caseout caseindex: :>,worki,nl,2);
*****:*>
case worki of
begin
\f
<* 513, if -1- *>
begin
integer i,action;
if expression(r,r1)>0 then
begin
pc:=pc+1; <* skip then *>
if r=0 <* false *> then
begin
while store(zno).pc extract 12=0513 <* if *> do
search_for_code_after_then(pc);
if store(zno).pc extract 12=1040 <* eos *> then
begin
case search_statement(i,0526,0513,0519) of
begin <*else if endif*>
<* 1: *> begin <* not found *>
error(0052)
end;
<* 2: *> begin <* else found *>
action:=0;
next_statement:=i;
stack_it: if restcore<4 then
error(0020)
else
begin
restcore:=restcore-4;
pstacktop:=pstacktop+2;
if pstack-pstacktop shift 1<lastprogram
then move_tables;
store(zno).pstack(-pstacktop+2):=action;
store(zno).pstack(-pstacktop+1):=2 shift 12
+0513
end
end;
<* 3: *> next_statement:=i; <* endif found *>
end
end <* 1040 *>
end <* false *>
\f
<* 513, if -2- *>
else <* true *>
if store(zno).pc extract 12=1040 then
begin
action:=1;
goto stack_it
end
else
begin
pc:=pc-2;
goto execute;
end;
end <* expression ok *>
end; <*if*>
\f
<* 514, proc *>
begin
integer i;
if search_statement(i,0520,0514,0000)=1 then
error(0045)
else
next_statement:=i
end; <*proc*>
\f
<* 515, for -1- *>
begin
integer i,j,to,from,count,var;
real stepval,limit,x;
real field v,b,c;
i:=restcore;
j:=pstacktop;
var:=store(zno).pc extract 12;
if pop(var) then
begin <* delete stack entry *>
from:=pstack-j shift 1+1;
to:=from+14;
i:=i+14;
j:=j-7;
count:=(j-pstacktop) shift 1;
basicmove(store(zno),to,from,count);
<* compress stack *>
end;
restcore:=i;
pstacktop:=j;
if expression(0.0,0.0)<0 then goto errexit;
pc:=pc+1;
if expression(limit,x)<0 then goto errexit;
if store(zno).pc extract 12=1040 then stepval:=1.0
else begin
pc:=pc+1;
if expression(stepval,x)<0 then goto errexit
end;
\f
<* 515, for -2- *>
v:=store(zno).nametable((var extract 9)*5)+
storelength shift 1+2; <* address *>
if (store(zno).v-limit)*stepval<=0 then
begin <* stack new element *>
if restcore<14 then error(0020)
else
begin
restcore:=restcore-14;
pstacktop:=pstacktop+7;
if pstack-pstacktop shift 1<lastprogram then
move_tables;
b:=pstack-pstacktop shift 1+10;
c:=b-4;
store(zno).pstack(-pstacktop+1):=7 shift 12+var;
store(zno).pstack(-pstacktop+6):=next_statement;
store(zno).pstack(-pstacktop+7):=v-storelength shift 1;
store(zno).b:=stepval;
store(zno).c:=limit
end
end <* stack *>
else
begin
i:=search_code_and_var(next_statement,0523,var);
if i=0 then error(0021)
else next_statement:=i
end;
errexit:
end; <*for*>
\f
<* 516, while *>
begin
integer i;
if expression(r,r1)>0 then
begin
if r=0 <* false *> then
begin
if search_statement(i,0522,0516,0000)=1 then
error(0053)
else
next_statement:=i
end
else <* true *>
begin
if restcore<4 then error(0020)
else
begin
restcore:=restcore-4;
pstacktop:=pstacktop+2;
if pstack-pstacktop shift 1<lastprogram then
move_tables;
store(zno).pstack(-pstacktop+2):=this_statement;
store(zno).pstack(-pstacktop+1):=2 shift 12+0516
end
end
end
end; <*while*>
\f
<* 517, case -1- *>
begin
real r1,r2,r3;
integer resulttype1,resulttype2,i,savelc;
boolean found;
i:=expression(r1,r3);
if i>0 then
begin
resulttype1:=(i+1) shift (-1);
savelc:=next_statement;
if restcore<2 then
begin
error(0020);
goto errexit
end;
restcore:=restcore-2;
pstacktop:=pstacktop+1;
if pstack-pstacktop shift 1<lastprogram then
move_tables;
store(zno).pstack(-pstacktop+1):=1 shift 12+0517;
repeat
i:=search_statement(next_statement,
0525,0517,0521);
if i=2 then <* when found 0525 *>
begin
repeat
pc:=pc+1;
resulttype2:=expression(r2,r3);
if resulttype2<0 then goto errexit;
resulttype2:=(resulttype2+1) shift (-1);
if resulttype1<>resulttype2 then
begin
error(0066); <* type conflict *>
goto errexit
end;
found:=if resulttype1=1 then r1=r2
else comparestring(r1,r2,4)=1;
until found or store(zno).pc extract 12=1040
end
until i<>2 or found;
\f
<* 517, case -2- *>
if i=1 then error(0059)
else if i=3 then
begin
next_statement:=savelc;
pc:=savelc+2;
if store(zno).pc extract 12=0512 <* endcase *> or
store(zno).pc extract 12=0525 <* when *> then
error(0059)
end
end;
errexit:
end; <*case*>
\f
<* 518, repeat *>
if restcore<4 then
error(0020)
else
begin
restcore:=restcore-4;
pstacktop:=pstacktop+2;
if pstack-pstacktop shift 1<lastprogram then
movetables;
store(zno).pstack(-pstacktop+2):=next_statement;
store(zno).pstack(-pstacktop+1):=2 shift 12+0518
end; <*repeat*>
\f
<* 519, endif *>
if -, pop(0513) then error(0056);
\f
<* 520, endproc (return) *>
endproc: if plevel=0 then error(0019)
else
begin
next_statement:=store(zno).pstack(-plevel+1);
restcore:=restcore+(pstacktop-(plevel-2)) shift 1;
pstacktop:=plevel-2;
plevel:=store(zno).pstack(-pstacktop)
end; <*endproc*>
\f
<* 521, endcase *>
if -, pop(0517) then error(0061);
\f
<* 522, endwhile *>
begin
integer i;
if -, pop(0516) then error(0055)
else
begin
i:=store(zno).pstack(-pstacktop);
if i=0 then error(0055)
else
begin
pc:=i+3;
if expression(r,r1)>0 and r<>0 then
begin
restcore:=restcore-4;
pstacktop:=pstacktop+2;
pc:=i+1;
next_statement:=i+store(zno).pc extract 12
end
end
end
end; <*endwhile*>
\f
<* 523, next *>
begin
real field v,b,c;
if -, pop(store(zno).pc extract 12) then error(0022)
else
begin
v:=store(zno).pstack(-pstacktop)+storelength shift 1;
b:=pstack-pstacktop shift 1-4;
c:=b-4;
if (store(zno).v+store(zno).b-store(zno).c)*store(zno).b<=0 then
begin
store(zno).v:=store(zno).v+store(zno).b;
next_statement:=store(zno).pstack(-pstacktop-1);
restcore:=restcore-14;
pstacktop:=pstacktop+7
end
end
end; <*next*>
\f
<* 524, until *>
if -, pop(0518) then
error(0058)
else
if expression(r,r1)>0 and r=0 then
begin
next_statement:=store(zno).pstack(-pstacktop);
pstacktop:=pstacktop+2;
restcore:=restcore-4
end; <*until*>
\f
<* 525, when *>
begin
integer i;
if -, pop(0517) then error(0062)
else
if search_statement(i,0521,0517,0000)=1 then
error(0060)
else
next_statement:=i
end; <*when*>
\f
<* 526, else *>
begin
integer i;
if -, pop(0513<* if *>) then
error(0051)
else if store(zno).pstack(-pstacktop)<>1 then
error(0051)
else if search_statement(i,0519,0513,0000)=1 then
error(0052)
else
next_statement:=i
end; <*else*>
\f
<* 527, rem *>
;
<* 528, stop *>
begin
running:=false;
if currout=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
write(za(currout),<:<13><10>stop i linie :>,
<<zddd>,store(zno).this_statement,<:<13><10>:>);
end;
\f
<* 529, end *>
begin
running:=false;
if currout=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
write(za(currout),<:<13><10>end i linie :>,
<<zddd>,store(zno).this_statement,<:<13><10>:>);
end;
<* 530, return *>
goto endproc;
\f
<* 531, bye *>
bye:
begin
if killed(incarn) then
begin
if -, link(3) then
begin
killed(incarn):=false;
goto exit_bye;
end;
link(2); <* remove existing output *>
link(1);
<* killed(incarn):=false; *>
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,<:<13><10>killed by operator:>);
setposition(za(1),0,0);
end;
fileno:=0;
next_fileno:
zaindex:=zaindextable(fileno);
if zaindex<>0 and currout<>zaindex then
begin
closeza(zaindex);
end;
fileno:=fileno+1;
if fileno<=no_of_user_zones then goto next_fileno;
la(1):=userident(incarn,1);
la(2):=userident(incarn,2);
scanusercat(la,userident(incarn,3) extract 24,ia,6,0,0,0,incarn,la);
if userident(incarn,1) = long <:opera:> add 116 <*t*> and
userident(incarn,2) = long <:or:>
then oprno:=0;
userident(incarn,1):=0;
open(zhelp,0,<:term:>,0); close(zhelp,true);
monitor(48<*remove*>,zhelp,0,ia);
cpu(incarn):=cpu(incarn)+systime(1,0,r1);
realtime(incarn):=realtime(incarn)+r1;
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,<:<13><10>:>,la,<<-dddddd>,userident(incarn,3),
<: logged out at :>);
writedate(za(1),systime(5,0,r),r,9);
write(za(1),<:<13><10>time used, cpu: :>);
systime(4,cpu(incarn),r);
writedate(za(1),r,0,0);
systime(4,realtime(incarn),r);
write(za(1),<: real: :>); writedate(za(1),r,0,0);
systime(4,r1-logintime(incarn),r);
write(za(1),<: login: :>);
writedate(za(1),r,0,0);
write(za(1),<:<13><10><10>terminal :>,<<d>,incarn,<: idle<13><10>:>);
setposition(za(1),0,0);
begin
real x1,x2;
integer array c(1:6);
real array field raf;
zone z(128,1,stderror);
x1:=systime(4,logintime(incarn),x2);
open(z,4,comalacc,0);
monitor(42<*lookup*>,z,0,ia);
i:=ia(7)//11; <* 512//44=11 *>
raf:=(ia(7) mod 11)*44;
setposition(z,0,i);
if raf<>0 then
begin
inrec6(z,512);
setposition(z,0,i);
end
else
if ia(1)<i+1 then ia(1):=i+1;
outrec6(z,512);
z.raf(1):=userident(incarn,3);
for j:=1,2 do
begin
l:=la(j);
for i:=1 step 1 until 6 do
begin
c(i):=k:=l shift(-48+i*8) extract 8;
if k=0 then c(i):=32;
end;
if j=1 then
begin
z.raf(2):=real<::> add c(1) shift 12 add
c(2) shift 12 add c(3) shift 12 add c(4);
z.raf(3):=real<::> add c(5) shift 12 add
c(6) shift 12;
end
else
begin
z.raf(3):=z.raf(3) add c(1) shift 12 add c(2);
z.raf(4):=real<::> add c(3) shift 12 add c(4)
shift 12 add c(5) shift 12;
end
end;
z.raf(5):=0;
z.raf(6):=x1;
z.raf(7):=x2;
z.raf(8):=sys6;
z.raf(9):=cpu(incarn);
z.raf(10):=realtime(incarn);
z.raf(11):=r1-logintime(incarn);
if raf+44>512 then
begin
for i:=12 step 1 until 19 do z.raf(i):=real<::>;
end;
close(z,true);
ia(6):=systime(7,0,0.0);
ia(7):=ia(7)+1;
ia(9):=3;
ia(10):=44;
monitor(44<*change*>,z,0,ia);
end account;
killed(incarn):=false;
link(2);
exit_bye:
terminals(incarn,2):=0;
if incarn=mainno then mainno:=0;
if locked then
begin
begin
for i:=1 step 1 until maxincarn do
if incarn<>i and userident(i,1)<>0 then
goto someone_running;
goto stop;
someone_running:
end;
end;
goto examinqueue;
end bye;
\f
<* 532, call *>
begin
<*: integer i,j,k;
real x,y;
if expression(x,y)>0 then
begin
i:=round x;
if i>=1 and i<=10 then
begin
case i of
begin
for i:=1 step 1 until 10000 do anyactions;
begin
j:=pc+1;
for i:=1 step 1 until 10000 do
begin pc:=j; expression(x,y);
end
end;
begin
j:=pc;
for i:=1 step 1 until 10000 do
begin pc:=j;
end
end;
end;
end;
end; :*>
end;
<* 533, chain *>
begin
worki:=pc;
if expression(r,r)>0 then
begin
if store(zno).pc extract 12<>1040 then
begin
inf:=(pc+4)//2*2;
linenumber1:=store(zno).inf
end
else
linenumber1:=0;
pc:=worki;
if load1 then
begin
if exitexamine then
begin
exit(examinqueue);
open_after_exit(name);
end;
if -, error_called then load2;
if -, errorcalled then
begin
if linenumber1=0 then
begin
init_run;
next_statement:=programstart+2
end
else
if search_for_linenumber(linenumber1,worki,0)<>1 then
error(13)
else
begin
next_statement:=worki;
store(zno).esc:=0;
store(zno).err:=0;
end;
end <* if errorcalled *>
end <* if load1 *>
end <* if expression *>
end; <* chain *>
\f
<* 534, close -1- *>
begin
if store(zno).pc extract 12=1040 then
begin
fileno:=0;
next_closefile:
zaindex:=zaindextable(fileno);
if zaindex<>0 and currout<>zaindex then
begin
closeza(zaindex);
zaindextable(fileno):=0;
end;
fileno:=fileno+1;
if fileno<=no_of_user_zones then goto next_closefile;
goto exit_closefile;
end;
i:=expression(r,r);
if i<0 then goto exit_closefile;
fileno:=subscripts(1);
if fileno=-1 then goto exit_closefile;
if fileno<-1 or fileno>no_of_user_zones then
begin
error(0027);
goto exit_closefile;
end;
zaindex:=zaindextable(fileno);
\f
<* 534, close -2- *>
if currout<>zaindex and zaindex<>0 then
begin
closeza(zaindex);
zaindextable(fileno):=0;
end;
exit_closefile:
end closefile;
\f
<* 535, delete *>
begin
i:=expression(r,r1);
if i<0 then begin i:=0; goto exit_delete; end;
if -,packname(name,r) then
begin i:=0; goto exit_delete; end;
open(zhelp,0,name,0);
close(zhelp,false);
i:=monitor(76<*lookuphead and tail*>,zhelp,0,ia);
if i<>0 then goto exit_delete;
if ia(2)<>base(1) or ia(3)<>base(2) or name(1)=long <:term:> then
begin
i:=3;
goto exit_delete;
end;
findkitno(ia.laf16);
monitor(48<*remove*>,zhelp,0,ia);
userclaim(incarn,kitno,2,1):=
userclaim(incarn,kitno,2,1) + 1;
userclaim(incarn,kitno,2,2):=
userclaim(incarn,kitno,2,2)
+ (ia(8)+kittable(kitno,4)-1)//kittable(kitno,4);
exit_delete:
if i<>0 then error(if i=2 then 0100 else 0114);
end delete;
\f
<* 536, dimension -1- *>
begin
integer err,var,claim,vsize,size,type,count,i,j,k;
real r1,r2;
integer array field iaf;
integer field inf;
real field rf;
pc:=pc-1;
err:=0;
repeat
pc:=pc+1;
if expression(r1,r2)<0 then goto errorexit;
var:=r1; count:=r2;
iaf:=(var extract 9-1)*10;
type:=store(zno).nametable.iaf(1) shift (-20);
if type extract 1=1 then <* string *>
begin
size:=(subscripts(count)+1) shift (-1)
shift 1 + 4;
count:=count-1
end
else
size:=4;
claim:=size;
for i:=1 step 1 until count do
begin
k:=subscripts(i)-store(zno).lowbound+1;
if k<=0 then
begin
err:=1;
goto errorexit
end;
claim:=claim*k
end;
\f
<* 536, dimension -2- *>
if claim<=0 then
begin
err:=1;
goto errorexit
end;
vsize:=claim+count shift 1+6;
if store(zno).nametable.iaf(5)=-1 then <* not alloc. *>
begin
if -, allocate(var,vsize) then goto errorexit;
store(zno).nametable.iaf(1):=
store(zno).nametable.iaf(1) add (count shift 21);
i:=store(zno).nametable.iaf(5)+4+storelength shift 1;
j:=i-2+count shift 1;
k:=1;
for inf:=i step 2 until j do
begin
store(zno).inf:=subscripts(k)-store(zno).lowbound+1;
k:=k+1
end;
inf:=i-4; store(zno).inf:=vsize;
inf:=i-2; store(zno).inf:=count;
inf:=j+2; store(zno).inf:=size;
inf:=inf+2;
if count=0 then <* simple string *>
begin
store(zno).inf:=subscripts(1); <* max length *>
inf:=inf+2; store(zno).inf:=0 <* current length *>
end
else
begin
if type extract 1=0 then <* real array *>
begin
i:=inf+claim-2;
for rf:=inf+2 step 4 until i do
store(zno).rf:=0.0
end
\f
<* 536, dimension -3- *>
else <* string array *>
begin
set_string: i:=inf;
j:=inf+claim-4;
for iaf:=i step size until j do
begin
store(zno).iaf(0):=subscripts(count+1);
store(zno).iaf(1):=0
end
end <* string array *>
end
end <* not alloc. *>
\f
<* 536, dimension -4- *>
else
begin <* allocated allready *>
i:=store(zno).nametable.iaf(5)+storelength shift 1;
inf:=i+2;
if store(zno).inf<count or type=0 then
begin
err:=2;
goto errorexit
end;
i:=i+4;
j:=i-2+store(zno).inf shift 1;
vsize:=claim+store(zno).inf shift 1+6;
inf:=inf-2;
if store(zno).inf<vsize then
begin
err:=2;
goto errorexit
end;
k:=1;
for inf:=i step 2 until j do
begin
store(zno).inf:=subscripts(k);
k:=k+1
end;
inf:=j+2;
store(zno).inf:=size;
inf:=inf+2;
store(zno).nametable.iaf(1):=store(zno).nametable.iaf(1)
extract 21 add (count shift 21);
if type extract 1=1 then goto set_string
end
until store(zno).pc extract 12=1040;
errorexit:
if err<>0 then error(case err of (0031,0044))
end; <* dimension *>
\f
<* 537, enter *>
begin <* enter *>
copy_currout:=true;
if expression(r,r)<0 then goto entexit;
if -, packname(name,r) then goto entexit;
if openinternal(name,savedzaindex,5,9)<>0 then
goto entexit;
if exitexamine then
begin
exit(examinqueue);
open_after_exit(name);
end;
if error_called then goto entexit;
zaindex:=savedzaindex;
monitor(42<*lookup*>,za(zaindex),0,ia);
if ia(9) mod 100 < 0 or ia(9) mod 100 > 1 then
begin
error(0171);
goto entexit;
end;
entrep: <* repeat *>
case getline(za(zaindex)) of
begin
<* 1: *> ; <* empty line *>
<* 2: *> <*delete*><**>;
<* 3: *> begin
error(0007);
copy_line_out(za(zaindex))
end;
<* 4: *> insertline;
<* 5: *> copy_line_out(za(zaindex));
<* 6: *> begin
error(0007);
copy_line_out(za(zaindex))
end
end;
if errorcalled then errorout(sys7);
if getclock-entrytime>timeslice then
begin
entrytime:=getclock;
if anyactions then
begin
termno:=incarn;
insert;
exit(examinqueue);
zaindex:=savedzaindex;
end;
end;
repeatchar(za(zaindex));
readchar(za(zaindex),worki);
if worki<>25 and -, stop_att and -,killed(incarn) and zablprocerror=0 then
goto entrep;
<* until eof(zaindex) *>
fileno:=-1;
closeza(zaindex);
entexit:
copy_currout:=false;
end;
\f
<* 538, input *>
begin
fileno:=-1;
zaindex:=currin;
if store(zno).pc extract 12=1028<*file*> then
begin
i:=expression(r,r1);
if i<0 then goto exit_input;
fileno:=subscripts(1);
if fileno<-1 or fileno>no_of_user_zones then
begin
error(0027);
goto exit_input;
end;
if fileno<>-1 then
begin
sys8:=fileno;
sys6:=sys6+1;
end;
if -,beforeio(9) then goto exit_input;
if eof(fileno) then
begin
error(0139);
goto exit_input;
end;
end;
boo:=true;
k:=pagetabpos(-1) extract 8;
ch:=10;
\f
<* 538, input -2- *>
again:
if store(zno).pc extract 12=1537<* textconstant *> then
begin
expression(r,r1);
if zaindex=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
bf:=r shift (-24) extract 24;
bfx:=bf+r extract 24 - 1;
for bf:=bf step 1 until bfx do
outchar(za(zaindex),store(zno).bf extract 12);
setposition(za(1),0,0);
k:=k+r extract 24;
boo:=false;
ch:=10;
end
end
else
begin
if zaindex=1 and ch=10 then
begin
if boo then k:=k+1;
if stopatt then goto exitinput;
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,if boo then <:?:> else <::>);
setposition(za(1),0,0);
startinput;
if killed(incarn) then goto bye;
waitinlist(0,incarn);
exit(examinqueue);
if killed(incarn) then goto bye;
if attstatus then stop_att:=true;
zaindex:=1;
if stop_att then goto exit_input;
end;
\f
<* 538, input -3- *>
i:=expression(r,r1);
if i<0 then goto exit_input;
if i=1 <*numeric*> then
begin
rf:=r extract 24;
rep:
for cl:=readchar(za(zaindex),ch)
while ch=32 or ch=10 and zaindex<>1 do k:=k+1;
if ch=44 then
for cl:=readchar(za(zaindex),ch)
while ch=32 or ch=10 and zaindex<>1 do k:=k+1;
if ch=25 then
begin
eof(fileno):=true;
goto exit_input;
end;
repeatchar(za(zaindex));
k:=k-1;
if -,readreal(za(zaindex),store(zno).rf) then
begin
if zaindex<>1 then
begin
error(0066);
goto exit_input;
end;
if stopatt then goto exitinput;
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,<:/?:>);
k:=k+2;
setposition(za(1),0,0);
startinput;
if killed(incarn) then goto bye;
waitinlist(0,incarn);
exit(examinqueue);
if killed(incarn) then goto bye;
if attstatus then stop_att:=true;
zaindex:=1;
if stop_att then goto exit_input;
goto rep;
end;
repeat
k:=k+1;
readchar(za(zaindex),ch)
until ch<>32;
k:=k-1;
if ch<>10 then repeatchar(za(zaindex));
end
else
\f
<* 538, input -4- *>
begin
cl:=readchar(za(zaindex),ch);
k:=k+1;
if ch=25 then
begin
eof(fileno):=true;
goto exit_input;
end;
repeatchar(za(zaindex));
k:=k-1;
boo:=true;
len:=r extract 24 + 2;
bf:=r shift (-24) extract 24;
siz:=r1 shift (-24) extract 24;
for siz:=siz,siz-1 while siz>0 and boo do
begin
readchar(za(zaindex),ch);
k:=k+1;
if ch=10 then boo:=false
else
begin
store(zno).bf:=false add ch;
bf:=bf+1;
end;
end;
\f
<* 538, input -5- *>
if siz=0 and boo then
begin
if bf>len+store(zno).len + 1 then
store(zno).len:=(bf-len-1);
end
else
store(zno).len:=(bf-len-1);
rf:=if bf mod 2=0 then bf else bf+1;
boo:=true;
end;
end;
if zaindex=1 and boo then
begin
repeatchar(za(1));
readchar(za(1),ch);
end;
if store(zno).pc extract 12=1038 then <* nothing *>
else if store(zno).pc extract 12<>1040 then
begin
pc:=pc+1; goto again
end
else if incarn<>mainno and fileno=-1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,<:<13><10>:>);
setposition(za(1),0,0);
k:=0
end;
exit_input:
if zaindex=1 then
pagetabpos(-1):=pagetabpos(-1) shift (-8) shift 8 add k;
after_io;
end input;
\f
<* 539, let *>
begin
pc:=pc-1;
repeat pc:=pc+1; <* expression has a side effect on pc *>
until expression(0.0,0.0)<0 or store(zno).pc extract 12<>1038;
end;
\f
<* 540, mat -1- *>
begin <*outer block for mat input *>
begin
real field rf,rfa,rfb,rfc,rfbx,rfcx;
real array field raf;
integer maxa,maxb,maxc,inda,indb,indc,upi,upj,up;
integer field aiaddr,biaddr,ciaddr,aupiaddr,bupiaddr,cupiaddr,
aupjaddr,bupjaddr,cupjaddr;
\f
<* 540, mat -2- *>
boolean
procedure matinf(max,iaddr,indices,upiaddr,upjaddr,rf);
integer max,iaddr,indices,upiaddr,upjaddr,rf;
begin integer i;
integer field inf;
matinf:=true;
if store(zno).nametable(store(zno).pc extract 9*5)=-1 then
begin
error(0038);
matinf:=false;
goto exit_matinf;
end;
i:=store(zno).pc extract 9*5;
iaddr:=i-4;
indices:=store(zno).nametable(iaddr) shift (-21);
if indices=0 then
begin
error(0064);
matinf:=false;
goto exit_matinf;
end;
inf:=store(zno).nametable(i)+storelength shift 1;
max:=store(zno).inf;
upiaddr:=inf+4;
upjaddr:=inf+6;
inf:=inf+2;
rf:=inf+6+store(zno).inf shift 1;
exit_matinf:
end matinf;
\f
<* 540, mat -3-, procedure invert -1- *>
real procedure invert (w,m);
value m; integer m; array w;
begin <* von neumanns method *>
boolean skip;
integer i,q1,k,fi,j,jmax,m1,lamda;
real delta,u,alfa,eps;
real field f1,f2;
integer array f,b,l,g(1:m);
delta:=1; <*determinant*>
eps:='-100;
skip:=false;
for i:=1 step 1 until m do
begin
f(i):=0;
b(i):=0;
l(i):=i;
g(i):=i;
end;
q1:=0;
for k:=1 step 1 until m do
begin
u:=0; q1:=q1+1;
for i:=1 step 1 until m do
if b(i)=0 then
begin
f1:=4*((i-1)*m+q1);
if abs(w.f1)>abs(u) then
begin
u:=w.f1;
fi:=i;
end;
end;
if abs(u)<=eps then
begin
invert:=u;
error(0037);
goto exit_invert;
end;
delta:=delta*u;
f(k):=fi;
b(fi):=1;
\f
<* 540, mat -4-, procedure invert -2- *>
f1:=4*((fi-1)*m+q1);
w.f1:=1/u;
for i:=1 step 1 until m do
begin
f1:=4*((i-1)*m+q1);
if i<>fi then w.f1:=-w.f1/u;
if q1<>1 then
begin
skip:=true;
j:=1;
jmax:=q1-1;
end;
end;
repeat
if -,skip then
begin
j:=q1+1;
jmax:=m;
end;
skip:=false;
repeat
f1:=4*((fi-1)*m+j);
if w.f1<>0 then
begin
alfa:=w.f1;
w.f1:=alfa/u;
for i:=1 step 1 until m do
if i<>fi then
begin
f1:=4*((i-1)*m+j);
f2:=4*((i-1)*m+q1);
w.f1:=w.f1+alfa*w.f2;
end;
end;
j:=j+1;
until j>jmax
until (jmax=m) or (q1=m)
end;
\f
<* 540, mat -5-, procedure invert -3- *>
m1:=m-1;
for k:=1 step 1 until m1 do
if g(k)<>f(k) then
begin
lamda:=l(f(k));
for i:=1 step 1 until m do
begin
f1:=4*((k-1)*m+i);
f2:=4*((lamda-1)*m+i);
alfa:=w.f1;
w.f1:=w.f2;
w.f2:=alfa;
end;
delta:=-delta;
for i:=1 step 1 until m do
begin
f1:=4*((i-1)*m+f(k));
f2:=4*((i-1)*m+g(k));
alfa:=w.f1;
w.f1:=w.f2;
w.f2:=alfa;
end;
l(f(k)):=k;
l(g(k)):=lamda;
g(lamda):=g(k);
g(k):=f(k);
end;
invert:=delta;
exit_invert:
end invert;
\f
<* 540, mat -6- *>
i:=store(zno).pc extract 12;
if i<560 or i=1043 then pc:=pc+1;
\f
<* 540, mat -7-, mat print -1- *>
if i=544 <*print*> then
begin integer i,upi,upj,index,page,tab,linepos,pos,s;
real field rf;
integer field upiaddr,upjaddr;
fileno:=-1;
zaindex:=currout;
if store(zno).pc extract 12=1028<*file*> then
begin
i:=expression(r,r1);
if i<0 then goto exit_matprint;
fileno:=subscripts(1);
if fileno<-1 or fileno>no_of_user_zones then
begin
error(0027);
goto exit_matprint;
end;
if fileno<>-1 then
begin
sys8:=fileno;
sys6:=sys6+1;
end;
if -,beforeio(11) then goto exit_matprint;
end;
i:=pagetabpos(fileno);
linepos:=i extract 8;
page:=i shift (-16);
tab:=(i-page shift 16) shift (-8);
\f
<* 540, mat -8-, mat print -2- *>
again:
if store(zno).pc extract 12=1040 then goto no_matprint;
if -, matinf(i,i,index,upiaddr,upjaddr,rf) then
goto exit_matprint;
upi:=store(zno).upiaddr;
upj:=if index=1 then 1 else store(zno).upjaddr;
if index>2 then
begin
error(40);
goto no_matprint;
end;
pc:=pc+1;
k:=store(zno).pc extract 12;
for i:=1 step 1 until upi do
begin
if zaindex=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
write(za(zaindex),<:<13><10>:>);
if zaindex=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
\f
<* 540, mat -9-. ,mat print -3- *>
linepos:=0;
for j:=1 step 1 until upj do
begin
printnumber(store(zno).rf,page,pos,linepos);
linepos:=linepos+pos;
if k<>1038<*semicolon*> then
begin
s:=tab-pos;
if s<0 then s:=s-tab*((s-tab)//tab);
write(za(zaindex),sp,s);
linepos:=linepos+s;
end;
rf:=rf+4;
end;
end;
if k<>1040<*eos*> then
begin
write(za(zaindex),<:<13><10>:>);
if zaindex=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
pc:=pc+1;
goto again;
end;
no_matprint:
write(za(zaindex),<:<13><10>:>);
if zaindex=1 then setposition(za(1),0,0);
pagetabpos(fileno):=pagetabpos(fileno) shift (-8) shift 8;
exit_matprint: after_io;
end matprint
else
\f
<* 540, mat -10 -, mat input *>
if i=538<*input*> then goto mat_input
else
\f
<* 540, mat -11-, mat read -1- *>
if i=546<*read*> then
begin integer reclength,size,upi,upj,index;
boolean last,random,mode0;
integer field upiaddr,upjaddr;
real field rf,rf1,rfa;
fileno:=-1;
random:=mode0:=last:=false;
if store(zno).pc extract 12=1028<*file*> then
begin
i:=expression(r,r1);
if i<0 then goto exit_matread;
fileno:=subscripts(1);
if fileno<-1 or fileno>no_of_user_zones then
begin
error(0027);
goto exit_matread;
end;
if fileno<>-1 then
begin
sys8:=fileno;
sys6:=sys6+1;
end;
if -,beforeio(if r1>1 then 4 else 1) then goto exit_matread;
if fileno=-1 then goto next_mat;
if eof(fileno) then
begin
error(0139);
goto exit_matread;
end;
reclength:=zainf(zaindex,4) ;
i:=zainf(zaindex,3) ;
random:=i=0 or i=4;
mode0:=i=0;
rf:=0;
\f
<* 540, mat -12-, mat read -2- *>
if -,random then
begin
getzone6(za(zaindex),ia);
rf:=ia(16<*reclength*>);
if zainf(zaindex,5)<>ia(9<*segcount*>)+1 then
reclength:=512
else
last:=true;
if rf=reclength and last then
begin
eof(fileno):=true;
goto exit_matread;
end;
end
else
if r1>1 then
begin
recno:=subscripts(2);
if recno=zainf(zaindex,5)+1 then
begin
eof(fileno):=true;
goto exit_mat_read;
end;
if recno<1 or recno>zainf(zaindex,5) then
begin error(0136); goto exit_matread; end;
setposition(za(zaindex),0,(recno-1)//(512//reclength));
i:=(recno-1) mod (512//reclength);
for i:=i step -1 until 0 do
inrec6(za(zaindex),reclength);
end;
if -,random then changerec6(za(zaindex),reclength);
end;
\f
<* 540, mat -13-, mat read -3- *>
next_mat:
if -, matinf(i,i,index,upiaddr,upjaddr,rfa) then
goto exit_mat_read;
upi:=store(zno).upiaddr;
upj:=if index=1 then 1 else store(zno).upjaddr;
if index>2 then
begin
error(40);
goto exit_matread;
end;
if random and rf+4*upi*upj>reclength then
begin
error(0132);
goto exit_matread;
end;
for i:=1 step 1 until upi do
for j:=1 step 1 until upj do
begin
rf:=rf+4;
if last then
begin
if rf>reclength then
begin
eof(fileno):=true;
goto exit_matread;
end;
end;
if fileno=-1 then
begin
k:=get_next_data_item(r);
if k<0 then
begin
if -,eof(-1) then eof(-1):=true else error(0137);
goto exit_matread;
end;
if k<>1 then
begin
error(0066);
goto exit_matread;
end;
end
else
if rf>512 then
begin
rf:=4; inrec6(za(zaindex),512);
ia(9):=ia(9)+1;
if zainf(zaindex,5)=ia(9) then
begin
last:=true; reclength:=zainf(zaindex,4);
end;
end;
store(zno).rfa:=if fileno=-1 then r else za(zaindex).rf;
rfa:=rfa+4;
end;
\f
<* 540, mat -14-, mat read -4- *>
pc:=pc+1;
if store(zno).pc extract 12<>1040 then
begin pc:=pc+1; goto next_mat; end;
if -,random and fileno<>-1 then changerec6(za(zaindex),rf);
exit_matread:
after_io;
end matread
else
\f
<* 540, mat -15-, mat write -1- *>
if i=558 <*write*> then
begin
integer reclength,size,upi,upj,index;
boolean field bf,bfx,bfz;
boolean mode0;
real field rf,rfa;
integer field upiaddr,upjaddr;
i:=expression(r,r1);
if i<0 then goto exit_write;
fileno:=subscripts(1);
if fileno<0 or fileno>no_of_user_zones then
begin
error(0027);
goto exit_write;
end;
sys8:=fileno;
sys6:=sys6+1;
if -,beforeio(if r1>1 then 0 else 3) then goto exit_write;
reclength:=zainf(zaindex,4) ;
mode0:=zainf(zaindex,3) =0;
rf:=0;
if -,mode0 then
begin
getzone6(za(zaindex),ia);
rf:=ia(16<*reclength*>);
end;
recno:=0;
\f
<* 540, mat -16-, mat write -2- *>
if r1>1 and mode0 then
begin
recno:=subscripts(2);
if recno<1 then
begin error(0136); goto exit_write; end;
k:=512//reclength;
j:=(recno-1)//k;
setposition(za(zaindex),0,j);
i:=(recno-1) mod k;
if j<=(zainf(zaindex,5)-1)//k then
begin
inrec6(za(zaindex),512);
getzone6(za(zaindex),ia);
ia(9):=ia(9)-1;
ia(13):=6<*outrec*>;
ia(14):=ia(19)+i*reclength;
ia(16):=reclength;
setzone6(za(zaindex),ia);
end
else
for i:=i step -1 until 0 do outrec6(za(zaindex),reclength);
end
else
changerec6(za(zaindex),512);
if recno>zainf(zaindex,5) then zainf(zaindex,5):=recno;
nextmat:
if -, matinf(i,i,index,upiaddr,upjaddr,rfa) then
goto exit_write;
upi:=store(zno).upiaddr;
upj:=if index=1 then 1 else store(zno).upjaddr;
if index>2 then
begin
error(40);
goto exit_write;
end;
if mode0 and rf+4*upi*upj>reclength then
begin
error(0132);
goto exit_write;
end;
\f
<* 540, mat -17-, mat write -3- *>
for i:=1 step 1 until upi do
for j:=1 step 1 until upj do
begin
rf:=rf+4;
if rf>512 then
begin rf:=4; outrec6(za(zaindex),512); end;
za(zaindex).rf:=store(zno).rfa;
rfa:=rfa+4;
end;
pc:=pc+1;
if store(zno).pc extract 12<>1040 then
begin pc:=pc+1; goto next_mat; end;
if -, mode0 then changerec6(za(zaindex),rf);
exit_write:
after_io;
end matwrite
else
\f
<* 540, mat -18-, mat solve -1- *>
if i=1043 <*solve*> then
begin array field rafa,rafb,rafc;
if -, matinf(maxa,aiaddr,inda,aupiaddr,aupjaddr,rfa) then
goto exit_mat_solve;
maxa:=(maxa-rfa+aupiaddr-2) shift (-2);
upi:= store(zno).aupiaddr;
upj:=store(zno).aupjaddr;
if inda<>2 or upi<>upj then
begin
error(41);
goto exit_mat_solve;
end;
pc:=pc+2;
if -, matinf(maxc,ciaddr,indc,cupiaddr,cupjaddr,rfc) then
goto exit_mat_solve;
pc:=pc+2;
if -, matinf(maxb,biaddr,indb,bupiaddr,bupjaddr,rfb) then
goto exit_mat_solve;
up:=if indb=1 then store(zno).bupiaddr else store(zno).bupjaddr;
upj:=if indb=1 then 1 else store(zno).bupiaddr;
if upj<>1 and indc=1 or up<>upi or up*upj>maxc then
begin
error(40);
goto exit_mat_solve;
end;
store(zno).nametable(ciaddr):=
indb shift 21 add (store(zno).nametable(ciaddr) extract 21);
store(zno).cupiaddr:=if indb=1 then up else upj;
if indc<>1 then store(zno).cupjaddr:=if indb=1 then 1 else up;
rafa:=rfa-4; rafb:=rfb-4; rafc:=rfc-4;
\f
<* 540, mat -19-, mat solve -2- *>
begin integer array p(1:upi);
array b(1:upi);
trap(det0);
if -, decomposef(store(zno).rafa,p,0) then
begin
det0:
error(37);
store(zno).determinant:=0;
goto exit_mat_solve;
end;
for i:=1 step 1 until upj do
begin
tofrom(b,store(zno).rafb,4*upi);
solvef(store(zno).rafa,p,0,b);
tofrom(store(zno).rafc,b,4*upi);
rafb:=rafb+4*upi;
rafc:=rafc+4*upi;
end;
end;
r:=1;
for i:=1 step 1 until upi do
begin
rf:=rfa+4*(i-1)*(upi+1);
r:=r*store(zno).rf;
end;
store(zno).determinant:=r;
exit_mat_solve:
end mat_solve
else
\f
<* 540, mat -20-, mat con and idn *>
begin
if -,matinf(maxa,aiaddr,inda,aupiaddr,aupjaddr,rfa) then
goto exit_mat;
rf:=rfa;
upi:=store(zno).aupiaddr;
upj:=if inda=1 then 1 else store(zno).aupjaddr;
maxa:=(maxa-rfa+aupiaddr-2) shift (-2);
pc:=pc+2;
i:=store(zno).pc extract 12;
if i=3<*con*> then
begin
for i:=1 step 1 until upi do
for j:=1 step 1 until upj do
begin
store(zno).rf:=1;
rf:=rf+4;
end
end
else
if i=1029<*idn*> then
begin
for i:=1 step 1 until upi do
for j:=1 step 1 until upj do
begin
store(zno).rf:=if i=j then 1 else 0;
rf:=rf+4;
end
end
else
\f
<* 540, mat -21-, mat inv *>
if i=1030<*inv*> then
begin
pc:=pc+2;
if -, matinf(maxb,biaddr,indb,bupiaddr,bupjaddr,rfb) then
goto exit_mat;
upi:=store(zno).bupiaddr;
upj:=if indb=1 then 1 else store(zno).bupjaddr;
maxb:=upi*upj;
if upi<>upj or maxb>maxa then
begin
error(if upi<>upj then 41 else 40);
goto exit_mat;
end;
if rfa<>rfb then
begin
store(zno).nametable(aiaddr):=
indb shift 21 add (store(zno).nametable(aiaddr) extract 21);
store(zno).aupiaddr:=upi;
store(zno).aupjaddr:=upj;
for i:=1 step 1 until upi do
for j:=1 step 1 until upj do
begin
store(zno).rfa:=store(zno).rfb;
rfa:=rfa+4;
rfb:=rfb+4;
end;
end;
raf:=rf-4;
store(zno).determinant:=invert(store(zno).raf,upi);
end
else
\f
<* 540, mat -22-, mat trn *>
if i=1035<*trn*> then
begin
pc:=pc+2;
if -, matinf(maxb,biaddr,indb,bupiaddr,bupjaddr,rfb) then
goto exit_mat;
upi:=store(zno).bupiaddr;
upj:=if indb=1 then 1 else store(zno).bupjaddr;
maxb:=upi*upj;
if rfa=rfb then
begin
error(39);
goto exit_mat;
end;
if maxb>maxa then
begin
error(40);
goto exit_mat;
end;
store(zno).nametable(aiaddr):=
indb shift 21 add (store(zno).nametable(aiaddr) extract 21);
store(zno).aupiaddr:=upj;
if inda>1 then store(zno).aupjaddr:=upi;
for i:=1 step 1 until upi do
for j:=1 step 1 until upj do
begin
rf:=rfa+4*((j-1)*upi+i-1);
store(zno).rf:=store(zno).rfb;
rfb:=rfb+4;
end;
end
else
\f
<* 540, mat -23-, mat zer *>
if i=1037<*zer*> then
begin
for i:=1 step 1 until upi do
for j:=1 step 1 until upj do
begin
store(zno).rf:=0;
rf:=rf+4;
end;
end
else
if i>2048 then
begin
if store(zno).pc extract 12=1044<*parantesis*> then goto multexpr;
if -, matinf(maxb,biaddr,indb,bupiaddr,bupjaddr,rfb) then
goto exit_mat;
maxb:=store(zno).bupiaddr*(if indb=1 then 1 else store(zno).bupjaddr);
pc:=pc+1;
\f
<* 540, mat -24-, mat assign *>
if store(zno).pc extract 12=1040 then
begin <*assign*>
if maxb>maxa or indb>2 then
begin
error(40);
goto exit_mat;
end;
store(zno).nametable(aiaddr):=
indb shift 21 add (store(zno).nametable(aiaddr) extract 21);
upi:=store(zno).bupiaddr;
store(zno).aupiaddr:=upi;
upj:=if indb=1 then 1 else store(zno).bupjaddr;
if inda>1 then store(zno).aupjaddr:=upj;
for i:=1 step 1 until upi do
for j:=1 step 1 until upj do
begin
store(zno).rfa:=store(zno).rfb;
rfa:=rfa+4;
rfb:=rfb+4;
end;
end assign
else
\f
<* 540, mat -25-, mat add and sub -1- *>
if store(zno).pc extract 12=3594<*plus*> or
store(zno).pc extract 12=3595<*minus*> then
begin <*add and sub*>
pc:=pc+1;
if -, matinf(maxc,ciaddr,indc,cupiaddr,cupjaddr,rfc) then
goto exit_mat;
upi:=store(zno).cupiaddr;
store(zno).aupiaddr:=upi;
upj:=if indb=1 then 1 else store(zno).bupjaddr;
if inda>1 then store(zno).aupjaddr:=upj;
if maxb>maxa or upi<>store(zno).cupiaddr or
upj<>(if indc=1 then 1 else store(zno).cupjaddr) then
begin
error(40);
goto exit_mat;
end;
pc:=pc-1;
if store(zno).pc extract 12=3591<*plus*> then
begin
for i:=1 step 1 until upi do
for j:=1 step 1 until upj do
begin
store(zno).rfa:=store(zno).rfb+store(zno).rfc;
rfa:=rfa+4; rfb:=rfb+4; rfc:=rfc+4;
end;
end
else
\f
<* 540, mat -26-, mat add and sub -2- *>
begin
for i:=1 step 1 until upi do
for j:=1 step 1 until upj do
begin
store(zno).rfa:=store(zno).rfb-store(zno).rfc;
rfa:=rfa+4; rfb:=rfb+4; rfc:=rfc+4;
end
end
end add and sub
else
\f
<* 540, mat -29-, mat mult -1- *>
if false then
begin
multexpr:
pc:=pc+1;
i:=expression(r,r1);
pc:=pc+1;
if -, matinf(maxc,ciaddr,indc,cupiaddr,cupjaddr,rfc) then
goto exit_mat;
maxc:=store(zno).cupiaddr*(if indc=1 then 1 else store(zno).cupjaddr);
if maxc>maxa then
begin
error(40);
goto exit_mat;
end;
store(zno).nametable(aiaddr):=
indc shift 21 add (store(zno).nametable(aiaddr) extract 21);
upi:=store(zno).cupiaddr;
store(zno).aupiaddr:=upi;
upj:=if indc=1 then 1 else store(zno).cupjaddr;
if inda>1 then store(zno).aupjaddr:=upj;
for i:=1 step 1 until upi do
for j:=1 step 1 until upj do
begin
store(zno).rfa:=store(zno).rfc*r;
rfa:=rfa+4; rfc:=rfc+4;
end;
end
else
\f
<* 540, mat -28-, mat mult -2- *>
begin <*matrix mult*>
pc:=pc+1;
if -, matinf(maxc,ciaddr,indc,cupiaddr,cupjaddr,rfc) then
goto exit_mat;
up:=store(zno).bupiaddr;
upi:=store(zno).cupiaddr;
upj:=if indc=1 then 1 else store(zno).cupjaddr;
store(zno).aupiaddr:=up;
if inda>1 then store(zno).aupjaddr:=upj;
if upi*upj>maxa or (indb=1 and up<>upi) or
(indb=2 and (store(zno).bupjaddr<>upi or up<>upj)) then
begin
error(40);
goto exit_mat;
end;
store(zno).nametable(aiaddr):=
indc shift 21 add (store(zno).nametable(aiaddr) extract 21);
if rfa=rfb or rfa=rfc then
begin
error(39);
goto exit_mat;
end;
upj:=4*upj; upi:=4*upi;
rfb:=rfb-4; rfc:=rfc-4-upj;
\f
<* 540, mat -29-, mat mult -3- *>
for i:=1 step 1 until up do
for j:=4 step 4 until upj do
begin
r:=0;
rfbx:=rfb+(i-1)*upi;
rfcx:=rfc+j;
for k:=4 step 4 until upi do
begin
rfbx:=rfbx+4;
rfcx:=rfcx+upj;
r:=r + store(zno).rfbx*store(zno).rfcx;
end;
store(zno).rfa:=r;
rfa:=rfa+4;
end;
end;
end;
end;
goto exit_mat;
end declarations;
\f
<* 540, mat -30-, mat input -1- *>
matinput:
fileno:=-1;
zaindex:=currin;
if store(zno).pc extract 12=1028<*file*> then
begin
i:=expression(r,r1);
if i<0 then goto exit_mat_input;
fileno:=subscripts(1);
if fileno<-1 or fileno>no_of_user_zones then
begin
error(0027);
goto exit_mat_input;
end;
if fileno<>-1 then
begin
sys8:=fileno;
sys6:=sys6+1;
end;
if -,beforeio(9) then goto exit_mat_input;
if eof(fileno) then
begin
error(0139);
goto exit_mat_input;
end;
end;
ch:=10;
boo:=true;
\f
<* 540, mat -31-, mat input -2- *>
next_mat:
if store(zno).nametable(store(zno).pc extract 9*5)=-1 then
begin
error(0038);
goto exit_mat_input;
end;
i:=store(zno).pc extract 9*5;
index:=store(zno).nametable(i-4) shift (-21);
if index=0 or index>2 then
begin
error(if index=0 then 0064 else 0040);
goto exit_mat_input;
end;
inf:=store(zno).nametable(i) + storelength shift 1;
upiaddr:=inf+4;
upjaddr:=inf+6;
inf:=inf+2;
rfa:=inf+6+store(zno).inf shift 1;
upi:=store(zno).upiaddr;
upj:=if index=1 then 1 else store(zno).upjaddr;
index:=1;
next_i:
if zaindex=1 and ch=10 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,<:<13><10>:>);
setposition(za(1),0,0);
boo:=true;
end;
j:=1;
next_j:
\f
<* 540, mat -32-, mat input -3- *>
rep_mat:
if ch=10 and zaindex=1 then
begin
if stopatt then goto exitmatinput;
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,if boo then <:?:> else <:/?:>);
setposition(za(1),0,0);
startinput;
if killed(incarn) then goto bye;
waitinlist(0,incarn);
exit(examinqueue);
if killed(incarn) then goto bye;
if attstatus then stop_att:=true;
zaindex:=1;
if stop_att then goto exit_mat_input;
end;
for cl:=readchar(za(zaindex),ch)
while ch=32 or ch=10 and zaindex<>1 do;
if ch=44 then
for cl:=readchar(za(zaindex),ch)
while ch=32 or ch=10 and zaindex<>1 do;
if ch=25 then
begin
eof(fileno):=true;
goto exit_mat_input;
end;
repeatchar(za(zaindex));
\f
<* 540 , mat -33-. mat input -4- *>
if -,readreal(za(zaindex),store(zno).rfa) then
begin
if zaindex<>1 then goto exit_mat_input;
boo:=false;
ch:=10;
goto rep_mat;
end;
rfa:=rfa+4;
repeatchar(za(1));
readchar(za(1),ch);
boo:=false;
j:=j+1;
if j<=upj then goto next_j;
index:=index+1;
if index<=upi then goto next_i;
pc:=pc+1;
if store(zno).pc extract 12<>1040 then
begin pc:=pc+1; goto next_mat; end;
exit_mat_input:
if zaindex=1 then pagetabpos(-1):=pagetabpos(-1) shift (-8) shift 8;
after_io;
<* endof matinput*>
exit_mat:
end mat;
\f
<* 541, new *>
begin
for fileno:=0 step 1 until no_of_user_zones do
begin
zaindex:=zaindextable(fileno);
if zaindex<>0 and zaindex<>currout then
begin
closeza(zaindex);
zaindextable(fileno):=0;
end
end;
next_statement:=this_statement:=0;
worki:=currin;
workj:=currout;
init_context;
currin:=worki;
currout:=workj;
end; <* new *>
\f
<* 542, open -1- *>
begin
<* open old if output and mode<>0 *random* the file
is extended to an integral number of
slices
open new if -,(mode=3 or moe=11) then error else
create new
open hardoutput: create temp work area (which is removed
by later close)
open hardinput: create temp work area (which is removed
by later close).
send load message to filerouter.
*>
i:=expression(r,r1);
if i<0 then
begin i:=0; goto exit_openfile; end;
fileno:=subscripts(1);
mode:=subscripts(2);
i:=expression(r,r);
if i<0 then begin i:=0; goto exit_openfile; end;
if -,packname(name,r) then
begin i:=0; goto exit_openfile; end;
l:=name(1);
if currout<>1 and l=long<:lpt:> then
begin
i:=0;
goto exit_openfile;
end;
if fileno<-1 or fileno>no_of_user_zones then
begin
i:=1;
goto exit_openfile;
end;
\f
<* 542, open -2- *>
if fileno=-1 then
begin
i:=0;
goto exit_openfile;
end;
sys8:=fileno;
if mode<0 or mode>11 or mode>4 and mode<9 or r1=1 then
begin
i:=2;
goto exit_openfile;
end;
if zaindextable(fileno)<>0 then
begin
i:=3;
goto exit_openfile;
end;
output:=mode=0 or mode=2 or mode=3 or mode=10 or mode=11;
supermode:=if l=long <:lpt:> then 1 else
if l=long <:ptp:> then 2 else
if l=long <:ptr:> then 3 else
if l=long <:cdr:> then 4 else
if l=long <:mcdr:> then 5 else
if l=long <:term:> then 6 else 0;
created:=supermode>0;
if created then
begin
if output and supermode>2 or
-,output and supermode<3 or
mode <> 9 and mode <> 11 then
begin
i:=2;
goto exit_openfile;
end;
end;
\f
<* 542, open -3- *>
zaindex:=1;
for zaindex:=zaindex+1 while zainf(zaindex,1)<>0 do;
if zaindex>no_of_zones then
begin
i:=4;
goto exit_openfile;
end;
open(zhelp,0,name,0);
close(zhelp,true);
i:=monitor(76<*head and tail*>,zhelp,0,ia);
if i=0 then
begin base1:=ia(2); base2:=ia(3); end
else
begin base1:=base(1); base2:=base(2); end;
if name(1)=long<:basic:> add <*h*>104 then
begin
if name(2)<>long<:otnew:> then goto not_hotnews;
if userident(incarn,1)<>long<:opera:> add <*t*>116 or
userident(incarn,2)<>long<:or:> then goto not_hotnews;
if i<>0 or mode<>11 then goto not_hotnews;
base1:=base(1); base2:=base(2);
end;
not_hotnews:
if output and -,created and (mode=3 or mode=11) then
begin
if i<>0 or i=0 and (base1<>base(1) or base2<>base(2)) then
begin
if userclaim(incarn,stdkitno,2,2) =0 then
begin
i:=8;
goto exit_openfile;
end;
\f
<* 542, open -4- *>
if userclaim(incarn,stdkitno,2,1)=0 then
begin
i:=9;
goto exit_openfile;
end;
if -, createentry(name,stdkit,kittable(stdkitno,4),0) then
begin
i:=0;
goto exit_openfile;
end;
goto device_created;
end;
end;
if i<>0 or supermode>=4 or
i=0 and (mode=0 or mode=2 or mode=10) and (base1<>base(1) or base2<>base(2)) or
i=0 and created and (base1<>base(1) or base2<>base(2)) then
begin
if created then
begin
i:=createwrk(name,(if mode>8 then 1 else 2)+100*supermode);
if i<>0 then
begin
error(case i of (127,126,100,100)); i:=0;
goto exit_openfile;
end;
goto device_created;
end;
i:=5;
goto exit_openfile;
end;
\f
<* 542, open -5- *>
if i=0 and ia(8)<0 then
begin
i:=11;
goto exit_openfile;
end;
device_created:
zainf(zaindex,1):=incarn;
open(za(zaindex),4,name,if output then 1 shift 18 else 0);
if monitor(52<*create area process*>,za(zaindex),0,ia)>0 then
begin
i:=12;
goto exit_openfile;
end;
if created then
begin
if -,output then
begin
close(za(zaindex),true);
open(za(zaindex),0,<:primo:>,0);
carr(1):=carr(2):=-1;
carr.laf0(2):=projectnumber;
carr.laf0(3):=0;
for i:=7 step 1 until 20,25,30 do carr(i):=-1;
carr.laf0(5):=userident(incarn,1);
carr.laf0(6):=userident(incarn,2);
carr.laf2(13):=name(1);
carr.laf2(14):=name(2);
carr.laf0(11):=if l=long <:ptr:> and mode>2 then long <:tre:> else
if l=long <:ptr:> then long <:trn:> else
if l=long <:term:> then l else l;
carr.laf0(12):=0;
i:=transfer(2<*define*>,carr,30,carr,11);
if i<>0 then
begin
i:=if i=4 then 164 else if i=6 then 165 else 166;
goto exit_openfile;
end;
if carr(1)<*reply code*> <>0 then
begin
i:=carr(1);
i:=if i=3 then 167 else if i=5 then 169 else 168;
goto exit_openfile;
end;
outrec6(za(zaindex),24);
getzone6(za(zaindex),ia);
<* get state of transport *>
i:=ia(19);
getshare6(za(zaindex),ia,1);
ia(4):=7 shift 12;
ia(5):=i+2;
ia(6):=ia(5)+4;
ia(7):=ia(5);
ia(8):=ia(5)+28;
za(zaindex,1):=real<::> add 6 shift 24
add 3 shift 4 add 1 shift 8 add 1;
za(zaindex,2):=real<::> add carr(2) shift 24;
setshare6(za(zaindex),ia,1);
terminals(incarn,2):=
monitor(16<*send mess*>,za(zaindex),1,ia);
k:=zaindex;
exit(examinqueue);
zaindex:=k;
monitor(18<*wait answer*>,za(zaindex),1,ia);
close(za(zaindex),false); open(za(zaindex),4,name,if output then
1 shift 18 else 0);
for i:=3 step 1 until 9 do carr(i):=-1;
i:=transfer(6<*getstate*>,carr,9,carr,26);
if i<>0 then
begin
i:=if i=4 then 164 else if i=6 then 165 else 166;
goto removewrk;
end;
if carr(1)<*reply code*> <>0 then
begin
i:=carr(1);
i:=if i=3 then 167 else if i=5 then 169 else 168;
removewrk: ;
message primoerror;
repeat until 0=monitor(48<*remove*>,za(zaindex),0,ia);
goto exit_openfile;
end;
j:=carr(23);
i:=(carr(23)+767)//768;
j:=j mod 768;
j:=(j+2)//3*2;
transfer(8<*release*>,carr,7,carr,6);
monitor(42<*lookup*>,za(zaindex),0,ia);
ia(1):=ia(7):=i;
ia(10):=j;
message primoerror;
repeat until 0=monitor(44<*change*>,za(zaindex),0,ia);
la(1):=userident(incarn,1); la(2):=userident(incarn,2);
hardinoutput_account(la,userident(incarn,3) extract 24,supermode,i);
open(zhelp,0,name,0); close(zhelp,true);
end;
end;
i:=monitor(42<*lookup*>,zhelp,0,ia);
if i<>0 then
begin
i:=0;
error(0100);
close(za(zaindex),true);
zainf(zaindex,1):=0;
goto exit_openfile;
end;
\f
<* 542, open -7- *>
findkitno(ia.laf2);
j:=ia(9);
if -, created then
begin
if j>3 or j<0 <*saved,illegal*> or
j=3 <*random*> and -, (mode=0 or mode=4) or
j=2 <*binary*> and (mode<1 or mode>3) or
j=1 <*ascii*> and mode<9 or
j=0 <*empty*> and -, (mode=3 or mode=11) then
begin
i:=2;
close(za(zaindex),true);
zainf(zaindex,1):=0;
goto exit_openfile;
end;
end;
<* zainf(zaindex,1):=incarn; *>
zainf(zaindex,2):=kitno;
zainf(zaindex,3):=(if mode=2 then 3 else if mode=10 then 11 else mode)
+100*supermode;
zainf(zaindex,4):=ia(10) extract 12;
zainf(zaindex,5):=ia(7);
if output and -,created then
begin
j:=kittable(kitno,4);
if mode<>0 then
ia(1):=(ia(1)+j-1)//j*j;
ia(9):=if mode=0 then 3 <*bin+random*> else
if mode=2 or mode=3 then 2 <*seq + bin*> else
<*mode=10 or mode=11*> 1 <*seq + text*>;
i:=monitor(44<*change*>,zhelp,0,ia);
end;
\f
<* 542, open -8- *>
if mode=2 or mode=10 then
begin
j:=ia(10) extract 12;
ia(7):=ia(7)-1;
setposition(za(zaindex),0,ia(7));
inrec6(za(zaindex),j);
setposition(za(zaindex),0,ia(7));
getzone6(za(zaindex),ia);
ia(16):=j;
if mode=2 then
ia(13):=6<*zonestate after outrec*>
else
begin
setzone6(za(zaindex),ia);
inf:=j; i:=za(zaindex).inf;
k:=i shift (-8) extract 8;
i:=i shift (-16);
ia(13):=3<*after print*>;
ia(14):=ia(19)+j-2;
ia(12):=if i=25 then 1 else
if k=25 then 1 shift 8 add i else
1 shift 8 add i shift 8 add k;
end;
setzone6(za(zaindex),ia);
end;
if mode=3 then outrec6(za(zaindex),0);
if mode=1 then inrec6(za(zaindex),0);
zaindextable(fileno):=zaindex;
i:=0;
exit_openfile:
if fileno<>-1 then
sys6:=sys6+1;
eof(fileno):=false;
if i<>0 then
error(if i=11 then 162 else if i=12 then 163 else i+0118);
end openfile;
\f
<* 543, page *>
begin integer f;
f:=-1;
if store(zno).pc extract 12=1028<*file*> then
begin
i:=expression(r,r1);
if i<0 then goto exit_page;
f:=subscripts(1);
if f<-1 or f>no_of_user_zones then
begin
error(0027);
goto exit_page;
end;
end;
pc:=pc+1;
i:=expression(r,r1);
if i<0 then goto exit_page;
if r<0 or r>132 then
begin
error(0008);
goto exit_page;
end;
pagetabpos(f):=round r shift 16 add (pagetabpos(f) extract 16);
exit_page:
end page;
\f
<* 544, print *>
begin
rep544:
if spoolfull(incarn) then
begin
termno:=incarn;
insert;
exit(examinqueue);
goto rep544
end;
begin
integer linepos,page,tab,pos;
real r1,r2;
boolean field bf,bfx;
fileno:=-1;
zaindex:=currout;
if store(zno).pc extract 12=1028<*file*> then
begin
i:=expression(r1,r2);
if i<0 then goto no_print;
fileno:=subscripts(1);
if fileno<-1 or fileno>no_of_user_zones then
begin
error(0027);
goto no_print;
end;
if fileno<>-1 then
begin
sys8:=fileno;
sys6:=sys6+1;
end;
if -,before_io(11) then goto no_print;
end;
i:=pagetabpos(fileno);
linepos:=i extract 8;
page:=i shift (-16);
tab:=(i-page shift 16) shift (-8);
if zaindex=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
\f
<* 544, print -2- *>
again:
i:=expression(r1,r2);
if i=-2 then goto exit_print;
if i=-1 then
begin
pos:=0;
if store(zno).pc extract 12=1036 <* using *> then
begin
pc:=pc+1;
i:=using(r1);
goto if i<0 then exit_print else print_string;
end
else
if store(zno).pc extract 12=0550 then
begin
pc:=pc+1;
i:=expression(r1,r2);
if i=-2 then goto exit_print;
l:=r1;
l:=l mod (if page=0 then 132 else page);
if l-1>=linepos then
begin
pos:=l-1-linepos;
write(za(zaindex),sp,pos);
end;
end
end
else
if i=1 then
begin
if -,printnumber(r1,page,pos,linepos) then
goto exit_print;
end
else
\f
<* 544, print -3- *>
print_string:
begin
pos:=if i=2 then 5 else
if i=3 then 1 else r1 extract 24;
if i=4<*text*> then
begin
if page>0 and pos>page-linepos then
begin
bf:=(r1 shift (-24) extract 24 ) - 1;
j:=bf;
bfx:=bf+pos-1;
for bf:=bf+1 while store(zno).bf extract 12<>13
and bf<=bfx do;
if bf<bfx+1 then pos:=bfx-j;
end;
end;
testline(page,pos,linepos);
case i of
begin
;
write(za(zaindex),if r1=1 then <:true :> else <:false:>);
outchar(za(zaindex),r1 shift (-24) extract 24);
begin
bf:=r1 shift (-24) extract 24;
bfx:=bf+pos-1;
for bf:=bf step 1 until bfx do
begin
i:=store(zno).bf extract 12;
if i=13 then
begin
linepos:=0;
if zaindex=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
end;
outchar(za(zaindex),i);
end;
end;
end cases;
\f
<* 544, print -4- *>
end;
linepos:=linepos+pos;
i:=store(zno).pc extract 12;
if i=1039<*comma*> then
begin
j:=linepos mod tab;
j:=tab-j;
write(za(zaindex),sp,j);
linepos:=linepos+j;
end
else
if i<>1038<*semicolon*> then
begin
linepos:=0;
write(za(zaindex),<:<13><10>:>);
if zaindex=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
end;
if i=1038 or i=1039 then
begin
bf:=pc+1;
if store(zno).bf extract 12=1040 then goto exit_print;
end;
if store(zno).pc extract 12<>1040 then
begin pc:=pc+1; goto again; end;
\f
<* 544, print -5- *>
exit_print:
if zaindex=1 then setposition(za(1),0,0);
pagetabpos(fileno):=page shift 8 add tab shift 8 add linepos;
if fileno<>-1 then after_io;
no_print:
end;
end print;
\f
<* 545, randomize *>
begin
real x;
systime(1,0,x);
store(zno).rnd:=x extract 24;
end randomize;
\f
<* 546, read *>
begin integer reclength,size,upi,upj,index;
boolean random,mode0,boo,last;
real r2;
integer field upiaddr,upjaddr,len;
real field rf,rf1,rfa;
boolean field bfz,bfx;
procedure nextrecord;
begin
inrec6(za(zaindex),512);
ia(9):=ia(9)+1;
if zainf(zaindex,5)=ia(9) then
begin
last:=true;
reclength:=zainf(zaindex,4);
end;
end nextrecord;
last:=false;
fileno:=-1;
if store(zno).pc extract 12=1028<*file*> then
begin
i:=expression(r,r1);
if i<0 then goto exit_read;
fileno:=subscripts(1);
if fileno<-1 or fileno>no_of_user_zones then
begin
error(0027);
goto exit_read;
end;
if fileno<>-1 then
begin
sys8:=fileno;
sys6:=sys6+1;
end;
if -,beforeio(if r1>1 then 4 else 1) then goto exit_read;
if fileno=-1 then goto next_data;
if eof(fileno) then
begin
error(0139);
goto exit_read;
end;
reclength:=zainf(zaindex,4) ;
i:=zainf(zaindex,3) ;
random:=i=0 or i=4;
mode0:=i=0;
rf:=0;
\f
<* 546, read -2- *>
if -,random then
begin
getzone6(za(zaindex),ia);
rf:=ia(16<*reclength*>);
if zainf(zaindex,5)>ia(9<*segcount*>) then
reclength:=512
else
last:=true;
if rf=reclength and last then
begin
eof(fileno):=true;
goto exit_read;
end;
end
else
if r1>1 then
begin
recno:=subscripts(2);
if recno=zainf(zaindex,5)+1 then
begin
eof(fileno):=true;
goto exit_read;
end;
if recno<1 or recno>zainf(zaindex,5) then
begin error(0136); goto exit_read; end;
setposition(za(zaindex),0,(recno-1)//(512//reclength));
i:=(recno-1) mod (512//reclength);
for i:=i step -1 until 0 do
inrec6(za(zaindex),reclength);
end;
if -,random then changerec6(za(zaindex),reclength);
end;
\f
<* 546, read -3- *>
if fileno=-1 then
begin
next_data:
i:=expression(r,r1);
if i<0 then goto exit_read;
j:=get_next_data_item(r2);
if j<0 then
begin
error(0137);
goto exit_read;
end;
if i=1 and j<>1 or i=2 and j<>4 then
begin
error(66);
goto exit_read;
end;
if i=1<*numeric*> then
begin
rf1:=r extract 24;
store(zno).rf1:=r2;
end
else
begin
len:=r extract 24 + 2;
bfx:=r shift (-24) extract 24;
size:=r1 shift (-24) extract 24;
bfz:=r2 shift (-24) extract 24;
i:=r2 extract 24;
i:=if i<size then i else size;
basicmove(store(zno),bfx,bfz,i);
if size=i then
begin
if bfx>len + store(zno).len + 1 then
store(zno).len:=(bfx-len-1);
end
else
store(zno).len:=(bfx-len-1);
end;
if store(zno).pc extract 12=1040 then goto exit_read;
pc:=pc+1;
goto next_data;
end;
\f
<* 546, read -4- *>
again:
i:=expression(r,r1);
if i<0 then goto exit_read
else
if i=2<*text*> then
begin
len:=r extract 24 + 2;
j:=bfx:=r shift (-24) extract 24;
size:=r1 shift (-24) extract 24;;
bfz:=rf;
boo:=true;
while size>0 and boo do
begin
bfz:=bfz+1;
if bfz>reclength then
begin
if random or last then
begin
if last then
begin
eof(fileno):=true;
goto exit_read;
end;
error(132);
goto exit_read;
end;
bfz:=1;
nextrecord;
end;
\f
<* 546, read -5- *>
boo:=za(zaindex).bfz;
if boo extract 12=0 then boo:=false else
begin
store(zno).bfx:=boo;
bfx:=bfx+1;
boo:=true;
end;
if boo then size:=size-1;
end;
if size=0 then
begin
if bfx>len + store(zno).len + 1 then
store(zno).len:=(bfx-len-1)
end
else
store(zno).len:=(bfx-len-1);
if boo and bfz=512 then
begin
bfz:=0;
nextrecord;
end;
if boo then
for bfz:=bfz+1 while za(zaindex).bfz extract 12<>0 do
begin
if bfz>=reclength then
begin
if random or last then
begin
if last then
begin
eof(fileno):=true;
goto exit_read;
end;
error(132);
goto exit_read;
end;
bfz:=1;
nextrecord;
end;
end;
rf:=if bfz mod 2=0 then bfz else bfz+1;
end
else
begin <*numeric*>
if rf+4>reclength and (random or last) then
begin
if last then
begin
eof(fileno):=true;
goto exit_read;
end;
error(0132); goto exit_read;
end;
\f
<* 546, read -6- *>
rf:=rf+4;
if rf>512 then
begin rf:=4; nextrecord; end;
rf1:=r extract 24;
store(zno).rf1:=za(zaindex).rf;
end;
if store(zno).pc extract 12<>1040 then
begin pc:=pc+1; goto again; end;
if -,random then changerec6(za(zaindex),rf);
exit_read:
after_io;
end readfile;
\f
<* 547, rename *>
begin
long array old,new(1:2);
i:=expression(r,r1);
if i<0 then begin i:=0; goto exit_rename; end;
if -,packname(old,r) then
begin i:=0; goto exit_rename; end;
pc:=pc+1;
i:=expression(r,r1);
if i<0 then begin i:=0; goto exit_rename; end;
if -,packname(new,r) then
begin i:=0; goto exit_rename; end;
open(zhelp,0,old,0);
close(zhelp,false);
i:=monitor(76<*head and tail*>,zhelp,0,ia);
if i=0 then
begin
if ia(2)<>base(1) or ia(3)<>base(2) then i:=1;
end
else if i=3 or i=6 then i:=1;
if i<>0 then goto exit_rename;
ia.lf4:=new(1); ia.lf8:=new(2);
i:=monitor(46<*rename*>,zhelp,0,ia);
if i=6 then i:=4;
exit_rename:
if i<>0 then error(case i of(0111,0100,0112,0113));
end rename;
\f
<* 548, restore *>
begin
inf:=pc+1;
data_line:=0;
worki:=store(zno).inf; <* linenumber *>
if worki<>0 then
begin
if search_for_linenumber(worki,data_line,0)=3 then
error(0013)
else
begin
pc:=data_line+2;
data_byte:=if store(zno).pc extract 12=551 then 3
else 0
end
end
end; <* restore *>
\f
<* 549, save *>
begin
if expression(r,r)>0 then
begin
if packname(name,r) then
begin
if name(1)=long <:ptp:> then
begin
error(0025);
goto endsave;
end;
if openinternal(name,savedzaindex,3,3)=0 then
begin
if exitexamine then
begin
exit(examinqueue);
open_after_exit(name);
end;
zaindex:=savedzaindex;
begin <* inner block *>
integer totsize,progsize,datasize,tablsize;
integer array field iaf;
integer field inf;
procedure outsegment(first,last);
value first,last; integer first,last;
begin
iaf:=first;
while last-iaf>=512 do
begin
outrec6(za(zaindex),512);
after_io;
if errorcalled then goto exitsave;
tofrom(za(zaindex),store(zno).iaf,512);
iaf:=iaf+512
end;
if iaf<>last then
begin
outrec6(za(zaindex),last-iaf);
after_io;
if errorcalled then goto exitsave;
tofrom(za(zaindex),store(zno).iaf,last-iaf);
end
end; <* outsegment *>
\f
<* 549, save - 2 - *>
<* calculate sizes *>
progsize:=lastprogram-programstart;
datasize:=storelength shift 1+2-lastdata;
tablsize:=lastname*10+pstacktop shift 1;
totsize:=progsize+datasize+tablsize;
outrec6(za(zaindex),100);
after_io;
if errorcalled then goto exitsave;
for inf:=2 step 2 until 30 do
za(zaindex).inf:=case inf//2 of
<* 2*> (-1, <* revision of save, used by load *>
<* 4*> totsize,
<* 6*> progsize,
<* 8*> datasize,
<*10*> tablsize,
<*12*> lastname,
<*14*> pstacktop,
<*16*> plevel,
<*18*> this_statement,
<*20*> next_statement,
<*22*> data_line,
<*24*> data_byte,
<*26*> sys7,
<*28*> sys8,
<*30*> sys16);
iaf:=30;
tofrom(za(zaindex).iaf,store(zno).fcttable,70);
outsegment(programstart,lastprogram);
outsegment(last_data-2,store_length shift 1);
outsegment(pstack-pstacktop shift 1,
name_table+lastname*10);
end; <* inner block *>
\f
<* 549, save - 3 - *>
exitsave:
closeza(zaindex);
if errorcalled then
begin
open(zhelp,0,name,0);
if monitor(42<*lookup*>,zhelp,0,ia)=0 then
begin
ia(9):=0;
monitor(44<*change*>,zhelp,0,ia)
end;
close(zhelp,true)
end
end <* if openinternal *>
end <* if packname *>
end; <* if expression *>
endsave:
end; <* save *>
\f
<* 550, tab *>
begin integer f,page;
f:=-1;
if store(zno).pc extract 12=1028<*file*> then
begin
i:=expression(r,r1);
if i<0 then goto exit_tab;
f:=subscripts(1);
if f<-1 or f>no_of_user_zones then
begin
error(0027);
goto exit_tab;
end;
end;
pc:=pc+1;
i:=expression(r,r1);
if i<0 then goto exit_tab;
page:=pagetabpos(f) shift (-16);
if r<1 or r>page then
begin
error(0008);
goto exit_tab;
end;
pagetabpos(f):=page shift 8 add round r shift 8
add (pagetabpos(f) extract 8);
exit_tab:
end tab;
\f
<* 551, data *>
; <* no action *>
<* 552, def *>
store(zno).fcttable(store(zno).pc extract 9):=
this_statement;
\f
<* 553, delay *>
begin
pc:=pc+1;
i:=expression(r,r1);
if i<0 or r<=0 then goto exit_delay;
if r>60 then r:=60;
zaindex:=1;
for zaindex:=zaindex+1 while zainf(zaindex,1)<>0 do;
if zaindex>no_of_zones then
begin
error(0122);
goto exit_delay;
end;
zainf(zaindex,1):=incarn;
open(za(zaindex),2,<:clock:>,0);
getshare6(za(zaindex),ia,1);
ia(4):=0;
ia(5):=r;
setshare6(za(zaindex),ia,1);
terminals(incarn,2):=
monitor(16<*send mess*>,za(zaindex),1,ia);
savedzaindex:=zaindex;
exit(examinqueue);
zaindex:=savedzaindex;
monitor(18<*wait answ*>,za(zaindex),1,ia);
close(za(zaindex),true);
zainf(zaindex,1):=0;
exit_delay:
end delay;
\f
<* 554, exec *>
begin
integer i;
i:=search_code_and_var(program_start+2,0514,
store(zno).pc extract 12);
if i=0 then
error(0046)
else
if restcore<4 then error(0020)
else
begin
restcore:=restcore-4;
pstacktop:=pstacktop+2;
if pstack-pstacktop shift 1<lastprogram then
move_tables;
store(zno).pstack(-pstacktop+2):=plevel;
store(zno).pstack(-pstacktop+1):=next_statement;
plevel:=pstacktop;
next_statement:=i
end
end; <*exec*>
\f
<* 555, gosub *>
gosub:
begin
inf:=(pc+2) shift (-1) shift 1;
if search_for_linenumber(store(zno).inf,i,1)<>1 then
error(0013)
else
if restcore<4 then error(0020)
else
begin
restcore:=restcore-4;
pstacktop:=pstacktop+2;
if pstack-pstacktop shift 1<lastprogram then
movetables;
store(zno).pstack(-pstacktop+2):=plevel;
store(zno).pstack(-pstacktop+1):=next_statement;
plevel:=pstacktop;
next_statement:=i
end
end; <*gosub*>
\f
<* 556, goto *>
goto_statement:
begin
integer field inf;
inf:=(pc+2) shift (-1) shift 1;
if search_for_linenumber(store(zno).inf,i,1)<>1 then
error(0013)
else
next_statement:=i;
end; <*goto*>
\f
<* 557, on *>
begin
integer i,count,number;
real x,y;
count:=store(zno).pc extract 12;
pc:=pc+1;
if count=0 then
begin
if store(zno).pc extract 12=1027 <* esc *> then
store(zno).esc:=this_statement
else
store(zno).err:=this_statement
end
else
if expression(x,y)>0 then
begin
number:=entier x;
pc:=pc+1; <* skip then *>
if number>0 and number<=count then
begin
i:=store(zno).pc extract 12;
pc:=pc-1+number shift 1;
if i=0555 then
goto gosub
else
goto goto_statement
end
end
end; <*on*>
\f
<* 558, write *>
begin
integer reclength,size,upi,upj,index;
boolean field bf,bfx,bfz;
boolean mode0;
real field rf,rfa;
integer field upiaddr,upjaddr;
i:=expression(r,r1);
if i<0 then goto exit_write;
fileno:=subscripts(1);
if fileno<0 or fileno>no_of_user_zones then
begin
error(0027);
goto exit_write;
end;
sys8:=fileno;
sys6:=sys6+1;
if -,beforeio(if r1>1 then 0 else 3) then goto exit_write;
reclength:=zainf(zaindex,4) ;
mode0:=zainf(zaindex,3) =0;
rf:=0;
if -,mode0 then
begin
getzone6(za(zaindex),ia);
rf:=ia(16<*reclength*>);
end;
recno:=0;
\f
<* 558, write -2- *>
if r1>1 and mode0 then
begin
recno:=subscripts(2);
if recno<1 then
begin error(0136); goto exit_write; end;
k:=512//reclength;
j:=(recno-1)//k;
setposition(za(zaindex),0,j);
i:=(recno-1) mod k;
if j<=(zainf(zaindex,5)-1)//k then
begin
inrec6(za(zaindex),512);
getzone6(za(zaindex),ia);
ia(9):=ia(9)-1;
ia(13):=6<*outrec*>;
ia(14):=ia(19)+i*reclength;
ia(16):=reclength;
setzone6(za(zaindex),ia);
end
else
for i:=i step -1 until 0 do outrec6(za(zaindex),reclength);
end
else
changerec6(za(zaindex),512);
if recno>zainf(zaindex,5) then zainf(zaindex,5):=recno;
again:
i:=expression(r,r1);
if i=-2 then goto exit_write;
if i=-1 then
else
if i=4<*text*> then
begin
size:=r extract 24;
bf:=r shift (-24) extract 24;
bfx:=bf+size;
i:=size+(if size mod 2=1 then 1 else 2);
if rf+i>reclength and mode0 then
begin
error(0132);
goto exit_write;
end;
\f
<* 558, write -3- *>
bfz:=rf; rf:=rf+size+1;
for bf:=bf step 1 until bfx do
begin
bfz:=bfz+1;
if bfz>512 then
begin rf:=rf-512; bfz:=1; outrec6(za(zaindex),512); end;
if bf<bfx then za(zaindex).bfz:=store(zno).bf;
end;
za(zaindex).bfz:=false;
if rf mod 2=1 then
begin
rf:=rf+1; bfz:=bfz+1;
za(zaindex).bfz:=false;
end;
end
else
if i=3 then <* char *>
begin
if rf+2>reclength and mode0 then
begin
error(132);
goto exit_write
end;
rf:=rf+2;
if rf>512 then
begin
rf:=2; outrec6(za(zaindex),512);
end;
bfz:=rf-1;
za(zaindex).bfz:=false add (r shift (-24) extract 7);
bfz:=bfz+1; za(zaindex).bfz:=false
end else
begin <*numeric*>
if rf+4>reclength and mode0 then
begin
error(0132);
goto exit_write;
end;
rf:=rf+4;
if rf>512 then
begin rf:=4; outrec6(za(zaindex),512); end;
za(zaindex).rf:=r;
end;
if store(zno).pc extract 12<>1040 then
begin pc:=pc+1; goto again; end;
\f
<* 558, write -4- *>
if -,mode0 then changerec6(za(zaindex),rf);
exit_write:
after_io;
end writefile;
\f
<* 559, boundlow *>
begin
real x,y;
pc:=pc + 1;
if expression(x,y)>0 then
store(zno).lowbound:=entier x;
end boundlow;
\f
<* 560, lookup *>
begin
if currout=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
i:=expression(r,r1);
if i<0 then goto exit_lookup;
if -,packname(name,r) then goto exit_lookup;
open(zhelp,0,name,0); close(zhelp,false);
i:=monitor(76<*head and tail*>,zhelp,0,ia);
if i<>0 then
begin
write(za(currout),name,<: unknown:>);
goto exit_lookup;
end;
if -,(base(1)=ia(2) and base(2)=ia(3)) then
write(za(currout),<:protected against output:<13><10>:>);
write(za(currout),sp,12-write(za(currout),name));
if ia(8)<0 then write(za(currout),sp,6) else
write(za(currout),<<ddddd>,ia(8),sp,1);
write(za(currout),sp,9-write(za(currout),ia.laf16));
writedate(za(currout),systime(6,ia(13),r),r,9);
for i:=14 step 1 until 17 do
begin
if ia(i)<4096 and ia(i)>=0 then
write(za(currout),<<-ddddddd>,ia(i))
else
write(za(currout),<<-ddd>,ia(i) shift (-12) extract 12,
<:.:>,<<zdd>,ia(i) extract 12);
end tail;
\f
<* 560, lookup -2- *>
exit_lookup:
write(za(currout),<:<13><10>:>);
if currout=1 then setposition(za(1),0,0);
end lookup;
\f
<* 561, create *>
begin long array name,kitname(1:2);
integer size,reclength;
i:=expression(r,r1);
if i<0 then goto exit_create;
if -,packname(name,r) then goto exit_create;
pc:=pc+1;
i:=expression(r,r1);
if i=1 then
begin
kitname(1):=stdkit(1);
kitname(2):=stdkit(2);
end
else
if i=4 then
begin
if -,packname(kitname,r) then goto exit_create;
pc:=pc+1;
i:=expression(r,r1);
end;
if i<0 then goto exit_create;
size:=r;
if store(zno).pc extract 12=1040 then reclength:=0 else
begin
pc:=pc+1;
i:=expression(r,r1);
if i=-2 then goto exit_create;
if i=-1 then r:=0;
reclength:=if entier r mod 2=0 then r else r+1;
end;
createentry(name,kitname,size,reclength);
exit_create:
end create;
\f
<* 562, changesize *>
begin
integer more,segm,size;
boolean random;
i:=expression(r,r1);
if i<0 then begin i:=0; goto exit_changesize; end;
if -,packname(name,r) then
begin i:=0; goto exit_changesize; end;
pc:=pc+1;
i:=expression(r,r1);
if i<0 then
begin i:=0; goto exit_changesize; end;
size:=r;
if size<0 then
begin
i:=4;
goto exit_changesize;
end;
open(zhelp,0,name,0);
close(zhelp,false);
i:=monitor(76<*look head and tail*>,zhelp,0,ia);
if i<>0 then goto exit_changesize;
if ia(2)<>base(1) or ia(3)<>base(2) then
begin
i:=3;
goto exit_changesize;
end;
findkitno(ia.laf16);
random:=ia(10) shift (-12) extract 1=0;
segm:=if -,random then size else
(size-1)/(512//ia(10) extract 12) + 1;
slices:=(segm-1+kittable(kitno,4))//kittable(kitno,4);
more:=slices-(ia(8)+kittable(kitno,4)-1)//kittable(kitno,4);
i:=userclaim(incarn,kitno,2,2);
\f
<* 562, changesize -2- *>
if i<more then
begin
i:=1;
goto exit_changesize;
end;
monitor(42<*lookup*>,zhelp,0,ia);
ia(1):=segm;
if random then ia(8):=size;
i:=monitor(44<*change*>,zhelp,0,ia);
if i<>0 then
begin
i:=2;
goto exit_changesize;
end;
userclaim(incarn,kitno,2,2):=
userclaim(incarn,kitno,2,2) - more;
exit_changesize:
if i=6 then i:=3;
if i<>0 then error(case i of(0110,0100,0109,0108));
end changesize;
\f
<* 563, copy -1- *>
begin <*outer block *>
<* copy from till size of till changed to size of from
copy from new create new
copy from hardoutput: send convert message to filerouter
copy hardinput till: size of till changed to maxclaim,
load message to filerouter,
size of fill is modified
copy hardinput new: create new=maxclaim,
load message to filerouter
size of new if modified.
copy hardinput hardoutput: send loadconv message to filerouter
*>
begin
boolean hardinput,hardoutput;
integer array totail(1:10),fromtail(1:17);
i:=expression(r,r1);
if i<0 then begin i:=0; goto exit_copy2; end;
if -,packname(la,r) then
begin i:=0; goto exit_copy2; end;
zaindex:=1;
for zaindex:=zaindex+1 while zainf(zaindex,1)<>0 do;
if zaindex>=no_of_zones then
begin
i:=10;
goto exit_copy;
end;
\f
<* 563, copy -2- *>
pc:=pc+1;
i:=expression(r,r1);
if i<0 then begin i:=0; goto exit_copy2; end;
if -,packname(name,r) then
begin i:=0; goto exit_copy2; end;
if la(1)=name(1) and la(2)=name(2) then
begin
i:=18;
goto exit_copy;
end;
savedzaindex:=zaindex;
for savedzaindex:=savedzaindex+1 while zainf(savedzaindex,1)<>0 do;
if savedzaindex>no_of_zones then
begin
i:=10;
goto exit_copy;
end;
zainf(zaindex,1):=incarn;
zainf(savedzaindex,1):=incarn;
open(za(savedzaindex),4,name,0);
open(za(zaindex),4,la,0);
l:=la(1);
hardinput:=(l=long<:ptr:> or
l=long<:cdr:> or
l=long<:mcdr:> or l=long<:term:>);
if l=long<:term:> then link(3);
l:=name(1);
hardoutput:=l=long <:lpt:> or l=long<:ptp:>;
i:=monitor(76<*head and tail*>,za(zaindex),0,fromtail);
if i=0 then
begin base1:=fromtail(2); base2:=fromtail(3); end;
if i<>0 and -, hardinput then goto exit_copy;
if hardoutput then
begin
siz:=fromtail(8);
mode:=fromtail(16) mod 100;
i:=if hardinput then 1 else 3;
goto after_prepare_output;
end;
\f
<* 563, copy -3- *>
i:=monitor(42<*lookup*>,za(savedzaindex),0,totail);
if i=0 then
begin <* if to is outsides bases then create *>
monitor(76<*head and tail*>,za(savedzaindex),0,ia);
if ia(2)<>base(1) or ia(3)<>base(2) then i:=3;
end;
if i=0 then findkitno(totail.laf2) else kitno:=stdkitno;
if hardinput then
begin
slices:=(createsize+kittable(kitno,4)-1)//kittable(kitno,4);
fromtail(8):=slices*kittable(kitno,4);
fromtail(13):=systime(7,0,0.0);
fromtail(14):=
fromtail(15):=0;
fromtail(16):=1;
fromtail(17):=0;
end
else
begin
slices:=(fromtail(8)+kittable(kitno,4)-1)//kittable(kitno,4);
if i=0 then
slices:=slices-(totail(1)-1+kittable(kitno,4))//kittable(kitno,4);
if userclaim(incarn,kitno,2,2) < slices then
begin
i:=1;
goto exit_copy;
end;
end;
if i=0 then
begin
for j:=1,6 step 1 until 10 do totail(j):=fromtail(j+7);
i:=monitor(44<*changeentry*>,za(savedzaindex),0,totail);
if i<>0 then
begin
i:=2;
goto exit_copy;
end;
end
else
\f
<* 563, copy -4- *>
begin
if userclaim(incarn,kitno,2,1) < 1 then
begin
i:=4;
goto exit_copy;
end;
totail(1):=fromtail(8);
tofrom(totail.laf2,stdkit,8);
totail(6):=systime(7,0,0.0);
for j:=7 step 1 until 10 do totail(j):=fromtail(j+7);
i:=monitor(40<*createentry*>,za(savedzaindex),0,totail);
mode:=totail(9) mod 100;
if i<>0 then
begin
if i=4 then i:=2 else if i=6 then i:=5;
goto exit_copy;
end;
monitor(50<*perm*>,za(savedzaindex),3,totail);
userclaim(incarn,kitno,2,1):=
userclaim(incarn,kitno,2,1) - 1;
end;
i:=if hardinput then 2 else 4;
end block;
after_prepare_output:
sys6:=sys6+2;
if i=1 <*hardinput and hardoutput*> then
begin
close(za(savedzaindex),true);
close(za(zaindex),true); open(za(zaindex),0,<:primo:>,0);
r:=real name(1);
l:=la(1);
supermode:=if l=long<:ptr:> then 3 else
if l=long<:cdr:> then 4 else
if l=long <:mcdr:> then 5 else 6;
i:=createwrk(name,1+100*supermode);
if i<>0 then
begin
i:=0;
goto exitcopy;
end;
carr(1):=carr(2):=-1;
carr.laf0(2):=projectnumber;
carr.laf0(3):=0;
for i:=7 step 1 until 20,25,30 do carr(i):=-1;
carr.laf0(5):=userident(incarn,1);
carr.laf0(6):=userident(incarn,2);
carr.laf2(13):=name(1);
carr.laf2(14):=name(2);
l:=la(1);
carr.laf0(11):=if l=long <:ptr:> then long <:tre:> else
if l=long <:term:> then l else l;
carr.laf0(12):=0;
i:=transfer(2<*define*>,carr,30,carr,11);
if i<>0 then
begin
i:=if i=4 then 11 else if i=6 then 12 else 13;
goto removework;
end;
if carr(1)<*reply code*> <>0 then
begin
i:=carr(1);
i:=if i=3 then 14 else if i=5 then 16 else 15;
goto removework;
end;
outrec6(za(zaindex),24);
getzone6(za(zaindex),ia);
i:=ia(19);
<*get state of transport *>
getshare6(za(zaindex),ia,1);
ia(4):=7 shift 12;
ia(5):=i+2;
ia(6):=ia(5)+4;
ia(7):=ia(5);
ia(8):=ia(5)+28;
za(zaindex,1):=real<::> add 6 shift 24
add 3 shift 4 add 1 shift 8 add 1;
za(zaindex,2):=real<::> add carr(2) shift 24;
setshare6(za(zaindex),ia,1);
terminals(incarn,2):=
monitor(16<*send mess*>,za(zaindex),1,ia);
k:=zaindex;
exit(examinqueue);
zaindex:=k;
monitor(18<*wait answer*>,za(zaindex),1,ia);
close(za(zaindex),false); open(za(zaindex),4,name,0);
for i:=3 step 1 until 9 do carr(i):=-1;
i:=transfer(6<*getstate*>,carr,9,carr,26);
if i<>0 then
begin
i:=if i=4 then 11 else if i=6 then 12 else 13;
goto removework;
end;
if carr(1)<*reply code*> <>0 then
begin
i:=carr(1);
i:=if i=3 then 14 else if i=5 then 15 else 16;
removework: ;
message primoerror;
repeat until 0=monitor(48<*remove*>,za(zaindex),0,ia);
goto exit_copy;
end;
j:=carr(23);
i:=(carr(23)+767)//768;
j:=j mod 768;
j:=(j+2)//3*2;
transfer(8<*release*>,carr,7,carr,6);
monitor(42<*lookup*>,za(zaindex),0,ia);
ia(1):=ia(7):=i;
ia(10):=j;
message primoerror;
repeat until 0=monitor(44<*change*>,za(zaindex),0,ia);
l:=long r;
la(1):=userident(incarn,1); la(2):=userident(incarn,2);
hardinoutput_account(la,userident(incarn,3) extract 24,supermode,i);
siz:=i;
carr(1):=carr(2):=-1;
carr.laf0(2):=projectnumber;
carr.laf0(3):=0;
for i:=7 step 1 until 20,25,30 do carr(i):=-1;
carr.laf0(5):=userident(incarn,1);
carr.laf0(6):=userident(incarn,2);
carr.laf0(11):=name(1);
carr.laf0(12):=name(2);
carr.laf2(13):=if l=long<:lpt:> then long<:lp:>
else long<:tpe:>;
carr.laf2(14):=0;
i:=transfer(2<*define*>,carr,30,carr,11);
if i<>0 then
begin
i:=if i=4 then 11 else if i=6 then 12 else 13;
goto removework;
end;
if carr(1)<*reply code*> <>0 then
begin
i:=carr(1);
i:=if i=3 then 14 else if i=5 then 15 else 16;
goto removework;
end;
la(1):=userident(incarn,1); la(2):=userident(incarn,2);
hardinoutput_account(la,userident(incarn,3) extract 24,
if la(1)=long<:lpt:> then 1 else 2,siz);
primoindex:=0;
for primoindex:=primoindex+1 while primoia(primoindex,1)<>0 do;
if primoindex>bufs then
begin error(170); goto exit_copy;
end;
getzone6(zprimo(primoindex),ia);
i:=ia(19);
getshare6(zprimo(primoindex),ia,1);
ia(4):=7 shift 12;
ia(5):=i+2;
ia(6):=ia(5)+4;
ia(7):=ia(5);
ia(8):=ia(5)+28;
zprimo(primoindex,1):=real <::> add 6 shift 24
add 3 shift 4 add 1 shift 8 add 1;
zprimo(primoindex,2):=real<::> add carr(2) shift 24;
setshare6(zprimo(primoindex),ia,1);
primoia(primoindex,1):=
monitor(16)send messag:(zprimo(primoindex),1,ia);
primoia(primoindex,2):=carr(13);
primoia(primoindex,3):=userident(incarn,3);
primoia(primoindex,4):=base(1);
primoia(primoindex,5):=base(2);
primoia(primoindex,6):=((siz-1+kittable(stdkitno,4))//kittable(stdkitno,4))
shift 12 + stdkitno;
primoia(primoindex,7):=supermode shift 12 + siz;
primola(primoindex,1):=name(1);
primola(primoindex,2):=name(2);
primola(primoindex,3):=userident(incarn,1);
primola(primoindex,4):=userident(incarn,2);
i:=0; goto exit_copy;
end;
if i=2 <*hardinput *> then
begin
<*now input from device*>
close(za(savedzaindex),true);
open(za(savedzaindex),0,<:primo:>,0);
carr(1):=carr(2):=-1;
carr.laf0(2):=projectnumber;
carr.laf0(3):=0;
for i:=7 step 1 until 20,25,30 do carr(i):=-1;
carr.laf0(5):=userident(incarn,1);
carr.laf0(6):=userident(incarn,2);
carr.laf2(13):=name(1);
carr.laf2(14):=name(2);
l:=la(1);
carr.laf0(11):=if l=long <:ptr:> and mode<2 then long <:tre:> else
if l=long <:ptr:> then long <:trn:> else
if l=long <:term:> then l else l;
carr.laf0(12):=0;
i:=transfer(2<*define*>,carr,30,carr,11);
if i<>0 then
begin
i:=if i=4 then 11 else if i=6 then 12 else 13;
goto exit_copy;
end;
if carr(1)<*reply code*> <>0 then
begin
i:=carr(1);
i:=if i=3 then 14 else if i=5 then 16 else 15;
goto exit_copy;
end;
outrec6(za(savedzaindex),24);
<* get state of transport *>
getzone6(za(savedzaindex),ia);
i:=ia(19);
getshare6(za(savedzaindex),ia,1);
ia(4):=7 shift 12;
ia(5):=i+2;
ia(6):=ia(5)+4;
ia(7):=ia(5);
ia(8):=ia(5)+22;
za(savedzaindex,1):=real<::> add 6 shift 24
add 3 shift 4 add 1 shift 8 add 1;
za(savedzaindex,2):=real<::> add carr(2) shift 24;
setshare6(za(savedzaindex),ia,1);
terminals(incarn,2):=
monitor(16<*send mess*>,za(savedzaindex),1,ia);
k:=zaindex;
exit(examinqueue);
zaindex:=k;
monitor(18<*wait answer*>,za(savedzaindex),1,ia);
close(za(savedzaindex),false); open(za(savedzaindex),4,name,0);
for i:=3 step 1 until 9 do carr(i):=-1;
i:=transfer(6<*getstate*>,carr,9,carr,26);
if i<>0 then
begin
i:=if i=4 then 11 else if i=6 then 12 else 13;
goto exit_copy;
end;
if carr(1)<*reply code*> <>0 then
begin
i:=carr(1);
i:=if i=3 then 14 else if i=5 then 16 else 15;
goto exit_copy;
end;
j:=carr(23);
i:=(carr(23)+767)//768;
j:=j mod 768;
j:=(j+2)//3*2;
transfer(8<*release*>,carr,7,carr,6);
monitor(42<*lookup*>,za(savedzaindex),0,ia);
ia(1):=ia(7):=i;
bf:=20; ia.bf:=false add j;
message primoerror;
repeat until 0=monitor(44<*change*>,za(savedzaindex),0,ia);
la(1):=userident(incarn,1); la(2):=userident(incarn,2);
hardinoutput_account(la,userident(incarn,3) extract 24,if l=long<:ptr:> then 3 else
if l=long<:cdr:> then 4 else
if l=long<:mcdr:> then 5 else 6,i);
i:=0; goto exit_copy;
end;
\f
<* 563, copy -7- *>
if i=3 <*hardoutput *> then
begin <*copy filename todevice*>
carr(1):=carr(2):=-1;
carr.laf0(2):=projectnumber;
carr.laf0(3):=0;
for i:=7 step 1 until 20,25,30 do carr(i):=-1;
carr.laf0(5):=userident(incarn,1);
carr.laf0(6):=userident(incarn,2);
carr.laf0(11):=la(1);
carr.laf0(12):=la(2);
carr.laf2(13):=if name(1)=long<:lpt:> then long<:lp:>
else if mode>1 then long <:tpn:> else long<:tpe:>;
carr.laf2(14):=0;
i:=transfer(2<*define*>,carr,30,carr,11);
if i<>0 then
begin
i:=if i=4 then 11 else if i=6 then 12 else 13;
goto exit_copy;
end;
if carr(1)<*reply code*> <>0 then
begin
i:=carr(1);
i:=if i=3 then 14 else if i=5 then 15 else 16;
goto exit_copy;
end;
transfer(8<*release*>, carr,7,carr,6);
la(1):=userident(incarn,1); la(2):=userident(incarn,2);
hardinoutput_account(la,userident(incarn,3) extract 24,
if name(1)=long<:lpt:> then 1 else 2,siz);
i:=0; goto exit_copy;
end;
\f
<* 563, copy -8- *>
userclaim(incarn,kitno,2,2):=
userclaim(incarn,kitno,2,2) - slices;
for j:=inrec6(za(zaindex),0) while j>2 and zablprocerror=0 do
begin
inrec6(za(zaindex),512);
outrec6(za(savedzaindex) ,512);
tofrom(za(savedzaindex),za(zaindex),512);
end;
i:=0;
exit_copy:
if i<>10 and i<>18 then
begin
close(za(savedzaindex),true);
zainf(savedzaindex,1):=0;
close(za(zaindex),true);
zainf(zaindex,1):=0;
end;
if i<>0 then
error(case i of(0116,0100,0117,0115,0118,0117,142,143,146,152,
164,165,166,167,168,169,151,173));
exit_copy2:
end copy;
\f
<* 564, claim *>
search_or_claim:
begin <* outer block *>
<* scans the catalog and output entries with
specified base*>
begin
boolean look;
real sec;
integer i,j,k,segments,entries,sum,length,segm,
baselow,baseup;
integer field ifsegm,ifshortclock;
long array field laf,lafname;
zone z(128,1,stderror);
zaindex:=currout;
pc:=pc-1;
i:=store(zno).pc extract 12;
look:=i=565;
pc:=pc+1;
i:=expression(r,r1);
if i=-2 then goto exit_search_or_claim;
if i<>-1 then
begin
if -,packname(la,r) then goto exit_search_or_claim;
if openinternal(la,zaindex,1,11) <> 0 then
goto exit_search_or_claim;
sys6:=sys6+1;
end;
\f
<* 564, claim -2- *>
baselow:=base(1);
baseup :=base(2);
ifsegm:=16;
ifshortclock:=26;
lafname:=6;
segments:=entries:=0;
if zaindex=1 then setposition(za(1),0,0);
if look then
begin
open(z,4,<:catalog:>,0);
for length:=1 step 1 until catalogsize do
begin
inrec6(z,34);
if z.if2 shift (-12)<>4095<*4095=cleared entry*> then
begin
if z.if4=baselow and z.if6=baseup then
begin <*matching bases*>
if -,(zaindex<>1 and z.lafname(1)=long<:lpt:>) and
z.ifsegm>=0 then
begin
segm:=z.ifsegm;
segments:=segments+segm;
entries:=entries+1;
if zaindex=1 then write(za(1),<<zdd>,incarn);
write(za(zaindex),sp,12-write(za(zaindex),z.lafname),
<<ddddd>,segm,sp,1);
write(za(zaindex),sp,9-write(za(zaindex),z.laf16));
writedate(za(zaindex),systime(6,z.ifshortclock,sec),sec,9);
\f
<* 564, claim -3- *>
for inf:=28 step 2 until 34 do
begin
if z.inf<4096 and z.inf>=0 then
write(za(zaindex),<<-ddddddd>,z.inf)
else
write(za(zaindex),<<-ddd>,z.inf shift (-12) extract 12,
<:.:>,<<zdd>,z.inf extract 12);
end tail;
write(za(zaindex),<:<13><10>:>);
if zaindex=1 and spoolfull(incarn) then
begin
error(0172);
goto exitsearch;
end;
if zaindex=1 then setposition(za(1),0,0);
end not lpt;
end wanted base;
end non-blind entry;
end catalog scan;
if zaindex=1 then write(za(1),<<zdd>,incarn);
write(za(zaindex),
<:<13><10>:>,sp,12,<<ddddd>,segments,<: segments<13><10>:>);
if zaindex=1 then setposition(za(1),0,0);
close(z,true);
end look;
if zaindex=1 then write(za(1),<<zdd>,incarn);
write(za(zaindex),<:<13><10>used:<13><10>:>);
if zaindex=1 then setposition(za(1),0,0);
\f
<* 564, claim -4- *>
sum:=0;
entries:=0;
for i:=0 step 1 until maxkit do
begin
if kittable(i,1)<>0 <*0=removed kit*> then
begin
j:=userclaim(incarn,i,1,1)-userclaim(incarn,i,2,1);
k:=userclaim(incarn,i,1,2)-userclaim(incarn,i,2,2);
if j<>0 or k<>0 then
begin <* entries or slices <> 0 *>
segm:=k*kittable(i,4);
entries:=entries+j;
sum:=sum+segm;
laf:=i*8;
if zaindex=1 then write(za(1),<<zdd>,incarn);
write(za(zaindex),sp,10-write(za(zaindex), kittable.laf));
write(za(zaindex),<:::>,<<dddd>,k,<: slices *:>,
<<ddd>,kittable(i,4),<: = :>,
<<dddddd>,segm,<: segments:>,
<< dddd>,j,<: entries<13><10>:>);
if zaindex=1 then setposition(za(1),0,0);
end;
end;
end;
if zaindex=1 then write(za(1),<<zdd>,incarn);
write(za(zaindex),sp,22,<:total = :>,<<dddddd>,sum,<: segments:>,
<< dddd>,entries,<: entries<13><10><10>free:<13><10>:>);
if zaindex=1 and spoolfull(incarn) then
begin
error(0172);
goto exitsearch;
end;
if zaindex=1 then setposition(za(1),0,0);
sum:=0;
entries:=0;
for i:=0 step 1 until maxkit do
begin
if kittable(i,1)<>0 <*0=removed kit*> then
begin
if userclaim(incarn,i,2,1)<>0 or userclaim(incarn,i,2,2)<>0 then
begin <* entries or slices <> 0*>
length:=userclaim(incarn,i,2,2);
segm:=length*kittable(i,4);
j:=userclaim(incarn,i,2,1);
\f
<* 564, claim -5- *>
entries:=entries+j;
sum:=sum+segm;
laf:=i*8;
if zaindex=1 then write(za(1),<<zdd>,incarn);
write(za(zaindex),sp,10-write(za(zaindex), kittable.laf));
write(za(zaindex),<:::>,<<dddd>,length,<: slices *:>,
<<ddd>,kittable(i,4),<: = :>,
<<dddddd>,segm,<: segments:>,
<< dddd>,j,<: entries<13><10>:>);
if zaindex=1 then setposition(za(1),0,0);
end;
end;
end;
if zaindex=1 then write(za(1),<<zdd>,incarn);
write(za(zaindex),sp,22,<:total = :>,<<dddddd>,sum,<: segments:>,
<< dddd>,entries,<: entries<13><10>:>);
end declarations;
exitsearch:
fileno:=-1;
if zaindex=1 then setposition(za(1),0,0);
if zaindex <> currout then closeza(zaindex);
exit_search_or_claim:
end search_or_claim;
\f
<* 565, search *>
goto search_or_claim;
\f
<* 566, scope *>
begin boolean running,up;
integer inc,sl,claimed,projectno;
integer array b(1:2);
long array initials,name(1:2);
up:=store(zno).pc extract 12=1041; <*mater*>
pc:=pc+1;
i:=expression(r,r1);
if i<0 then begin i:=0; goto exit_scope; end;
if -,packname(initials,r) then
begin i:=0; goto exit_scope; end;
pc:=pc+1;
i:=expression(r,r1);
if i<0 then begin i:=0; goto exit_scope; end;
if -,packname(name,r) then
begin i:=0; goto exit_scope; end;
projectno:=userident(incarn,3);
inc:=maxincarn+1;
running:=logged_in(initials,projectno,inc);
i:=scanusercat(initials,projectno,b,2,0,0,0,incarn,la);
if i<>0 then goto exit_scope;
if -,(base(1)<=b(1) and base(2)>=b(2)) then
begin
i:=2;
goto exitscope;
end;
if -,up then monitor(72<*set catbase*>,ownprocess,0,b);
\f
<* 566, scope -2- *>
open(zhelp,0,name,0); close(zhelp,true);
i:=monitor(76<*head and tail*>,zhelp,0,ia);
if i=0 then
begin
if up and base(1)=ia(2) and base(2)=ia(3) or
-,up and b(1)=ia(2) and b(2)=ia(3) then
begin
i:=6;
goto exit_scope;
end;
end;
if -,up then monitor(72<*set catbase*>,ownprocess,0,base);
if up then monitor(72<*set catbase*>,ownprocess,0,b);
i:=monitor(42<*lookup*>,zhelp,0,ia);
if i<>0 then
begin
i:=3;
goto exit_scope;
end;
if -,findkitno(ia.laf2) then goto exit_scope;
sl:=(ia(1)+kittable(kitno,4)-1)//kittable(kitno,4);
if -,running then
scanusercat(initials,projectno,ia,4,kitno,0,0,inc,la);
if up then
begin
if userclaim(incarn,kitno,2,1)<1 then
begin
i:=4;
goto exit_scope;
end;
\f
<* 566, scope -3- *>
if userclaim(incarn,kitno,2,2)<sl then
begin
i:=5;
goto exit_scope;
end;
userclaim(incarn,kitno,2,1):=
userclaim(incarn,kitno,2,1) - 1;
userclaim(incarn,kitno,2,2):=
userclaim(incarn,kitno,2,2) - sl;
userclaim(inc,kitno,2,1):=
userclaim(inc,kitno,2,1) + 1;
userclaim(inc,kitno,2,2):=
userclaim(inc,kitno,2,2) + sl;
end
else
begin
if userclaim(inc,kitno,2,1)<1 then
begin
i:=4;
goto exit_scope;
end;
if userclaim(inc,kitno,2,2)<sl then
begin
i:=5;
goto exit_scope;
end;
\f
<* 566, scope -4- *>
userclaim(incarn,kitno,2,1):=
userclaim(incarn,kitno,2,1)+ 1;
userclaim(incarn,kitno,2,2):=
userclaim(incarn,kitno,2,2) + sl;
userclaim(inc,kitno,2,1):=
userclaim(inc,kitno,2,1) - 1;
userclaim(inc,kitno,2,2):=
userclaim(inc,kitno,2,2) - sl;
end;
if -,running then
scanusercat(initials,projectno,ia,6,kitno,0,0,inc,la);
if up then
monitor(74<*set entrybase*>,zhelp,0,base)
else
monitor(74<*set entrybase*>,zhelp,0,b);
i:=0;
exit_scope:
monitor(72<*set catbase*>,ownprocess,0,base);
if i<>0 then
error(i+0199);
end scope;
\f
<* 567, newclaim *>
begin
boolean running;
long array initials,kitname(1:2);
integer projectno,entries, inc, claimed,slices;
i:=expression(r,r1);
if i<0 then begin i:=0; goto exit_newclaim; end;
if -,packname(initials,r) then
begin i:=0; goto exit_newclaim; end;
pc:=pc+1;
i:=expression(r,r1);
if i=1 then
begin
kitname(1):=stdkit(1);
kitname(2):=stdkit(2);
end
else
if i=4 then
begin
if -,packname(kitname,r) then
begin i:=0; goto exit_newclaim; end;
pc:=pc+1;
i:=expression(r,r1);
end;
if i<0 then goto exit_newclaim;
slices:=r;
pc:=pc+1;
i:=expression(r,r1);
if i=-2 then
begin i:=0; goto exit_newclaim; end;
if i=-1 then r:=0;
entries:=r;
projectno:=userident(incarn,3);
\f
<* 567, newclaim -2- *>
if -,findkitno(kitname) then
begin
i:=5;
goto exit_newclaim;
end;
inc:=maxincarn+1;
running:=logged_in(initials,projectno,inc);
if entries>0 then
begin
i:=userclaim(incarn,kitno,2,1);
if i<entries then
begin
i:=6;
goto exit_newclaim;
end;
end;
if slices>0 then
begin
i:=userclaim(incarn,kitno,2,2);
if i<slices then
begin
i:=7;
goto exit_newclaim;
end;
end;
i:=scan_usercat(initials,projectno,ia,3,kitno,
entries,slices ,incarn,la);
\f
<* 567, newclaim -3- *>
if i<>0 then
begin
i:=i+1;
goto exit_newclaim;
end;
if -,(base(1)<=ia(1) and base(2)>=ia(2)) then
begin
i:=1;
goto exit_newclaim;
end;
userclaim(inc,kitno,1,1):=
userclaim(inc,kitno,1,1)+entries;
userclaim(inc,kitno,1,2):=
userclaim(inc,kitno,1,2) + slices;
userclaim(inc,kitno,2,1):=
userclaim(inc,kitno,2,1)+entries;
userclaim(inc,kitno,2,2):=
userclaim(inc,kitno,2,2) + slices;
i:=0;
exit_newclaim:
if i<>0 then
error(i+0205);
end newclaim;
\f
<* 568, scanclaim *>
begin
zaindex:=currout;
i:=expression(r,r1);
if i=-2 then goto exit_scanclaim;
if i<>-1 then
begin
if -,packname(la,r) then goto exit_scanclaim;
if openinternal(la,zaindex,1,11)<>0 then
goto exit_scanclaim;
sys6:=sys6+1;
end;
if zaindex=1 then setposition(za(1),0,0);
la(1):=userident(incarn,1);
la(2):=userident(incarn,2);
scanusercat(la,userident(incarn,3) extract 24,ia,5,0,0,0,incarn,la);
fileno:=-1;
if zaindex=1 then setposition(za(1),0,0);
if zaindex <> currout then closeza(zaindex);
exit_scanclaim:
end scanclaim;
\f
<* 569, digits *>
begin integer f;
f:=-1;
if store(zno).pc extract 12=1028<*file*> then
begin
i:=expression(r,r1);
if i<0 then goto exit_digits;
f:=subscripts(1);
if f<-1 or f>no_of_user_zones then
begin
error(0027);
goto exit_digits;
end;
end;
pc:=pc+1;
i:=expression(r,r1);
if i<0 then goto exit_digits;
if r<1 or r>11 then
begin
error(0015);
goto exit_digits;
end;
printdigits(f):=r;
exit_digits:
end digits;
\f
<* 570, printdate *>
begin integer linepos,page,tab,pos,date,sec,format;
fileno:=-1;
zaindex:=currout;
if store(zno).pc extract 12=1028<*file*> then
begin
i:=expression(r,r1);
if i<0 then goto exit_printdate;
fileno:=subscripts(1);
if fileno<-1 or fileno>no_of_user_zones then
begin
error(0027);
goto exit_printdate;
end;
if fileno<>-1 then
begin
sys8:=fileno;
sys6:=sys6+1;
end;
if -,before_io(11) then goto exit_printdate;
end;
i:=pagetabpos(fileno);
linepos:=i extract 8;
page:=i shift (-16);
tab:=(i-page shift 16) shift (-8);
i:=expression(r,r1);
if i<0 then goto exit_printdate;
date:=r;
pc:=pc+1;
i:=expression(r,r1);
sec:=r;
if i<0 then goto exit_printdate;
\f
<* 570, printdate -2- *>
pc:=pc+1;
i:=expression(r,r1);
if i<0 then goto exit_printdate;
format:=r;
if format shift (-3) extract 1=0 then
begin
pos:=8;
if format shift (-1) extract 1=1 then pos:=pos+9 else
if format extract 1=1 then pos:=pos+6;
end
else
begin
pos:=8;
if format shift (-1) extract 1=1 then pos:=pos+7 else
if format extract 1=1 then pos:=pos+5;
end;
if format shift (-5) extract 2<>0 then pos:=pos+1;
if zaindex=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
if pos>page-linepos then
begin
linepos:=0;
write(za(zaindex),<:<13><10>:>);
end;
writedate(za(zaindex),date,sec,format);
i:=store(zno).pc extract 12;
\f
<* 570, printdate -3- *>
if i=1039 <*comma*> then
begin
i:=tab-pos;
if i<0 then i:=i-tab*((i-tab)//tab);
write(za(zaindex),sp,i);
linepos:=linepos+i;
end
else
if i<>1038<*semicolon*> then
begin
linepos:=0;
write(za(zaindex),<:<13><10>:>);
end;
if zaindex=1 then setposition(za(1),0,0);
pagetabpos(fileno):=page shift 8 add tab shift 8 add linepos;
if fileno<>-1 then after_io;
exit_printdate:
end printdate;
\f
<* 571, printeps *>
begin integer f;
f:=-1;
if store(zno).pc extract 12=1028<*file*> then
begin
i:=expression(r,r1);
if i<0 then goto exit_printeps;
f:=subscripts(1);
if f<-1 or f>no_of_user_zones then
begin
error(0027);
goto exit_printeps;
end;
end;
pc:=pc+1;
i:=expression(r,r1);
if i<0 then goto exit_printeps;
if r<'-100 or r>1 then
begin
error(0015);
goto exit_printeps;
end;
printeps(f):=r;
exit_printeps:
end printeps;
\f
<*572, kit off -1- *>
begin
integer devno;
real array docname,auxname(1:2);
if incarn<>mainno or
userident(incarn,1)<>long<:opera:> add<*t*>116 or
userident(incarn,2)<>long<:or:> then
begin
error(0026);
goto exit_kitoff;
end;
i:=expression(r,r1);
if i<0 then goto exit_kit_off;
devno:=r;
if get_dev_or_name(devno,docname,auxname) then
error(155)
else
begin
integer i,k;
zone z(512,1,stderror);
integer array ia(1:21);
integer array field iaf;
iaf:=0;
for i:=1 step 1 until 4 do
ia(17+i):=docname.iaf(i);
k:=monitor(108<*delete bs*>,z,0,ia);
if k<>0 then
begin
error(if k<>5 then 155 else 156);
goto exit_kit_off;
end
else
begin
for k:=monitor(110<*delete entries*>,z,0,ia) while k=3 do;
if k<>0 then
begin
error(157);
goto exit_kit_off;
end;
end;
\f
<* 572, kit off -2- *>
kittable(kitno,1):=0;
for i:=1 step 1 until maxincarn do
userclaim(i,kitno,1,1):=
userclaim(i,kitno,1,2):=
userclaim(i,kitno,2,1):=
userclaim(i,kitno,2,2):=0;
end;
exit_kit_off:
end kit off;
\f
<* 573, kit on -1- *>
begin
integer devno,i,k,catsize,slicelength,errors,updats,b1,b2;
real array docname(1:2);
integer array ia(1:21),updat(1:max_on_userkit,1:4);
zone zcat(128,1,stderror), zdisc(5*128,1,stderror);
long array field laf;
real array field raf;
integer array field iaf;
boolean procedure connect(devno, name);
integer devno;
real array name;
begin
integer repcount;
integer array zdescr(1:20);
real array field zname;
procedure repeatproc(z, s, b);
zone z;
integer s, b;
begin
repcount := repcount + 1;
if repcount < 3 and s = 1 shift 5 then
goto try_once_more;
b := 512;
connect := true;
setposition(za(1),0,0);
write (za(1),<<zdd>,incarn,<:intervention on :>, devno,<:<13><10>:>);
setposition(za(1),0,0);
end procedure repeatproc;
repcount := 0;
connect := false;
try_once_more:
begin
zone device(128, 1, repeatproc);
zname := 2;
i := 1; open(device, 0, string name(increase(i)), 1 shift 5);
i := monitor(54 <*create peripheral proc*>, device, devno, zdescr);
\f
<* 573, kit on -2- *>
if i <> 0 then
begin
error(if i=5 then 159 else 158);
connect := true;
end
else
begin
inrec6(device, 0); <*try to read a block *>
getzone6(device, zdescr);
name(1) := zdescr.zname(1);
name(2) := zdescr.zname(2);
end;
end;
end procedure connect;
procedure usercat_update;
begin boolean running;
integer i,j,k,inc,projectno;
integer field inf,infx,infz;
long array field laf;
real array field raf;
long array uid(1:2);
zone z(128,1,stderror);
open(z,4,usercat,0);
k:=0;
for i:=inrec6(z,2), inrec6(z,2) while z.if2<1 do
k:=k+1;
setposition(z,0,k);
swoprec6(z,512); inf:=2;
\f
<* 573, kit on -3- *>
projectloop:
infx:=inf+2;
if z.infx=8388607 then goto finis;
inf:=inf+z.inf extract 12;
projectno:=z.infx;
userloop:
if z.inf=0 then
begin swoprec6(z,512); inf:=2; end;
if z.inf shift (-12)<>2 then
begin
if z.inf shift (-12)=0 then goto projectloop;
inf:=inf+z.inf extract 12;
goto userloop;
end;
infx:=inf+10;
i:=z.infx; <*lower base*>
infx:=infx+2;
infz:=infx+2;
j:=i+z.infx+z.infz-2; <*upper base*>
for k:=1 step 1 until updats do
if updat(k,1)=i and updat(k,2)=j then goto user_found;
inf:=inf+z.inf extract 12;
goto userloop;
user_found:
laf:=inf;
uid(1):=z.laf(1);
uid(2):=z.laf(2);
\f
<* 573, kit on -4- *>
loop:
inf:=inf+z.inf extract 12;
if z.inf=0 then
begin swoprec6(z,512); inf:=2; end;
i:=z.inf shift (-12);
if i=0 then goto projectloop else
if i=2 then goto userloop else
if i<>6 then goto loop;
raf:=inf;
if docname(1)<>z.raf(1) or docname(2)<>z.raf(2) then goto loop;
running:=logged_in(uid,projectno,inc);
infx:=inf+12;
i:=z.infx shift (-12);
j:=z.infx extract 12;
if running then
begin
userclaim(inc,kitno,1,1):=i;
userclaim(inc,kitno,1,2):=j;
end;
i:=i-updat(k,3);
j:=j-updat(k,4);
infx:=infx-2;
z.infx:=i shift 12 + j extract 12;
if running then
begin
userclaim(inc,kitno,2,1):=i;
userclaim(inc,kitno,2,2):=j;
end;
\f
<* 573, kit on -5- *>
if updats=1 then goto finis;
if k<>updats then
begin
updat(k,1):=updat(updats,1);
updat(k,2):=updat(updats,2);
updat(k,3):=updat(updats,3);
updat(k,4):=updat(updats,4);
end;
updats:=updats-1;
goto loop;
finis:
close(z,true);
end usercat_update;
\f
<* 573, kit on -6- *>
if incarn<>mainno or
userident(incarn,1)<>long<:opera:> add <*t*>116 or
userident(incarn,2)<>long<:or:> then
begin
error(0026);
goto exit_kiton;
end;
i:=expression(r,r1);
if i<0 then goto exit_kit_on;
devno:=r;
laf:=6;
iaf:=0;
docname(1):=0;
if connect(devno,docname) then
begin
goto exit_kit_on;
end;
open(zdisc,4,docname,0);
<*read chain*>
inrec6(zdisc,2560);
getzone6(zdisc,ia);
for i:=2 step 1 until 5 do
docname.iaf(i-1):=ia(i):=zdisc.iaf(i+7);
setzone6(zdisc,ia);
monitor(54<*create ph proc*>,zdisc,devno,ia);
slicelength:=zdisc.iaf(14);
monitor(8<*reserve*>,zdisc,i,ia);
k:=monitor(102<*prepare bs*>,zdisc,i,ia);
if k<>0 then
begin
error(158);
goto exit_kit_on;
end;
\f
<* 573, kit on -7- *>
open(zcat,4,zdisc.laf,0);
catsize:=zdisc.iaf(8)*15;
errors:=0;
updats:=0;
for j:=1 step 1 until catsize do
begin
inrec6(zcat,34);
if zcat.iaf(1)<>-1 then
begin
k:=monitor(104<*insert entry*>,zdisc,0,zcat.iaf);
if k<>0 then errors:=errors+1
else
if zcat.iaf(8)>=0 then
begin
b1:=zcat.iaf(2); b2:=zcat.iaf(3);
for i:=1 step 1 until updats do
if updat(i,1)=b1 and updat(i,2)=b2 then goto updat_found;
if updats=max_on_userkit then
begin
error(0160);
goto exit_kiton;
end;
i:=updats:=updats+1;
updat(i,1):=b1; updat(i,2):=b2;
updat(i,3):=updat(i,4):=0;
updat_found:
updat(i,3):=updat(i,3)+1;
updat(i,4):=updat(i,4)+(zcat.iaf(8)-1+slicelength)//slicelength;
end;
end;
end;
close(zcat,true);
close(zdisc,true);
if errors<>0 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,<:<13><10>:>,<<d>,errors,<: entries rejected<10>:>);
setposition(za(1),0,0);
end;
\f
<* 573, kit on -8- *>
for i:=1 step 1 until 4 do
ia(17+i):=docname.iaf(i);
k:=monitor(106<*prepare bs*>,zcat,0,ia);
if k<>0 then
begin
error(158);
goto exit_kit_on;
end;
i:=1; setposition(za(1),0,0);
i:=write(za(1),<<zdd>,incarn,string docname(increase(i)));
write(za(1),false add 32,12-i,<: mounted on :>,<< ddd>,devno,<:<13><10>:>);
setposition(za(1),0,0);
get_dev_or_name(devno,docname,la.raf0); <*get kitno*>
raf:=kitno*8;
kittable.raf(1):=docname(1);
kittable.raf(2):=docname(2);
kittable(kitno,4):=slicelength;
if docname.laf0(1)=stdkit(1) and
docname.laf0(2)=stdkit(2) then stdkitno:=kitno;
usercat_update;
exit_kit_on:
end kit on;
\f
<* 574, alfalock *>
begin
pc:=pc+1; <* skip = *>
if expression(r,r1)>0 then
alfalock:=if r=0 then 0 else 1
end;
\f
<*
513 if
514 proc
515 for
516 while
517 case
518 repeat
519 endif
520 endproc
521 endcase
522 endwhile
523 next
524 until
525 when
526 else
527 rem
528 stop
529 end
530 return
531 bye
532 call
533 chain
534 close
535 delete
536 dim
537 enter
538 input
539 let
540 mat
541 new
542 open
543 page
544 print
545 randomize
546 read
547 rename
548 restore
549 save
550 tab
551 data
552 def
553 delay
554 exec
555 gosub
556 goto
557 on
558 write
559 boundlow
560 lookup
561 create
562 changesize
563 copy
564 claim
565 search
566 scope
567 newclaim
568 scanclaim
569 digits
570 printdate
571 printeps
572 kitoff
573 kiton
574 alfalock
*>
\f
end;
<*: if testbit2 then
begin
write(out,<:**statistics**:>,nl,1,
<: blocksread after caseout: :>,
blocksread,nl,2);
setposition(out,0,0);
end;:*>
if currout<>1 and zablprocerror=1 then
begin
fileno:=-1;
closeza(currout);
kitno:=zainf(currout,2);
monitor(42<*lookup*>,za(currout),0,ia);
monitor(48<*remove*>,za(currout),0,ia);
i:=ia(1)/kittable(kitno,4);
currout:=1;
end;
if errorcalled then
begin
errorcalled:=false;
if store(zno).err=0 or -, running then <* no on err action *>
begin
if currout=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn)
end;
if running then
begin
if this_statement <> 0 then
write(za(currout),<:<13><10>**fejl i linie :>,
<<zddd>,store(zno).this_statement)
else write(za(currout),<:<13><10>during chain:>);
end;
running:=false;
errorout(sys7);
goto return_to_user;
end
else
begin
pc:=store(zno).err+4;
store(zno).err:=0;
if -, killed(incarn) then goto execute
end
end;
if getclock-entrytime>timeslice then
begin
entrytime:=getclock;
if anyactions then
begin
termno:=incarn;
insert;
exit(examinqueue);
end;
end;
if stopatt then
begin
stopatt:=false;
terminals(incarn,2):=terminals(incarn,2) shift (-1) shift 1;
if running then
begin
if store(zno).esc<>0 then
begin
pc:=store(zno).esc+4;
store(zno).esc:=0;
if -, killed(incarn) then goto execute;
end
else
begin
if currout=1 then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn);
end;
if this_statement <> 0 then
write(za(currout),<:<13><10>stop i linie :>,
<<zddd>,store(zno).this_statement,
<:<13><10>:>)
else write(za(currout),<:<13><10>stop during chain<13><10>:>);
if currout=1 then setposition(za(currout),0,0);
running:=false;
goto return_to_user;
end;
end;
end;
this_statement:=next_statement;
if -,killed(incarn) then goto runrep;
end;
if false then
begin
contexterror:
j:=1;
write(out,<:<10>error caused by: :>,
string userident(incarn,increase(j)),<< d>,userident(incarn,3));
setposition(out,0,0);
error(0071); errorout(sys7);
if terminals(incarn,2)=2 then
begin <* trap during login *>
if temst(13) then link(2);
killed(incarn):=false;
terminals(incarn,2):=0;
if incarn=mainno then mainno:=0;
newincarnation:=false;
goto examinqueue;
end;
end;
return_to_user:
if running then
begin
if currout=1 then setposition(za(1),0,0);
write(za(currout),<:<13><10>:>);
if currout=1 then setposition(za(1),0,0);
end;
if currout<>1 then
begin
fileno:=-1;
closeza(currout);
currout:=1;
end;
running:=false;
<*: if testbit3 then
begin
tmcpu:=systime(1,tmbase,tmbase)-tmcpu;
tmtime:=tmbase-tmtime;
write(out,<:**time measure**:>,nl,1,
<: at return to user:>,nl,1,
<: cputime: :>,<<dddd.dd>,tmcpu,nl,1,
<: realtime: :>,tmtime,nl,2);
setposition(out,0,0);
systime(1,0,tmbase);
end;:*>
if errorcalled then
begin
if currout=1 and incarn<>mainno then
begin
setposition(za(1),0,0);
write(za(1),<<zdd>,incarn,<:<13><10>:>)
end;
errorout(sys7)
end;
if killed(incarn) then goto bye;
if -, ignorestopatt then
begin
setposition(za(1),0,0);
if auto then
write(za(1),<<zdd>,incarn,if incarn<>mainno then <:<13><10>:>
else <::>,<<zddd>,linenumber1,sp,1)
else
write(za(1),<<zdd>,incarn,if incarn<>mainno then <:<13><10>* :>
else <:* :>);
setposition(za(1),0,0);
startinput;
if killed(incarn) then goto bye;
end;
if auto then terminals(incarn,2):=6 else
terminals(incarn,2):=4+terminals(incarn,2) extract 1;
conend:end;
next: goto examinqueue;
end;
end;
stop:
write(out,<:<10><10>basic/comal started at :>);
writedate(out,systime(4,basicstarttime,r),r,9);
write(out,<:<10>basic/comal exit at :>);
tmcpu:=systime(1,0,r);
writedate(out,systime(4,r,r1),r1,9);
r:=r-basicstarttime;
r:=systime(4,r,r1);
if r<>680101 then r1:=r1+240000;
write(out,<:<10>time used, cpu: :>);
systime(4,tmcpu,r);
writedate(out,r,0,0);
write(out,<: real: :>);
writedate(out,r1,0,0);
write(out,<:<10><10>:>);
end;
message finis basictexts;
end
▶EOF◀