|
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: 26880 (0x6900)
Types: TextFile
Names: »tchildpr«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »tchildpr«
<*procedures for handling child processes
1982-04-15
Anders Lindgård
*>
algol list.on;
integer procedure create_child(desc,permcore,z,ct);
value permcore; boolean permcore;
integer array desc;
zone z;
integer array field ct;
if curchildren>=maxchildren or
(core.ownref.intfuncref shift (-12) extract 12 -owninternal)<=0 then
begin
createchild:=5;
writeerror(z,errornointernals,desc);
end else
begin
integer pda,i,sh,char,nameindex,res,cbn,ca,cb,cint,
usb,usa,usint,fblock,lblock;
own integer devices;
boolean checkcore,stdbincat;
integer array field par;
integer array param(1:9);
long array name1,jobname(1:3);
if devices=0 then
disable begin
devices:=(wordload(76)-wordload(74))//2;
end devices;
par:=12;
for i:=1,2 do name1(i):=jobname(i):=desc.conjobname(i);
createchild:=0;
checkcore:=if -,permcore then findcorehole(desc,fblock,lblock,z) else
true;
<*+2*>
if testop(2) and -,permcore then
disable write(z,"nl",1,<:create child: coreblock:>,
fblock,lblock);
<*-2*>
if -,checkcore then
begin
createchild:=res:=1;
writeerror(z,errornocore,desc);
end else
begin
ca:=core.ownref.bufarearef;
usb:=cb:=ca shift (-12) extract 12;
usa:=ca:=ca extract 12;
usint:=cint:=core.ownref.intfuncref shift (-12) extract 12;
<*+2*>
if testop(2) then disable write(z,"nl",1,<:buf,area,int:>,cb,ca,cint);
<*-2*>
res:=0;
cb:=cb-ownbuf-(desc.conbufandarea shift (-12) extract 12);
ca:=ca-ownarea-(desc.conbufandarea extract 12);
cint:=cint-owninternal-(desc.conintandfunc shift (-12) extract 12);
if cb<=0 then res:=errornobuffers else
if ca<=0 then res:=errornoareas else
if cint<=0 then res:=errornointernals;
if res>0 then
begin
param(1):=usb-ownbuf; param(2):=usa-ownarea;
param(3):=usint-owninternal;
writeerror(z,res,param);
createchild:=res:=6;
end else
begin
freebuf:=usb-ownbuf; freearea:=usa-ownarea;
freeinternal:=usint-owninternal;
if permcore then
begin
param(1):=desc.confirstaddress;
param(2):=desc.contopaddress;
end else
begin
desc.confirstaddress:=param(1):=coretable(fblock,1);
desc.contopaddress:=param(2):=coretable(lblock,1)-2;
end;
for i:=3 step 1 until 9 do param(i):=desc.par(i);
setbasestd;
pda:=process_description(name1);
stdbincat:= logand(desc.conprioandcommands,bit_stdbase)=0;
if stdbincat then param(8):=param(9):=desc.conloweruser;
if pda>0 and stdbincat then
begin
param(8):=desc.conloweruser;
i:=0;
repeat i:=i+1;
sh:=-48;
repeat sh:=sh+8;
char:=jobname(i) shift sh extract 8;
until char=0 or sh=0;
until char=0 or i=2;
res:=3; nameindex:=0;
while res=3 and nameindex<9 do
begin
name1(i):=(jobname(i) shift sh add
(48+nameindex)) shift (-sh);
param(8):=param(9):=param(8)+1;
res:=createint(name1,param);
<*+2*>
if testop(2) then disable
write(z,"nl",1,nameindex,name1,param(8),i,sh);
<*-2*>
nameindex:=nameindex+1;
end while;
end else res:=createint(name1,param);
<*+2*>
if testop(2) then disable write(z,"nl",1,<:createint: res :>,res,
"nl",1,<:name :>,name1,
"nl",1,<:faddr:>,param(1),
"nl",1,<:taddr:>,param(2),
"nl",1,<:b a a:>,param(3),
"nl",1,<:i a f:>,param(4),
"nl",1,<:mode :>,param(5),
"nl",1,<:maxb :>,param(6),param(7),
"nl",1,<:stdb :>,param(8),param(9),
"nl",1,if stdbincat then <::> else <:*stdbase=userbase:>);
<*-2*>
if res>0 then
begin
createchild:=res+8;
writeerror(z,case res of (
errorresultimpossible,errorcatalogerror,errornameconflict),desc);
end else
begin
for i:=1,2 do desc.con_proc_name(i):=name1(i);
setcatbase(name1,desc.conloweruser,desc.conupperuser);
for i:=1,2 do desc.con_proc_name(i):=name1(i);
childrencreated:=childrencreated+1;
curchildren:=curchildren+1;
if logand(desc.conprio_and_commands,bit_priv)=0 then
include_devices(name1,includelist,lastdevice) else
for i:=0 step 1 until devices do include_user(name1,i);
pda:=process_description(name1);
if permcore then else
begin
for cbn:=lblock-1 step -1 until fblock do coretable(cbn,2):=pda;
<*+2*>
if testop(2) then write(z,"nl",1,<:fblock, lblock:>,fblock,lblock);
<*-2*>
end;
cbn:=0;
ct:=-ct_size;
repeat cbn:=cbn+1;
ct:=ct+ct_size;
inspect(childtable.ct.ct_sem,i);
until cbn>maxchildren or (childtable.ct.ct_childpda=0 and i>0);
childtable.ct.ct_child_pda:=pda;
childtable.ct.ct_term_pda:=desc.contermpda;;
childtable.ct.ct_state:=state_created; <*created*>
childtable.ct.ct_ref:=desc.conref;
for i:=1,2 do childtable.ct.ct_jobname(i):=jobname(i);
childtable.ct.ct_first:=param(1);
childtable.ct.ct_last :=param(2);
childtable.ct.ct_usercatno:=desc.conusercatno;
desc.con_cur_child:=cbn;
desc.con_cur_childpda:=pda;
<*+2*>
if testop(2) then disable write(z,"nl",1,<:child no :>,cbn,
childtable.ct.ct_childno,
"nl",1,<:childpda:>,childtable.ct.ct_childpda);
<*-2*>
end;
resetbase;
end buf,area,int ok;
end coreblock_found;
end create_child;
integer procedure checkchild(desc,error,z,ct);
value error; boolean error;
integer array desc;
zone z;
integer array field ct;
begin
integer pda,cn,res;
<*checks whether the name in desc is a child of this console*>
res:=1;
cn:=0;
pda:=process_description(desc.con_proc_name);
if pda>0 then begin
res:=0;
ct:=-ct_size;
repeat cn:=cn+1;
ct:=ct+ctsize;
until cn>maxchildren or pda=childtable.ct.ct_childpda;
if cn>maxchildren then res:=1 else
if (desc.contermpda<>sysconpda and
desc.contermpda<>childtable.ct.ct_termpda) or
childtable.ct.ctbatch>0 then res:=2;
end pda>0;
checkchild:=res;
desc.concurchild:=if res=0 then cn else 0;;
desc.concurchildpda:=if res=0 then pda else 0;
if res>0 and error then writeerror(z,case res of (errorprocessunknown,
errornotallowed),desc);
end checkchild;
integer procedure load_and_modify(desc,z,mode);
value mode; boolean mode;
integer array desc;
zone z;
begin
integer res,rep,progext,base;
integer array field childpda,ct;
integer array M,A(1:8),param(1:6);
long array bsname(1:3);
procedure set_in_out(name,proc);
long array field name;
integer field proc;
if desc.name(1)<>0 or desc.name(2)<>0 then
begin
integer array field pda;
desc.proc:=pda:=processdescription(desc.name);
if pda=0 then
begin
set_base(desc.conloweruser,desc.conupperuser);
res:=createareaprocess(desc.name);
if res<>0 then write(z,"nl",1,<:**create area process :>,
desc.name,res);
pda:=processdescription(desc.name);
if pda=0 then desc.proc:=desc.contermpda else
desc.proc:=pda;
reset_base;
end;
end set in out;
childpda:=processdescription(desc.conprocname);
load_and_modify:=1;
<*+2*>
if testop(2) then disable write(z,"nl",1,<:load and modify:>,
"nl",1,<:child pda :>,childpda);
<*-2*>
if childpda>0 and wordload(childpda)=0 then
begin
setbase(desc.conloweruser,desc.conupperuser);
res:=lookupentry(desc.conprogram,tail);
<*+2*>
if testop(2) then disable write(z,"nl",1,
<:program :>,desc.conprogram,<: lookup result :>,res);
<*-2*>
if res>0 then
begin
writeerror(z,case res of (
0,errorcatalogerror,errorareaunknown),desc);
res:=res+24;
end else
begin
ct:=(desc.concurchild-1)*ct_size;
base:=core.childpda(50);
setinout(coninname,conprocin);
childtable.ct.ct_procin:=
param(1):=desc.con_proc_in;
param(2):=ownpda;
setinout(conoutname,conprocout);
childtable.ct.ct_procout:=
param(3):=desc.con_proc_out;
param(4):=childpda;
param(5):=0;
param(6):=desc.confirstaddress-base
+tail(9) extract 12;
if tail(9) shift (-12) extract 12<>3 then
begin
writeerror(z,errorareaerror,desc);
res:=25;
end else
if tail(1)<=0 then
begin
writeerror(z,errorareaerror,desc);
res:=26;
end else
if tail(10)>desc.contopaddress-desc.confirstaddress then
begin
res:=27;
writeerror(z,errorprogramtoobig,desc);
end else
begin
M(1):=3 shift 12;
M(2):=desc.confirstaddress;
M(3):=M(2)+tail(10)-2;
M(4):=0;
for i:=1,2 do bsname(i):=desc.conprogram(i);
createareaprocess(desc.conprogram);
rep:=0;
repeat rep:=rep+1;
if mode then
begin
res:=waitanswer(sendmessage(bsname,M),A);
end else
begin
csendmessage(bsname.f,M,progext);
cwaitanswer(progext,A,res,0);
end;
until res<>1 or (A(1)=0 and A(2)=tail(10)) or rep=10;
if res=1 and rep=10 then
begin
res:=24+5;
writeerror(z,errorareaerror,desc);
end else
if res>1 then
begin
writeerror(z,case res of(0,errorareareserved,
errorresultimpossible,errorareaunknown),desc);
res:=res+32;
end else
begin
res:=modifyint(desc.conprocname,param);
if res>0 then
begin
<*+2*>
if testop(2) then write(z,"nl",1,<:modify: :>,res,
"nl",1,<:in :>,param(1),
"nl",1,<:parent:>,param(2),
"nl",1,<:out :>,param(3),
"nl",1,<:own :>,param(4),
"nl",1,<:IC :>,param(6));
<*-2*>
res:=24+res;
writeerror(z,errorresultimpossible,desc);
end modify>0 else
if base=0 then
begin
res:=changeaddressbase(desc.conprocname,
desc.confirstaddress-childbaseaddress);
if res<>0 or testop(2) then write(z,"nl",1,<:change address :>,res,
desc.confirstaddress,childbaseaddress,desc.confirstaddress-
childbaseaddress);
end base=0;
end program in core;
end tail ok;
end lookup;
resetbase;
end internal;
loadandmodify:=res;
end load and modify;
integer procedure stop_child(desc);
integer array desc;
begin
integer cn,res;
integer array field ct,cpda;
boolean state;
res:=2;
cn:=desc.concurchild;
if cn>0 then
begin
ct:=(cn-1)*ctsize;
cpda:=childtable.ct.ct_childpda;
state:=core.cpda.stateref;
state:=(state and bit_start) extract 7=0;
if state then
begin
res:=stopchild:=stopint(desc.con_proc_name);
if res=0 then
begin
childtable.ct.ct_state:=state_stopped;
if childtable.ct.ctbatch>0 then brunchildren:=brunchildren-1;
end;
end else
begin
res:=0; childtable.ct.ct_state:=state_stopped;
end;
end cn>0;
stopchild:=res;
end stop_child;
integer procedure startchild(desc);
integer array desc;
begin
integer cn,res;
integer array field ct,cpda;
boolean state;
res:=2;
cn:=desc.concurchild;
if cn>0 then
begin
ct:=(cn-1)*ct_size;
cpda:=childtable.ct.ct_childpda;
state:=core.cpda.state_ref;
state:=(state and bit_start) extract 7 >0;
if state then
begin
res:=startchild:=startint(desc.con_proc_name);
if res=0 then
begin
if childtable.ct.ctstate<>state_breaked then
childtable.ct.ct_state:=state_running;
if childtable.ct.ctbatch>0 then brunchildren:=brunchildren+1;
end res=0;
end state else
begin
res:=0;
childtable.ct.ct_state:=state_running;
end started;
end cn>0;
startchild:=res;
end startchild;
integer procedure set_prio_child(desc);
integer array desc;
begin
integer cn,res;
res:=23;
cn:=desc.concurchild;
if cn>0 then
begin
res:=set_priority(desc.conprocname,desc.con_prio_and_commands shift (-12)
extract (12));
if res=0 then desc.conprioandcommands:=desc.conprioandcommands extract 12;
end cn>0;
set_prio_child:=res;
end setpriochild;
integer procedure break_child(desc,z);
integer array desc; zone z;
begin
integer i,res,base,oldIC;
integer array param(1:6);
integer array field childpda,reg,ct;
res:=stopchild(desc);
childpda:=processdescription(desc.conprocname);
oldIC:=core.childpda(46);
base:=core.childpda(50);
reg:=core.childpda(19)+base;
if reg>0 and res=0 then
begin
for i:=1 step 1 until 6,8 do core.reg(i):=core.childpda(40+i);
core.reg(7):=8;
param(1):=desc.conprocin;
param(2):=ownpda;
param(3):=desc.conprocout;
param(4):=childpda;
param(5):=0;
param(6):=reg+16-base; <* new IC*>
res:=modifyint(desc.conprocname,param);
if res<>0 then res:=res+16;
end;
write(z,<:<10>break :>,core.reg(7),oldIC,reg-base);
if res=0 then
begin
res:=startchild(desc);
ct:=(desc.concurchild-1)*ct_size;
if res=0 then childtable.ct.ct_state:=state_breaked;
end;
breakchild:=res;
end break;
integer procedure remove_child(desc,z);
integer array desc;
zone z;
begin
integer cn,res,bs,job;
integer array field pda,iaf,ppda,ct;
boolean batch;
long array field laf,laf1;
long array name,pname(1:3);
integer array param(1:8);
removechild:=1;
cn:=desc.concurchild;
<*+2*>
if testop(2) then disable write(z,"nl",1,<:remove: child :>,cn);
<*-2*>
if cn>0 then
begin
ct:=(cn-1)*ctsize;
pda:=childtable.ct.ct_childpda;
laf:=pda+2;
for i:=1,2 do pname(i):=core.laf(i);
batch:=childtable.ct.ctbatch>0;
<*+2*>
if testop(2) then disable write(z,"nl",1,<:child state:>,
childtable.ct.ctstate,if batch then <: batch :> else <:on line:>);
<*-2*>
if childtable.ct.ct_state <>staterunning then
begin
clearentries(1,core.pda.stdbaseref(1),core.pda.stdbaseref(2),z);
for bs:=1 step 1 until noofbs do
begin
laf:=iaf:=(bs-1)*12;
iaf:=usercatbs.iaf(6);
res:=lookup_bs_claims(pname,usercatbs.laf,param);
if res=0 then
begin
for i:=1,2 do perm_bs_claimed(childtable.ct.ct_usercatno,bs,i):=
perm_bs_claimed(childtable.ct.ct_usercatno,bs,i)-param(6+i);
<*+2*>
if testop(2) and (param(7)<>0 or param(8)<>0) then
write(z,"nl",1,<:perm bs userno :>,childtable.ct.ct_usercatno,
permbsclaimed(childtable.ct.ct_usercatno,bs,1),
permbsclaimed(childtable.ct.ct_usercatno,bs,2));
<*-2*>
end update resources
end for bs;
ppda:=childtable.ct.ctprocin;
if ppda=0 then else
begin
laf1:=ppda+2;
for i:=1,2 do name(i):=core.laf1(i);
if core.ppda(1)=4 then
begin
laf:=2;
if core.ppda.laf(1) shift (-24) extract 24=
long <:wrk:> shift (-24) extract 24 and
batch then removeentry(name);
removeprocess(name);
end;
end ppda>0;
ppda:=childtable.ct.ct_procout;
if ppda=0 then else
begin
laf1:=ppda+2;
for i:=1,2 do name(i):=core.laf1(i);
if core.ppda(1)=4 then removeprocess(name);
end procout;
res:=removechild:=removeprocess(pname);
<*+2*>
if testop(7) then disable
write(z,"nl",1,<:remove :>,pname,<: res :>,res);
<*-2*>
if res=0 then
begin
if childtable.ct.ct_bufref<>0 then
begin integer array A(1:8);
<*release possible buffer from finis or break*>
send_answer(1,childtable.ct.ct_bufref,A);
childtable.ct.ct_bufref:=0;
end;
job:=childtable.ct.ctsegmqueue;
for i:=1,2 do childtable.ct.ct_jobname(i):=0;
childtable.ct.ct_childpda:=childtable.ct.ct_termpda:=
childtable.ct.ct_state :=childtable.ct.ct_ref :=
childtable.ct.ct_first :=childtable.ct.ct_last :=
childtable.ct.ct_jobno :=childtable.ct.ct_segmswop:=
childtable.ct.ct_usercatno:=childtable.ct.ctprocin :=
childtable.ct.ct_procout :=0;
if batch then
begin
childtable.ct.ct_batch:=0;
if desc.q_remove_job_file>0 then
remove_entry(desc.q_jobname);
bcurchildren:=bcurchildren-1;
for i:=1 step 1 until bmaxchildren do
begin
if cn=bsegmtable(i,1) then bsegmtable(i,1):=0;
end;
for i:=2 step 1 until 15 do jobtable(job,i):=0;
desc.q_jobno:=0;
getjobsegm(desc,job,true);
end batch;
for cn:=1 step 1 until no_of_coreblocks do
if coretable(cn,2)=pda then coretable(cn,2):=0;
curchildren:=curchildren-1;
desc.con_cur_child:=0;
desc.con_cur_child_pda:=0;
freebuf:=core.ownref.bufarearef shift (-12) extract 12 -ownbuf;
freearea:=core.ownref.bufarearef extract 12 - ownarea;
freeinternal :=core.ownref.intfuncref shift (-12) extract 12 -owninternal;
end;
end;
end cn>0;
end remove child;
integer procedure find_bs_ref(desc,bs_type,bsno);
value bstype; integer bsno,bstype;
integer array desc;
begin
boolean found;
integer bs;
integer array field iaf;
long array field laf;
findbsref:=0;
repeat
iaf:=laf:=(bsno-1)*12;
iaf:=usercatbs.iaf(6);
found:=desc.iaf(5)=bs_type;
if found then findbsref:=iaf;
bsno:=bsno+1;
until bsno>no_of_bs or found;
end find_bs_ref;
procedure std_claim(desc);
integer array desc;
begin
desc.con_buf_and_area:=std_buf shift 12 add std_area;
desc.con_int_and_func:=std_int shift 12 add std_func;
desc.con_mode:=240 shift 12+7;
end std_claim;
procedure std_bs(desc,z);
integer array desc;
zone z;
begin
integer bs,firstbs;
integer array field iaf;
firstbs:=1;
repeat iaf:=findbsref(desc,0,firstbs); <*drum*>
if iaf=0 then else
begin
<*drum or not used*>
if desc.iaf(3)>stdentries then desc.iaf(1):=desc.iaf(8):=
stdentries else desc.iaf(8):=desc.iaf(3);
desc.iaf(9):=0;
<*+2*>
if testop(2) then write(z,"nl",1,<:std_bs : :>,iaf,desc.iaf(8),
desc.iaf(9));
<*-2*>
end;
until firstbs>=noofbs;
firstbs:=1;
repeat iaf:=findbsref(desc,1,firstbs); <*disc*>
if iaf=0 then else
begin
if desc.iaf(3)>stdentrydisc then
desc.iaf(1):=desc.iaf(8):=stdentrydisc else desc.iaf(8):=desc.iaf(3);
if desc.iaf(4)>stdsegmdisc then
desc.iaf(2):=desc.iaf(9):=stdsegmdisc else desc.iaf(9):=desc.iaf(4);
end;
until firstbs>noofbs;
firstbs:=1;
if stddisc1name(1)>0 then
begin
repeat iaf:=findbsref(desc,2,firstbs); <*disc1*>
if iaf>0 then
begin
if desc.iaf(3)>stdentrydisc1 then
desc.iaf(1):=desc.iaf(8):=stdentrydisc1 else desc.iaf(8):=desc.iaf(3);
if desc.iaf(4)>stdsegmdisc1 then
desc.iaf(2):=desc.iaf(9):=stdsegmdisc1 else desc.iaf(9):=desc.iaf(4);
end iaf>0
until iaf=0 or firstbs>noofbs;
end stddisc1;
firstbs:=1;
repeat iaf:=findbsref(desc,3,firstbs); <*aux*>
if iaf=0 then else
begin
for bs:=1,2 do desc.iaf(7+bs):=desc.iaf(bs):=desc.iaf(2+bs);
end;
until firstbs>noofbs;
firstbs:=1;
repeat iaf:=findbsref(desc,4,firstbs); <*max*>
if iaf=0 then else
begin
for bs:=1,2 do desc.iaf(7+bs):=desc.iaf(bs):=desc.iaf(2+bs);
end;
until firstbs>noofbs;
end stdbs;
integer procedure setbs(desc,bserror,z,tempadjust);
value tempadjust; boolean tempadjust;
integer array desc,bserror;
zone z;
begin
boolean priv;
integer bs,i,cn,res,usn,slicel;
integer array param(1:8);
long array field n;
integer array field iaf;
res:=setbs:=0;
cn:=desc.concurchild;
priv:=logand(desc.con_prio_and_commands,bit_priv)<>0 or
logand(desc.con_prio_and_commands,bit_maxclaim)<>0;
<*+2*>
if testop(2) then disable write(z,"nl",1,<:setbs: childno :>,cn,
<: :>,desc.con_procname);
<*-2*>
for bs:=1 step 1 until no_of_bs do
begin
bserror(bs):=0;
iaf:=n:=(bs-1)*12;
slicel:=usercatbs.iaf(5);
iaf:=usercatbs.iaf(6);
for i:=1,2 do param(6+i):=desc.iaf(7+i);
if (param(8)<>0 or param(7)<>0) and bs_exist(bs) then
begin
param(8):=(param(8)+slicel-1)//slicel*slicel;
for j:=0,1,2 do for i:=1,2 do param(j*2+i):=param(6+i)*
(if tempadjust then( if j=0 then 2.0 else 1.5) else 1.0);
if bs=1 then param(1):=param(1)+std_temp_entries;
<*first bs device must be catalog device*>
usn:=desc.conusercatno;
if perm_bs_claimed(usn,bs,3)-perm_bs_claimed(usn,bs,1)-param(7)<0
and desc.iaf(5)<3 and -,priv <*drum,disc,disc1*> then bserror(bs):=7 else
if perm_bs_claimed(usn,bs,4)-perm_bs_claimed(usn,bs,2)-param(8)<0
and desc.iaf(5)<3 and -,priv then bserror(bs):=8 else
bserror(bs):=set_bs_claims(desc.conprocname,usercatbs.n,param);
if bserror(bs)=0 then
begin
lookup_bs_claims(desc.conprocname,usercatbs.n,param);
for i:=1,2 do permbsclaimed(desc.conusercatno,bs,i):=
permbsclaimed(desc.conusercatno,bs,i)+param(6+i);
<*+2*>
if testop(2) and param(7)<>0 and param(8)<>0 then
disable write(z,"nl",1,<:perm bs set userno :>,desc.conusercatno,
usercatbs.n,
permbsclaimed(desc.conusercatno,bs,1),
permbsclaimed(desc.conusercatno,bs,2));
<*-2*>
end else
begin
res:=setbs:=31;
<*+2*>
if testop(2) then disable write(z,"nl",1,
<:set bs claim :>,bserror(bs),true,10,usercatbs.n,<< ddddd>,
param(1),param(2),param(3),param(4),
param(6),param(7),param(8));
<*-2*>
end bserror;
end resource>0;
end for bs;
if res>0 then
writeerror(z,errorbsclaimsexceeded,bserror);
end setbs;
procedure list_bs(name,z);
long array name; zone z;
begin
integer bs,i,res;
long array field laf;
integer array param(1:10);
write(z,"nl",2,true,10,<:device:>,"sp",7,<:temp:>,"sp",11,<:key 1:>,
"sp",11,<:login:>,"sp",12,<:perm:>,
"nl",1,"sp",9);
for i:=1 step 1 until 4 do write(z,"sp",1,<:entries:>,"sp",4,<:segm:>);
for bs:=1 step 1 until noofbs do
begin
laf:=(bs-1)*12;
res:=lookup_bs_claims(name,usercatbs.laf,param);
write(z,"nl",1);
if res>0 then write(z,<:***:>,true,12,name,
true,12,usercatbs.laf,<: does not exist:>,res) else
begin
write(z,true,10,usercatbs.laf);
for i:=1 step 1 until 4 do
write(z,true,8,<< dddddd>,param(2*i-1),true,8,param(2*i));
end;
end for bs;
end listbs;
procedure write_cur_time(z);
zone z;
begin
integer t;
real r;
write(z,<< dd dd dd.dd dd>,systime(6,systime(7,0,0.0),r)+r/1000000);
end writecurtime;
procedure write_time(z,time);
value time; integer time;
zone z;
begin
integer t;
real r;
write(z,<< dd dd dd.dd dd>,systime(6,time,r)+r/1000000);
end writetime;
procedure clear_entries(permkey,lower,upper,z);
value permkey,lower,upper; integer permkey,lower,upper;
zone z;
<*clear all temporary entries up to permkey
within the bases given*>
begin
integer i,j;
integer array field rec,srec,r;
long array field doc,name;
long array sname(1:3);
rec:=0;
name:=6;
doc:=16;
sname(1):=0;
wait(catsem);
open(cat,4,<:catalog:>,1 shift 9);
setposition(cat,0,0);
<*+2*>
if testop(2) then write(z,<:remove entries: :>,permkey,lower,upper);
<*-2*>
for i:=inrec6(cat,0) while i>2 do
begin
inrec6(cat,i);
srec:=0;
repeat
for r:=0 step 34 until 512-34 do
begin
rec:=srec+r;
if cat.rec(1)<>-1 then
begin
if cat.rec(1) extract 3<=permkey then
begin
if lower<=cat.rec(2) and upper>=cat.rec(3) then
begin
setbase(lower,upper);
<*+2*>
if testop(2) then write(z,"nl",1,cat.rec.name);
<*-2*>
removeentry(cat.rec.name);
resetbase;
end stdbase;
end permkey;
end entry;
end record;
srec:=srec+512;
until srec>=i;
end segments;
close(cat,true);
signal(catsem);
end clearentries;
boolean procedure find_core_hole(desc,fblock,lblock,z);
integer fblock,lblock;
integer array desc;
zone z;
begin
integer size,blocks,cbn,ccb,cblock,cs;
boolean free;
fblock:=lblock:=-1;
cs:=coreblocksize*512;
size:=desc.con_size;
blocks:=((size+cs-2)//cs);
<*+2*>
if testop(2) then write(z,"nl",1,<:size, blocks :>,size,blocks,cs);
<*-2*>
findcorehole:=false;
cbn:=0;
repeat cbn:=cbn+1;
cblock:=blocks;
ccb:=0;
repeat ccb:=ccb+1;
free:=coretable(cbn+ccb-1,2)=0;
if free then cblock:=cblock-1;
<*+2*>
if testop(2) then write(z,"nl",1,<:free blocks:>,blocks-cblock);
<*-2*>
until -,free or cblock=0 or cbn+ccb-1>=noofcoreblocks;
until cblock=0 or free or cbn>=noofcoreblocks;
if cblock=0 then
begin
findcorehole:=true;
fblock:=cbn;
lblock:=cbn+blocks;
end found;
end findcorehol;
integer procedure find_max_free_core;
begin
integer max,i,j,jmax;
boolean free;
max:=i:=0;
repeat i:=i+1;
j:=jmax:=0;
repeat j:=j+1;
free:=coretable(i+j-1,2)=0;
if free then jmax:=jmax+coreblocksize;
until -,free or i+j-1>=noofcoreblocks;
if max<jmax then max:=jmax;
until i>=noofcoreblocks;
findmaxfreecore:=max*512;
end findmaxfreecore;
integer procedure swop_child(swop,ct,in,z);
value in;
long array swop;
integer array field ct;
boolean in;
zone z;
begin
integer array M,A(1:8);
integer i,j,res,rep,bytes,swopext,pda_bs;
long array field nf;
integer array field pda_c;
setbasestd;
pda_c:=childtable.ct.ctchildpda;
if pda_c=0 then res:=4 else
begin
nf:=2;
pda_bs:=process_description(swop);
if pda_bs=0 then
begin
create_area_process(swop);
reserve_process(swop);
end;
M(1):=(if in then 3 else 5) shift 12;
M(2):=core.pda_c.coreaddressref(1)+core.pda_c.base_ref;
M(3):=core.pda_c.coreaddressref(2)+core.pda_c.base_ref;
M(4):=childtable.ct.ctsegmswop;
bytes:=M(3)-M(2)+2;
<*+2*>
if testop(7) then
disable begin
write(z,"nl",1,"cr",1,<:swopproc :>,swop,
if in then <: in:> else <: out:>,M(2),M(3),M(4));
setposition(z,0,0);
end;
<*-2*>
rep:=0;
repeat rep:=rep+1;
csendmessage(swop.f,M,swopext);
cwaitanswer(swopext,A,res,0);
until res<>1 or (A(1)=0 and A(2)=bytes) or rep=10;
<*+2*>
if testop(7) then
disable begin
write(z,res,A(1),A(2),rep);
setposition(z,0,0);
end;
<*-2*>
if rep=10 then res:=6 else
if res=1 and A(1)=0 and A(2)<>bytes then res:=7 else
if res=1 and A(1)<>0 then res:=8;
end child pda>0
swop_child:=res;
resetbase;
end swop_child;
procedure list_proc(very,connect);
value connect; boolean connect;
zone very;
begin
long array field nf;
integer array field ct,cpda,cur;
integer i;
long t;
real r;
nf:=2;
ct:=-ct_size;
if connect then writecurtime(very);
if lock and connect then write(very,<: **locked** :>);
for i:=1 step 1 until maxchildren do
begin
ct:=ct+ct_size;
cpda:=childtable.ct.ct_childpda;
if cpda>0 and connect then
begin
cur:=childtable.ct.ctref;
t:=core.cpda.runtimeref;
r:=core.cpda.starttimeref/10000;
if connect then write(very,"cr",1,"nl",1,true,11,core.cpda.nf,
<<ddd>,(core.cpda.coreaddressref(2)-
core.cpda.coreaddressref(1)+2)//1024,<:k:>,
"sp",1,case childtable.ct.ct_state of (
<:created :>,<:running :>,<:stopped :>,
<:breaked :>,<:swopped :>),<<dd dd dd.dd dd>,
systime(4,r,r)+r/1000000,
<: cpu:>,<< ddddd>, t/10000,"sp",2,
if childtable.ct.ct_batch>0 then <:batch___:> else <:on line :>);
if childtable.ct.ct_batch>0 then
write(very,true,11,q.cur.condesterm) else
write(very,true,11,condesc.cur.condesterm);
if childtable.ct.ct_batch>0 then
write(very,<: job :>,<<dddd>,q.cur.q_jobno);
end;
end for;
end list;
▶EOF◀