|
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: 16896 (0x4200)
Types: TextFile
Names: »scatop3tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »scatop3tx «
begin <* program scatop. author: jens arnspang, copenhagen rc, may 78 *>
<**************************************************************************
* the program is intended for use on operators level for s-user-catalog *
* managing purposes, i.e. cataloginitialization, inserting/changing/ *
* deleting entries, printing out contents of single entries or all *
* usernames. *
* for further details see appendix to the s-manual. *
* *
* if the program sourcetext is called scatoptxt the program should be *
* translated by: *
* scatop = algol scatoptxt connect.no spill.no *
*************************************************************************>
<*erklaeringer*>
integer catsize, <*antal segmenter i kataloget*>
antindprseg, <*antal entryes pr segment i kataloget*>
entrylgd, <*angiver laengden af en indgang i antal halvord*>
aktion, <*angiver det oenskede underprogram/aktion*>
katres, <*angiver resultat ved katalogopslag*>
i,j,k,p,pp,ind,int,sep,lgd,tal; <*hjalepevariable*>
boolean endlist, <*anvendes under scanningen af parameterliste til scatop*>
entry0; <*sand hvis aktionen angaar entry0, ellers false*>
integer field ifl;
real field nm1,nm2;
integer array field iaf;
real array field raf;
integer array entryarray(0:255), <*indeholder scatopparametre, dvs den nye entry*>
paramtype(0:255), <*angiver typen af param no.p, idet
0:tom, 1:<integer>, 2:<integer>.<integer>, 3:<name> *>
tail,scratch(1:10); <*anvendes ved opslag i hovedkatalog*>
real array createnewcat, createentry, deleteentry, changeentry, printentry, printcat,
procesnavn, arr, navn(1:3); <*diverse hjalepearrays til navne*>
zone entryzone(512,2,stderror);
procedure fejl(s); string s;
begin write(out,s); goto slut end;
procedure paramalarm(p,s);
value p; integer p; string s;
begin write(out,<:<10>***scatop: param no:>,<<dd>,p,<:: :>,s);
goto slut;
end;
procedure kopier(z,a,lgd);
value lgd; zone z; integer array a; integer lgd;
begin <*kopier ord 0...ord(lgd-1) i array a til ord 1...ord lgd i zone z*>
integer i; integer array field iaf;
iaf:=0;
for i:= 1 step 1 until lgd do
z.iaf(i):=a(i-1);
end;
boolean procedure temp(index);
value index; integer index;
<*proceduren er sand, hvis index peger paa en <temp>-resource*>
begin integer h;
h:=entrylgd//2; temp:=(-,entry0) and (index>=22) and
((index-22) mod 4 < 2) and (index < h-((h-22) mod 4));
end <*temp*>;
integer procedure soegnavn(navn,hashvalue);
real array navn; integer hashvalue;
begin <* navn hashes ind og soeges lineaert i susercat.
ved retur ligger den relevante indgang i entryzone.
ved retur angiver vaerdien af soegnavn:
1: kataloget fyldt, navnet fandtes ikke.
2: slettet indgang fundet, navnet fandtes ikke,
den foerste slettede indgang ligger i entryzone.
3: tom indgang fundet, navnet fandtes ikke,
der fandtes ingen slettede indgange,
den foerste tomme indgang ligger i entryzone.
4: navnet fandtes i kataloget, indgangen ligger i entryzone *>
boolean gennemkat, navnfund, tomfund, slettetfund;
integer startseg,<*indhashningssegment, 0..catsize-1 *>
segno, <*0...catsize-1*>
indgno, <*0...antindprseg-1*>
sletseg, sletind, <*angiver foerste evt. slettede indgang*>
i, int, hashvaerdi; <*hjaelpevar*>
long sum;
integer field intf;
gennemkat:=navnfund:=tomfund:=slettetfund:=false;
<*hash ind, hent gaettede entry til entryzone*>
sum:=(long navn(1))+(long navn(2));
int:=(sum extract 24)+((sum shift (-24)) extract 24);
startseg:=segno:=hashvalue:=abs((abs int) mod catsize);
<*soeg cyklisk, lineaert gennem kataloget*>
setposition(entryzone,0,startseg);
if startseg=0
then begin <*skip entry0*>
swoprec6(entryzone, entrylgd);
indgno:=0;
end
else indgno:=-1;
for indgno:=indgno+1
while (-,gennemkat) and (-,navnfund) and (-,tomfund) do
begin if indgno = antindprseg then
begin <*skift segment cyklisk*>
segno:=segno+1; indgno:=0;
if segno = catsize then segno:=0;
setposition(entryzone,0,segno);
if segno=0 then <*skip entry0*>
begin swoprec6(entryzone,entrylgd); indgno:=1 end;
end;
swoprec6(entryzone,entrylgd);
iaf:=2; hashvaerdi:=entryzone.iaf(0);
if hashvaerdi>0 then hashvaerdi:=0;
if (hashvaerdi<-2) or (hashvaerdi>0) then
fejl(<:<10>***scatop: catalogerror, hashvalue<10>:>);
case hashvaerdi+3 of
begin <*-2: slettet*> if -,slettetfund then
begin slettetfund:=true; soegnavn:=2;
sletseg:=segno; sletind:=indgno;
end;
<*-1: tom *>
begin tomfund:=true;
if -,slettetfund then soegnavn:=3;
end;
<* 0: fyldt *>
begin raf:=4;
if (entryzone.raf(1)=navn(1)) and
(entryzone.raf(2)=navn(2)) then
begin navnfund:=true; slettetfund:=false;
soegnavn:=4;
end;
end;
end <*case hashvaerdi*>;
if ((segno+1) mod catsize = startseg) and (indgno+1 = antindprseg)
then gennemkat:=true;
end <*soegning, whileloekke*>;
if gennemkat and (-,navnfund) and (-,tomfund) and (-,slettetfund)
then soegnavn:=1;
if slettetfund then
begin <*positioner til den slettede indgang*>
setposition(entryzone,0,sletseg);
for i:= 0 step 1 until sletind
do swoprec6(entryzone,entrylgd);
end;
end <*procedure soegnavn*>;
<*hovedprogramstart, initialiser*>
open(entryzone,4,<:susercat:>,0);
for i:=1,2 do createnewcat(i):=createentry(i):=deleteentry(i):=
changeentry(i):=printentry(i):=printcat(i):=real extend 0;
<*bestem aktionen/underprogrammet*>
movestring(createnewcat,1,<:newcat:>);
movestring(createentry ,1,<:insert:>);
movestring(deleteentry ,1,<:delete:>);
movestring(changeentry ,1,<:change:>);
movestring(printentry ,1,<:print:>);
movestring(printcat ,1,<:printcat:>);
if system(4,1,arr)<>4 shift 12 + 10
then paramalarm(1,<:action missing:>)
else if (arr(1)=createnewcat(1)) and (arr(2)=createnewcat(2)) then aktion:=1
else if (arr(1)=createentry(1)) and (arr(2)=createentry(2)) then aktion:=2
else if (arr(1)=deleteentry(1)) and (arr(2)=deleteentry(2)) then aktion:=3
else if (arr(1)=changeentry(1)) and (arr(2)=changeentry(2)) then aktion:=4
else if (arr(1)=printentry(1)) and (arr(2)=printentry(2)) then aktion:=5
else if (arr(1)=printcat(1)) and (arr(2)=printcat(2)) then aktion:=6
else paramalarm(1,<:action unknown<10>:>);
<*laes resten af parametre, saet entryarrayet op*>
for i:= 0 step 1 until 255 do entryarray(i):=paramtype(i):=0;
i:=1; iaf:=0; ifl:=2; nm1:=4; nm2:=8; endlist:=false;
for p:=2,p+1 while -,endlist do
begin <*accepter <integer> el <integer>.<integer> el <navn> *>
if iaf>=500 then paramalarm(p,<:too many parameters<10>:>);
k:=system(4,p,arr); sep:=k shift (-12); lgd:=k extract 12;
if (sep<>2 and sep<>4) or (lgd<>4 and lgd<>10)
then begin if (sep<2048) and (k<>0) <*positiv*> then paramalarm(p,<:unknown delimiter<10>:>);
endlist:=true;
end
else begin i:=i+1;
if lgd = 10
then begin <*navn foelger*>
entryarray.iaf.nm1:=arr(1);
entryarray.iaf.nm2:=arr(2);
iaf:=iaf+8; paramtype(i):=3;
end
else begin <*<integer> el <integer>.<integer> foelger*>
int:=arr(1); paramtype(i):=1;
if system(4,p+1,arr)=8 shift 12 + 4 then
begin p:=p+1; paramtype(i):=2;
int:=(int shift 12) + arr(1);
end;
entryarray.iaf.ifl:=int; iaf:=iaf+2;
end;
end;
end;
<*saet konstanter, soeg entry, hent den til lager*>
entry0:= system(4,2,procesnavn) <> 4 shift 12 + 10;
if aktion = 1
then begin <*tag konstanter fra parametre til scatop *>
entrylgd:=entryarray(1);
catsize:=entryarray(3);
end
else begin <*tag konstanter fra entry0*>
setposition(entryzone,0,0); swoprec6(entryzone,512);
ifl:=4; entrylgd:=entryzone.ifl;
ifl:=8; catsize:=entryzone.ifl;
antindprseg:=512//entrylgd;
<*soeg/hent entry*>
<*hvis navn angivet som foerste param, da tag det, ellers entry0*>
if -, entry0
then begin <*soeg den navngivne entry*>
katres:=soegnavn(procesnavn,entryarray(0));
if katres = 1 then
fejl(<:<10>***scatop: catalog full, name not found<10>:>);
end
else katres:=4; <*entry0 'fundet'*>
end;
<*udfoer aktionen*>
case aktion of
begin begin <* 1:newcat*>
integer lastused, devino, nameadr, firstdrumchain, topchaintable, lgdchaintable;
boolean devifundet;
long field sliceref, slicelength;
long array field devname, docname;
integer array ia(1:1), chaintablehead(-18:0);
<*beregn <slice-length> og <reference> - felter*>
lastused:=entryarray(2); devname:=-6; docname:=-20;
sliceref:=12; slicelength:=-8;
system(5,92,ia); firstdrumchain:=ia(1);
system(5,96,ia); topchaintable:=ia(1);
lgdchaintable:=(topchaintable-firstdrumchain)//2;
begin integer array nametable(0:abs(lgdchaintable-1));
system(5,firstdrumchain,nametable);
<*beregn <slicelength> og <reference> for hver device i entry0*>
for devname:=devname+12 while (devname<lastused) and (devname<entrylgd-12) do
begin <*soeg deviname i nametable-chaintableheads*>
devino:=-1; devifundet:=false;
for devino:=devino+1 while (devino<lgdchaintable) and (-, devifundet) do
begin <*sammenlign deviname fra entry0 og docname i chaintablehead*>
system(5,nametable(devino)-36,chaintablehead);
if (entryarray.devname(1)=chaintablehead.docname(1))
and (entryarray.devname(2)=chaintablehead.docname(2))
then devifundet:=true;
end;
if devifundet
then entryarray.devname.sliceref:=(chaintablehead.slicelength shift 24)+8*(devino-1)+44
else begin write(out,<:<10>***scatop: devi:>,<<dd>,(devname-6)//12,<: not found in nametable<10>:>);
goto slut;
end;
end;
end;
monitor(42)lookup_entry:(entryzone,0,tail);
tail(1):=catsize;
monitor(44)change_entry:(entryzone,0,tail);
setposition(entryzone,0,0);
for i:= 1 step 1 until catsize do
begin swoprec6(entryzone,512); iaf:=0;
for j:= 1 step 1 until 256 do entryzone.iaf(j):=0;
for j:= 1 step entrylgd//2 until 256 do entryzone.iaf(j):=-1;
end;
close(entryzone,false); open(entryzone,4,<:susercat:>,0);
setposition(entryzone,0,0);
swoprec6(entryzone,entrylgd);
kopier(entryzone,entryarray,entrylgd//2);
end;
begin <* 2:insert*>
if katres<>4 <*navn fandtes ikke i kataloget*>
then begin tal:=entryarray(5);
for i:=5,4,3,2 do entryarray(i):=entryarray(i-1);
entryarray(1):=tal;
<*adder perm resourcer til temp resourcer
for i:= 22 step 1 until entrylgd//2 -1 do
if temp(i) then
entryarray(i):= entryarray(i) + entryarray(i+2);*>
kopier(entryzone,entryarray,entrylgd//2);
end
else fejl(<:<10>***scatop: entry exists already<10>:>);
end;
begin <* 3:delete*>
if katres = 4 <*navn fandtes i kataloget*>
then begin ifl:=2; entryzone.ifl:=-2 end
else fejl(<:<10>***scatop: entry does not exist<10>:>);
end;
begin <* 4:change*>
if katres = 4 <*navn fandtes i kataloget*>
then begin iaf:=2;;
if system(4,2,arr) = 4 shift 12 + 10
then begin i:=5; p:=3 end else begin i:=1; p:=2 end;
for pp:= paramtype(p) while pp<>0 do
begin if pp<>1 then
paramalarm(p,<:<integer> index expected<10>:>);
ind:=entryarray(i);
if (ind<0) or (ind>=entrylgd//2) then
paramalarm(p,<:index ouside entrybounds<10>:>);
if (entry0 and (ind<=3)) or ((-,entry0) and (ind<=5) and (ind<>1)) then
paramalarm(p,<:forbidden field, must not be changed<10>:>);
pp:=paramtype(p+1);
if (pp<1) or (pp>3) then
paramalarm(p+1,<:one more parameter expected<10>:>);
if pp=3
then begin <*indsaet navn fra naeste param i 4 ord*>
entryzone.iaf(ind+0):=entryarray(i+1);
entryzone.iaf(ind+1):=entryarray(i+2);
entryzone.iaf(ind+2):=entryarray(i+3);
entryzone.iaf(ind+3):=entryarray(i+4);
i:=i+5; p:=p+2;
end
else begin <*indsaet heltal fra naeste param i 1 ord*>
entryzone.iaf(ind):=entryarray(i+1);
<*adder perm resourcer til temp resourcer
if temp(ind) then
entryzone.iaf(ind):= entryzone.iaf(ind) + entryzone.iaf(ind+2);*>
i:=i+2; p:=p+2;
end;
end;
end
else fejl(<:<10>***scatop: entry does not exist<10>:>);
end;
begin <* 5:print*>
procedure outch(t);
value t; integer t;
begin if (t<32) or (t=95) or (t>126)
then outchar(out,42)
else outchar(out,t);
end <*outch*>;
if katres = 4 <*navn fandtes i kataloget*>
then begin iaf:=2;
write(out,<:<10><10>entry contents:<10><10>:>);
for i:= 0 step 1 until entrylgd//2-1 do
begin <* if temp(i)
then tal:= entryzone.iaf(i) - entryzone.iaf(i+2)
else *> tal:= entryzone.iaf(i);
write(out,
<<+ddd>,2*i,
<:: wd::>,<<zdddddd>,tal,
<:: hwd::>,<<zddd>,tal shift (-12),<:.:>,tal extract 12,
<:: ch::>);
outch(tal shift (-16));
outch((tal shift (-8)) extract 8);
outch(tal extract 8);
write(out,<::<10>:>);
end;
write(out,<:<10>:>);
end
else fejl(<:<10>***scatop: entry does not exist<10>:>);
end;
begin <* 6:printcat*>
long array field laf; long array navn(1:3);
laf:=4; p:=entrylgd;
close(entryzone,false); open(entryzone,4,<:susercat:>,0);
write(out,<:<10>susercat contains:>);
for k:= 1 step 1 until catsize do
begin inrec6(entryzone,512);
for iaf:= (if k=1 then p else 0) step p until (antindprseg-1)*p do
if entryzone.iaf(1)>=0 then
begin <*entry fuld, skriv procesnavn ud*>
navn(1):=entryzone.iaf.laf(1);
navn(2):=entryzone.iaf.laf(2);
navn(3):=0; i:=1;
write(out,<:<10> :>, string navn(increase(i)));
end;
end;
write(out,<:<10>end list<10>:>);
end;
end <*case aktion*>;
slut: close(entryzone,true);
end
▶EOF◀