|
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: 6912 (0x1b00)
Types: TextFile
Names: »treaduscat«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »treaduscat«
<*read user catalog (tramos-type)
1981-12-03
Anders Lindgård
*>
procedure writeentry(desc,listz,extended);
value extended; boolean extended;
integer array desc;
zone listz;
begin
integer i,j;
long array field n,in_f,out_f,term;
long array con(1:2);
con(1):=long <:conso:> add 'l'; con(2):=long <:e:>;
n:=4;
in_f:=48;
out_f:=in_f+8;
term:=out_f+8;
if desc(1)=-1 then write(listz,"nl",2,<:empty entry:>) else
if desc(1)=-2 then write(listz,"nl",2,<:deleted entry:>) else
if desc(1)<0 then write(listz,"nl",<:impossible:>,desc(1)) else
begin
write(listz,"nl",2,
<:proc :>,true,12,desc.n,
"nl",1,<:sem conaccess :>,desc(1),
"nl",1,<:prio, mask :>,desc(2) shift (-12) extract 12,
desc(2) extract 12,
"nl",1,<:buf , area :>,desc(9) shift (-12) extract 12,
desc(9) extract 12,
"nl",1,<:intern, func :>,desc(10) shift (-12) extract 12,
desc(10) extract 12,
"nl",1,<:mode :>,desc(11),
"nl",1,<:max bases :>,<< -dddddddd>,desc(12),desc(13),
"nl",1,<:std bases :>,desc(14),desc(15),
"nl",1,<:size :>,desc(16),
"nl",1,<:user bases :>,desc(21),desc(22));
n:=32;
write(listz,
"nl",1,<:program :>,desc.n,
"nl",1,<:project,user :>,<< ddddddd>,desc(23) shift (-8) extract 16,
desc(23) extract 8,
"nl",1,<:usercatno :>,desc(24),
"nl",1,<:in :>);
if desc.in_f(1)=0 then write(listz,con) else
write(listz, desc.in_f);
write(listz, "nl",1,<:out :>);
if desc.out_f(1)=0 then write(listz,con) else
write(listz, desc.out_f);
write(listz, "nl",1,<:term :>);
if desc.term(1)=0 then write(listz,con) else
write(listz, desc.term);
write(listz,"nl",1,<:job state :>,desc.conjobstate);
write(listz,<:
temp perm set used type
entries segment entries segment entries segment entries segment:>);
for i:=1 step 1 until no_of_bs do
begin
fi:=12*i-12;
fi:=usercatbs.fi(6);
write(listz,"nl",1,<< dddddd>,desc.fi(1),
desc.fi(2),desc.fi(3),desc.fi(4),
desc.fi(6),desc.fi(7),desc.fi(8),desc.fi(9),
<< dd>,desc.fi(5));
end listbs;
if extended then
begin
<*console descriptor*>
write(listz,"nl",1,<:pda in :>,desc.conprocin,
"nl",1,<:pda out :>,desc.conprocout,
"nl",1,<:pda term :>,desc.contermpda,
"nl",1,<:descrip term :>,desc.condesterm,
"nl",1,<:job name :>,desc.conjobname,
"nl",1,<:child no :>,desc.concurchild,
"nl",1,<:child pda :>,desc.concurchildpda,
"nl",1,<:terminal no :>,desc.contermno,
"nl",1,<:descrip reference:>,desc.conref,
"nl",1,<:job number :>,desc.conjob);
end console descriptor;
end non empty entry;
end write entry;
boolean procedure read_user_cat(name,desc,list,listz);
value list; boolean list;
long array name;
integer array desc;
zone listz;
begin
integer i,j,hkey,bs;
boolean found;
integer array field fi,d,iaf;
long array field n;
fi:=n:=0;
setbaseusercat;
i:=connectcuri(usercatname);
readusercat:=false;
if i=0 then
begin
if name(1)=0 then
disable begin
<*entry 0*>
setposition(in,0,0);
inrec6(in,512);
if list then
begin
write(listz,"nl",1,<:usercat entry 0:>,
<< ddd >,
"nl",1,<:entry length :>,in.fi(2),
"nl",1,<:entry0 length :>,in.fi(3),
"nl",1,<:catalog size :>,in.fi(4),
"nl",1,<:no of users :>,in.fi(5),
"nl",1,<:updated :>);
writetime(listz,in.fi(10));
write(listz,
"nl",2,<:device name slicelength reference:>);
end list;
n:=0;
d:=0;
for fi:=20 step 12 until lengthusercatentry0 do
begin
for i:=1 step 1 until 6 do desc.d(i):=in.fi(i);
if list then
write(listz,"nl",1,
true,11,desc.d.n,
<< ddd >,desc.d(5),
"sp",8,desc.d(6));
d:=d+12;
end for;
unstackcuri;
end entry 0 else
begin
h_key:=hash(name,size_user_cat);
found:=search_user_cat(in,h_key,sizeusercat,name,desc);
if -,found then found:=search_user_cat(in,0,h_key,name,desc);
if found and list then disable writeentry(desc,listz,false);
found:=found and desc.conusercatno<=usercatusers+10;
if found then
begin
for i:=1,2 do desc.con_jobname(i):=desc.con_procname(i):=name(i);
for bs:=1 step 1 until noofbs do
begin
iaf:=(bs-1)*12;
iaf:=usercatbs.iaf(6);
for i:=3,4 do perm_bs_claimed(desc.conusercatno,bs,i):=
desc.iaf(i);
for i:=1,2 do perm_bs_claimed(desc.conusercatno,bs,i):=
desc.iaf(5+i);
end;
end found;
readusercat:=found;
unstackcuri;
end other entry;
end connect;
resetbase;
end read user cat;
algol list.off;
integer procedure hash(name, catsize);
___________________________________
comment compute hashvalue;
long array name;
integer catsize;
begin
integer nv;
long name1;
name1 := name(1) + name(2);
nv := name1 extract 24 + name1 shift (-24);
if nv < 0 then nv := - nv;
hash := nv mod catsize;
end;
boolean procedure search_user_cat(s_cat,start_segm, end_segm, proc_name,desc);
___________________________________________________________
comment search segment;
comment find <proc_name> entry in user_catalog;
value start_segm, end_segm;
integer start_segm, end_segm;
integer array desc;
long array proc_name;
zone s_cat;
begin
integer track,h_key,rest,i,res,rep;
boolean found;
integer array field fi;
fi:=0;
search_user_cat:= found := false;
rep:=0;
repeat rep:=rep+1;
setbaseusercat;
createareaprocess(usercatname);
if res=1 then delay(1);
res:=reserveprocess(usercatname);
resetbase;
until res=0 or rep=10;
if res=0 then
begin
setposition(s_cat, 0, start_segm);
for track := start_segm + 1 step 1 until end_segm do
begin
repeat
rest := inrec_6(s_cat, length_user_cat_entry);
h_key := s_cat.con_access;
if h_key <> -1 and h_key <> -2 and
_ s_cat.con_proc_name(1) = proc_name(1) and
_ s_cat.con_proc_name(2) = proc_name(2) then
begin
search_user_cat:= found := true;
for i:=length_user_cat_entry//2 step -1 until 2 do
desc(i):=s_cat.fi(i);
<*desc(1) is a semaphore*>
end;
until rest < length_user_cat_entry or found;
end;
end res=0;
releaseprocess(usercatname);
end search;
algol list.on;
▶EOF◀