|
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: 9216 (0x2400)
Types: TextFile
Names: »tadd «
└─⟦110021343⟧ Bits:30007476 RC8000 Backup tape fra HT's bus-radio system
└─⟦a957ba283⟧
└─⟦this⟧ »tadd «
(
mp=set 1
mp=algol message.no
lookup add
if ok.no
(
fl=algol message.no connect.no
add=algol message.no connect.no
)
end
)
external
integer procedure mp(to_file,from_file);
long array to_file,from_file; <* output file name; input file name *>
begin
<*
mp return value: 0 copying ok.
1 no core.
<lookup result> * 1000 + 2 no input file.
<lookup result> * 1000 + 3 no output file.
<ch.entry result>* 1000 + 4 change entry output file impossible.
5 create area process impossible, area claims exceeded.
6 input file reserved by other process.
<lookup result> = 0 means non-area entry looked up.
WARNING: the output file is changed partly when result 6 is returned.
Carsten Palvig 1981.06.22
NHP 880422 *>
integer procedure slice_size(device_name);
long array device_name;
begin
integer array core(1:18);
integer size,bs_devices;
size:= 0; <* result value for non-existing devices *>
system(5,92,core);
bs_devices:= (core(3)-core(1))//2;
begin
integer array name_table(1:bs_devices);
integer device_no;
long array field name;
system(5,core(1),name_table);
name:= 18;
for device_no:= 1 step 1 until bs_devices do
begin
system(5,name_table(device_no)-36,core);
if core.name(1)=device_name(1) and core.name(2)=device_name(2) then
begin
size:= core(15);
device_no:= bs_devices;
end;
end;
end;
slice_size:= size;
end slice_size;
<* mp page 2 *>
procedure error(error_code);
value error_code; integer error_code;
begin
mp:= error_code;
goto terminate;
end error;
integer block_size, segm_in, segm_out;
long array file_in, file_out(1:2);
begin <* calculate the optimal blocksize *>
zone z, z_bs(1,1,stderror);
integer array tail_in, tail_out, tail_out_bs(1:10),
_ tail_in_bs(6:10), ia(1:1);
long array docname(1:2);
long array field device;
integer max_blockfactor, slice, s, kind_in, kind_out, i;
boolean bs_in, bs_out;
device:= 2;
for i:= 1,2 do
begin file_in(i):= from_file(i); file_out(i):= to_file(i) end;
max_blockfactor:= system(2,0,docname)//512-14;
if max_blockfactor<1 then error(1); <* no core *>
open(z,0,file_in,0); close(z,false);
i:= monitor(42,z,0,tail_in); if i<>0 then error(2+i*1000); <* no input file *>
bs_in:= tail_in(1)=1 shift 23+4;
kind_in:= tail_in(9) shift (-12);
if bs_in then
begin
for i:= 6,7,8,9,10 do tail_in_bs(i):= tail_in(i);
for i:= 1,2 do file_in(i):= tail_in.device(i);
segm_in:= if kind_in=4 then 0 else
_ if kind_in<32 then tail_in(8) else kind_in-32;
open(z,0,file_in,0); close(z,false);
i:= monitor(42,z,0,tail_in); if i<>0 or tail_in(1)<0 then
error(2+i*1000) <* no input file *>
end else
if tail_in(1)<0 then error(2) <* no input file *> else segm_in:= 0;
if monitor(52,z,0,ia)<>0 then error(5); <* create area process impossible *>
open(z,0,file_out,0); close(z,false);
i:= monitor(42,z,0,tail_out); if i=3 then
begin
tail_out(1):= tail_in(1)-segm_in; tail_out(2):= 1;
for i:= 3 step 1 until 10 do tail_out(i):= 0;
i:= monitor(40,z,0,tail_out)
end;
if i<>0 then error(3+i*1000); <* no output file *>
bs_out:= tail_out(1)=1 shift 23+4;
kind_out:= tail_out(9) shift (-12);
if bs_out then
begin
open(z_bs,0,file_out,0); close(z_bs,false);
for i:= 1 step 1 until 10 do tail_out_bs(i):= tail_out(i);
for i:= 1,2 do file_out(i):= tail_out.device(i);
segm_out:= if kind_out=4 then 0 else
_ if kind_out<32 then tail_out(8) else kind_out-32;
open(z,0,file_out,0); close(z,false);
i:= monitor(42,z,0,tail_out); if i<>0 or tail_out(1)<0 then
error(3+i*1000) <* no output file *>
end else
if tail_out(1)<0 then error(3) <* no output file *> else segm_out:= 0;
if monitor(52,z,0,ia)<>0 then error(5); <* create area process impossible *>
slice:= slice_size(tail_in.device);
s:= slice_size(tail_out.device);
if s>slice then slice:= s;
tail_out(1):= segm_out-segm_in+tail_in(1);
if bs_out then
begin
if bs_in then
begin
for i:= 6,7,8,9,10 do tail_out_bs(i):= tail_in_bs(i);
if kind_in=4 then error(2) else
if kind_in<=32 then tail_out_bs(8):= segm_out else
tail_out_bs(9):= (segm_out+32) shift 12+(tail_in_bs(9) extract 12)
end else
begin
for i:= 6,7,8,9,10 do tail_out_bs(i):= tail_in(i);
if kind_in>32 then error(2) else
if kind_in<>4 then tail_out_bs(8):= segm_out else
tail_out_bs(9):= (segm_out+32) shift 12+(tail_in(9) extract 12)
end;
i:= monitor(44,z_bs,0,tail_out_bs);
if i<>0 then error(4+i*1000) <* change entry output file impossible *>
end else
if bs_in then
begin
for i:= 6,7,8,9,10 do tail_out(i):= tail_in_bs(i);
if kind_in=4 then error(2) else
if kind_in<=32 then tail_out(8):= 0 else
tail_out(9):= 4 shift 12+(tail_out(9)extract 12)
end else
begin
for i:= 6,7,8,9,10 do tail_out(i):= tail_in(i);
if kind_in>32 then error(2)
end;
i:= monitor(44,z,0,tail_out);
if i<>0 then error(4+i*1000); <* change entry output file impossible *>
if tail_out(1)=0 then error(0);<* nothing to move (no error) *>
monitor(8,z,0,ia); <* reserve output file *>
block_size:= (if max_blockfactor>=tail_in(1) then tail_in(1) else
if max_blockfactor>slice then max_blockfactor//slice*slice
else max_blockfactor
) * 512;
if docname(1)=long<:testm:> add 'o' then <* 'testmove' *>
_ write(out,<:mp blocksize: max, used =:>,max_blockfactor,block_size//512,<:<10>:>);
end;
begin <* mp page 3 *>
procedure block_proc(z,s,b);
zone z; integer s,b;
begin
if false add (s shift(-2)) then error(6);
<* input file reserved by other process *>
stderror(z,s,b);
end;
zone z(block_size//4,1,block_proc);
integer array to, from(1:20);
integer i;
getzone6(z,to);
open(z,4,file_in,1 shift 2); <* giveup: rejected *>
getzone6(z,from); from(9):= segm_in;
setzone6(z,to);
open(z,4,file_out,0);
getzone6(z,to); to(9):= segm_out;
setzone6(z,from);
copy:
i:= inrec6(z,0);
if i>2 then
begin
inrec6(z,i);
getzone6(z,from); setzone6(z,to);
outrec6(z,i);
if i=block_size then
begin
outrec6(z,0);
getzone6(z,to); setzone6(z,from);
goto copy;
end;
getzone6(z,to); setzone6(z,from);
end;
close(z,true); <* input *>
setzone6(z,to);
close(z,true); <* output *>
end;
mp:= 0; <* move ok *>
terminate:
end procedure mp;
end
end
begin
array o,s,p(1:2);
integer i;
long array field l;
l:= 0;
system(4,0,o);
if system(4,1,p)<>6 shift 12+10 then
write(out,<:***:>,o.l,<: intet målområde:>) else
if system(4,2,s)<>4 shift 12+10 then
write(out,<:***:>,p.l,<: ingen kilde:>) else
begin
i:= mp(o.l,s.l);
if i>0 then write(out,<:***:>,p.l,<< bddd>,i,<: :>,case i mod 1000 of(
_ <:processtørrelse:>,<:kildeområde:>,<:målområde:>,<:change entry:>,
_ <:create area process:>,<:kilde reserveret:>))
end;
fpproc(7,0,0,0)
end
begin
integer item,sep,i;
long array field l,m;
array field r;
integer array field ii;
array o,s,p(1:2);
integer array t(1:17);
zone z,z1(1,1,stderror);
procedure q(i);
value i; integer i;
if i>1000 then system(9,i,<:<10>moncall:>);
l:= 0; m:= 6; r:= 2; ii:= 0;
system(4,0,o);
if system(4,1,p)<>6 shift 12+10 then
write(out,<:***:>,o.l,<: intet målområde:>) else
begin
item:= 2;
sep:= system(4,item,s);
if sep<>4 shift 12+10 then write(out,<:***:>,p.l,<: har intet at tilføje:>) else
repeat
if sep extract 12<>10 then
write(out,<:***:>,p.l,<: kan ikke tilføje:>,s(1)) else
if s(1)=o(1) and s(2)=o(2) then
write(out,<:***:>,p.l,<: :>,s.l,<: kan ikke tilføjes sig selv:>) else
begin
open(z,0,o,0); close(z,true);
q(1000*monitor(42,z,0,t)+42);
if t(1)<0 then system(9,t(1),<:<10>objekt:>);
t(8):= t(1); t.r(1):= o(1); t.r(2):= o(2); t(1):= 1 shift 23+4;
t(6):= t(7):= t(9):= t(10):= 0;
q(1000*monitor(68,z,0,t)+68); q(1000*monitor(40,z,0,t)+40);
q(1000*monitor(76,z,0,t)+76);
i:= mp(t.m,s.l);
if i=0 then
begin
open(z1,0,s,0); close(z1,true);
monitor(48,z1,0,t); q(1000*monitor(46,z,0,s.ii)+46);
end else write(out,<:***:>,p.l,<< bddd>,i,<: :>,case i mod 1000 of(
_ <:processtørrelse:>,<:kildeområde:>,<:målområde:>,<:change entry:>,
_ <:create area process:>,<:kilde reserveret:>))
end;
item:= item+1; sep:= system(4,item,s)
until sep=0
end;
fpproc(7,0,0,0)
end
▶EOF◀