|
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: 10752 (0x2a00)
Types: TextFile
Names: »claimtst3tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »claimtst3tx «
begin
message rc 1978.10.02 claimtest, sidst rettet 1982.12.16;
real array fpparam(1:2);
integer array iarr(1:21);
long array bs_name,search_name(1:2);
integer c_size,a_size,c_area,a_area,c_buf,a_buf,
c_internals,a_internals,i,j,space_name,point_name,
point_integer,bsno,c_segments,c_entries,slicelength,
a_segments,a_entries,sep,fpno,process_descr_addr;
boolean found,ok;
procedure exit;
begin
ok:= false;
goto slut;
end;
procedure next_fp(type);
value type ;
integer type ;
begin
boolean error;
integer separator,length;
fpno:= fpno + 1;
error:= false;
sep:= system(4,fpno,fpparam);
separator:= sep shift (-12) extract 12;
length:= sep extract 12;
case type of
begin
begin <* point-integer required *>
if sep <> point_integer then
begin
if separator = 8 then fp_error(1,separator,length) else
fp_error(2,separator,length);
error:= true;
end;
end;
begin <* point-name required *>
if sep <> point_name then
begin
if separator = 8 then fp_error(1,separator,length) else
fp_error(2,separator,length);
error:= true;
end;
end
end case;
if error then exit;
end next_fp;
procedure fp_error(type,separator,length);
value type,separator,length ;
integer type,separator,length ;
begin
integer i, delim, param;
i:= 1;
delim:= (separator+1)//2;
param:= (length+3)//6;
write(out,<:<10>***claimtest : :>,case type of
(<:parametererror,:>,<:syntaxerror,:>));
case type of
begin
begin <* parametererror *>
write(out,<:parameter must be :>,case param of
(<:<name>:>,<:<integer>:>),<: read : :>);
if param = 1
then write(out,round fpparam(1),<:<10>:>)
else write(out,string fpparam(increase(i)),<:<10>:>);
end;
begin <* syntaxerror *>
write(out,<:separator must be <point> read : :>,
case delim+1 of (<:<newline>:>,<::>,<:<space>:>,<:<equality sign>:>,
<:<point>:>),<:<10>:>);
end;
end case;
end fp_error;
integer procedure fp_specif;
fp_specif:= if fpparam(1) = real<:perm:> then 1 else
if fpparam(1) = real<:login:> then 2 else
if fpparam(1) = real<:temps:> add 'p' and
fpparam(2) = real <:ec:> then 3 else
if fpparam(1) = real<:temp:> then 4 else
if fpparam(1) = real<:buf:> then 5 else
if fpparam(1) = real<:area:> then 6 else
if fpparam(1) = real<:size:> then 7 else
if fpparam(1) = real<:int:> then 8 else 9;
boolean procedure claimproc
(keyno,bsno,bsname,entries,segm,slicelength);
value keyno;
integer keyno,bsno,entries,segm,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
1=temp spec
2=login
3=user/project
bsno (call and return, integer)
If call value is 0 then return value
is main bsdevice no else unchanged
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,mainbs,monrel;
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);
mainbs := core (4);
ownadr:=system(6,i,bsname);
system (5, 64, core);
monrel := core (1) shift (-12) extract 12; <*monitor release*>
end;
if bsno<0 or bsno>bsdevices
or keyno<0 or keyno > 3 then
begin
claimproc:=false;
goto exitclaim
end;
claimproc:=true;
begin integer array nametable(1:bsdevices);
name:=18;
system(5,firstbs,nametable);
if bsno = 0 then
repeat
bsno := bsno + 1;
until nametable (bsno) = mainbs;
system(5,nametable(bsno)-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);
if monrel <= 8 then
begin <*claims in halfwords*>
entries:=core(keyno+1) shift (-12);
segm :=core(keyno+1) extract 12 * slicelength;
end else
begin <*claims in words*>
entries := core (2 * keyno + 1);
segm := core (2 * keyno + 2) * slicelength;
end;
end;
if false then
begin
exitclaim:
entries:=segm:=slicelength:=0;
bsname(1):=bsname(2):=0;
end;
end claimproc;
procedure checkdisc_claims(key);
value key ;
integer key ;
begin
boolean found;
found:= false;
next_fp(2);
search_name(1):= long fpparam(1);
search_name(2):= long fpparam(2);
next_fp(1);
c_segments:= round fpparam(1);
next_fp(1);
c_entries:= round fpparam(1);
bsno := 1;
while
-, found and
claimproc (key, bsno, bsname, a_entries, a_segments, slicelength) do
begin
bsno := bsno + 1;
if bsname(1) = search_name(1) and
bsname(2) = search_name(2) then
begin
found:= true;
if key > 1 then
begin <*login or perm*>
if a_segments < c_segments
or a_entries < c_entries then exit;
end else
begin <*temp or temp spec*>
if a_segments < c_segments
or -,claimproc (key, 0, bsname, a_entries, a_segments, slicelength)
or a_entries < c_entries then
exit;
end;
end;
end;
if -,found then
begin
write(out,<:<10>***claimtest: unknown bs-device :>,
search_name,<:<10>:>);
exit;
end;
sep:= system(4,fpno+1,fpparam);
end checkdisc_claims;
comment get process description for the jobprocess;
process_descr_addr:= system(6,i,fpparam);
system(5)move core area:(process_descr_addr,iarr);
trapmode:= 1 shift 10;
fpno:= 1;
space_name:= 4 shift 12 + 10;
point_name:= 8 shift 12 + 10;
point_integer:= 8 shift 12 + 4;
ok:= true;
comment scan fpparameters and check claims;
for sep:= system(4,fpno,fpparam) while sep extract 12 <> 0 do
begin
case fpspecif of
begin
begin <* perm disc *>
next_fp(2); fpno:= fpno - 1;
while sep = point_name do checkdisc_claims(3);
end;
begin <* login *>
next_fp(2); fpno:= fpno - 1;
while sep = point_name do checkdisc_claims(2);
end;
begin <*temp special*>
next_fp(2); fpno:= fpno - 1;
while sep = point_name do checkdisc_claims(1);
end;
begin <* temp disc *>
next_fp(2); fpno:= fpno - 1;
while sep = point_name do checkdisc_claims(0);
end;
begin <* check buffer claim *>
next_fp(1);
c_buf:= round fpparam(1); <* claim *>
a_buf:= iarr(14) shift (-12) extract 12 + 1; <* available *>
if c_buf > a_buf then exit;
end;
begin <* check area claim *>
next_fp(1);
c_area:= round fpparam(1); <* claim *>
a_area:= iarr(14) extract 12 + 2; <* available *>
if c_area > a_area then exit;
end;
begin <* check size claim *>
next_fp(1);
c_size:= round fpparam(1);
a_size:= iarr(13) - iarr(12);
if c_size > a_size then exit;
end;
begin <* check int. process claim *>
next_fp(1);
c_internals:= round fpparam(1);
a_internals:= iarr(15) shift (-12) extract 12;
if c_internals > a_internals then exit;
end;
begin <* unknown fpparameter *>
i:= 1;
write(out,<:<10>***claimtest : parametererror,unknown fpparameter :>);
if sep extract 12 = 4
then write(out,round fpparam(1),<:<10>:>)
else write(out,string fpparam(increase(i)),<:<10>:>);
exit;
end;
end case;
fpno:= fpno + 1;
end scan fpparameters;
slut:
errorbits:=if ok then 0 else 1;
end program;
▶EOF◀