|
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: 13824 (0x3600)
Types: TextFile
Names: »fileswoptx«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »fileswoptx«
; fileswoptx * page 1 29 05 80, 12.13;
fileswop=algol
begin
<*
The program moves a file or nonareaentry from a specified
base to the user base of the calling process. An existing
<to_name> on from project scope down to temp scope is used.
Two program calls are alowed :
1) <to_name> = fileswop <car>1/0 <from_name>.<base_low>.<base_high>
2) fileswop <cat>0/1 <from_list>
<cat> == cat.<cat_name>. i.e. the name of the catalog.
_ default value : catalog.
<to_name> == the name of the result file.
<from_name> == the file or nonareaentry to move.
<base_low> and
<base_high> == the bases of <from_name>
<from_list> == <f_name_bs> <cont_list>
<cont_list> == (<f_name_bs>/<from_name>/<fom_name>.<bs>)
_ (<cont_list>)0/1
<f_name_bs> == <from_name>.<base_low>.<base_high>/
_ <from_name>.<bs.<base_low>.<base_high>
<bs> == the backingstorage used in the set_proc.
_ when claims are exceeded disc is used.
_ default value is the <from_name> device.
Program call number two will process all the names in <from_list>
as a serie of program calls of type number one with
<to_name> = <from_name>.
NOTE : The bases remain unchanged until a <f_name_bs> claims it
____ to be changed.
examples :
__________
hik = fileswop eputest1.40.49
fileswop sol6.disc2.90.99 sol7 sol8.disc1,
_ colllib1.110.119 covb covc neqcat nes0,
_ eputest1.40.49
sol6, sol7 sol8 is searched on base 90 to 99
colllib1 until nes0 is serached on base 110 to 119
and eputest1 is serached on base 40.49
sol6 is placed on disc2 (if possible else disc)
sol7 is plaved on disc3 as the fromfole sol7
sol8 is placed on disc1 (if...)
e.t.c.
*>
\f
comment fileswoptx * page 2 29 05 80, 12.13
0 1 2 3 4 5 6 7 8 9 ;
zone com(128, 1, stderror);
array par(1:2);
long d_name;
long array to_name, fm_name, scope, kit, cat_name(1:2);
long array field name_f;
real array field r0_f;
boolean perm_exist, temp_exist, exist, namecopy,
_ name_read, bases_sat;
integer array shdes(1:12), to_entry, fm_entry(1:17);
integer i, j, k, r, r1, r2, t, t1, t2,
_ base_lo, base_hi, to_size, fm_size,
_ cat_segm, cat_recl, cat_p_tr, nm_key;
integer field op, b_lo, b_hi, s_f;
integer array field mv_f, i0_f;
\f
comment fileswoptx * page 3 29 05 80, 12.13
0 1 2 3 4 5 6 7 8 9 ;
procedure stop(nr, cause);
integer nr, cause;
begin
write(out, nl, 2, <:*** :>, case nr of (
_ <:set:>, <:changeentry:>, <:scope:>),
_ <:proc error ::>, nl, 1);
case nr of
begin
begin
write(out, case cause of (
_ <:change kind impossible:>,
_ <:bs device unknown:>,
_ <:change bsdevice impossible:>,
_ <:no resources:>,
_ <:in use:>,
_ <:name format illegal:>,
_ <:catalog inconsistent:>,
_ <::>));
if cause = 4 then write(out, nl, 1,
_ <:from_file = set:>, to_entry(1), sp, 1,
_ to_entry.name_f);
end;
begin
write(out, case cause of (
_ <:change kind impossible:>,
_ <:cat i/o error:>,
_ <:name not found:>,
_ <:name protected:>,
_ <:name in use:>,
_ <:name format illegal:>,
_ <:catalog inconsistent:>,
_ <:change bs device impossible:>,
_ <:claims exceeded:>,
_ <::>));
if cause = 9 then write(out, nl, 1,
_ <: from_file = set:>, to_entry(1), sp, 1,
_ to_entry.name_f);
end;
begin
write(out, case cause of (
_ <:hard error:>,
_ <:bs device not ready:>,
_ <:name not found:>,
_ <:name protected:>,
_ <:name in use:>,
_ <:catalog error:>,
_ <:change bs device impossible:>,
_ <:illegal scope:>,
_ <:bs device unknown:>,
_ <::>));
if cause = 6 then write(out, nl, 1,
_ <:fromfile = set:>, to_entry(1), sp, 1,
_ to_entry.name_f);
end;
end;
write(out, nl, 1, <:***:>);
system(9, 0, case nr of (<:setpr:>, <:chgpr:>, <:scopepr:>));
end stop;
\f
comment fileswoptx * page 4 29 05 80, 12.13
0 1 2 3 4 5 6 7 8 9 ;
_
comment fixed fields;
_____________________
i0_f :=
r0_f := 0;
b_lo := 4;
b_hi := 6;
name_f := 2;
mv_f := 14;
s_f := 16;
cat_name(1) := long <:catal:> add 111 <*o*>;
cat_name(2) := long <:g:>;
name_read :=
bases_sat := false;
j := read_param(par);
name_copy := j > 0;
if -, name_copy then
begin
to_name(1) := long par(1);
to_name(2) := long par(2);
j := read_param(par);
end;
if j = 2 then
begin
if par(1) = real <:catna:> <*m*> add 109 and
_ par(2) = real <:e:> then
begin
if read_param(cat_name.r0f) <> 4 then
_ system(9, 0, <:<10>catname:>);
j := read_param(par);
end;
end;
fm_name(1) := long par(1);
fm_name(2) := long par(2);
scope(1) :=
scope(2) := 0;
i := lookup_proc(scope, cat_name, fm_entry);
if i <> 0 then system(9)alarm:(i, <:<10>catlook:>);
cat_segm := fm_entry(1);
cat_recl := 34;
cat_p_tr := 512 // cat_recl;
\f
comment fileswoptx * page 5 29 05 80, 12.13
0 1 2 3 4 5 6 7 8 9 ;
if j = 2 then
begin
repeat
begin
k := read_param(par);
if k = 4 then
begin <*bs device name*>
kit(1) := long par(1);
kit(2) := long par(2);
k := read_param(par);
end
else
kit(1) :=
kit(2) := 0;
if k = 3 then
begin
base_lo := par(1);
k := read_param(par);
base_hi := par(1);
bases_sat := true;
if base_lo > base_hi then
begin
i := base_lo;
base_lo := base_hi;
base_hi := i;
end;
if k <> 3 then system(9)alarm:(k, <:<10>***param:>);
end
else
name_read := true;
if -, bases_sat then system(9)alarm:(0, <:<10>-bases:>);
if name_copy then
begin
to_name(1) := fm_name(1);
to_name(2) := fm_name(2);
end;
write(out, nl, 2, true, 12, to_name, <:= :>);
scope(1) :=
scope(2) := 0;
i := lookup_proc(scope, to_name, to_entry);
perm_exist := i = 0 and (scope(1) = long <:user:>
_ or scope(1) = long <:proje:> add 100);
temp_exist := i = 0 and (scope(1) = long <:login:>
_ or scope(1) = long <:temp:>
_ or scope(1) = long <:***:>);
\f
comment fileswoptx * page 6 29 05 80, 12.13
0 1 2 3 4 5 6 7 8 9 ;
_
comment search fm_name in catalog;
__________________________________
open(com, 4, cat_name, 0);
d_name := fm_name(1) + fm_name(2);
nm_key := d_name shift (-24) + d_name;
nm_key := ((nm_key shift (-12) + nmkey) extract 12) mod cat_segm;
for t := 1 step 1 until 2 do
begin
t1 := case t of (nm_key, 0);
t2 := (case t of (cat_segm, nm_key)) - 1;
for r := t1 step 1 until t2 do
for r1 := 1 step 1 until cat_p_tr do
begin
inrec_6(com, 34);
exist := fm_name(1) = com.name_f(2)
_ and fm_name(2) = com.name_f(3)
_ and base_lo = com.b_lo
_ and base_hi = com.b_hi;
if exist then
begin
comment
write(out, nl, 1, com.name_f, <<-dddd>,
t, r, r1);
r1 := cat_p_tr;
r := t2;
t := 2;
end;
end r r1 loop;
end t-loop;
\f
comment fileswoptx * page 7 29 05 80, 12.13
0 1 2 3 4 5 6 7 8 9 ;
if exist then
begin
fm_size := com.s_f;
comment
write(out, nl, 1, <:fmsize :>, fm_size);
if -, (perm_exist or temp_exist) then
begin
for i := 1 step 1 until 10 do
_ to_entry(i) := com.mv_f(i);
if kit(1) <> 0 then
begin
to_entry.name_f(1) := kit(1);
to_entry.name_f(2) := kit(2);
end;
i := setproc(to_name, to_entry);
if i <> 0 and kit(1) <> 0 then
begin
to_entry.name_f(1) := long <:disc:>;
to_entry.name_f(2) := 0;
i := set_proc(to_name, to_entry);
end;
if i <> 0 then stop(1, i);
end
else
begin
to_entry(1) := fm_size;
for i := (if fm_size>0 then 6 else 2) step 1 until 10 do
_ to_entry(i) := com.mv_f(i);
i := chng_entr_pr(to_name, to_entry);
if i <> 0 then stop(2, i);
end;
if -, perm_exist then
begin
scope(1) := long <:user:>;
scope(2) := 0;
kit(1) :=
kit(2) := 0;
i := scope_proc(scope, kit, to_name);
if i <> 0 then stop(3, i);
end;
end exist
else
begin
write(out, nl, 2, <:****inputfil ej fundet:>);
system(9)alarm:(0, <:<10>sorry:>);
end;
for i := 1 step 1 until 17 do
_ fm_entry(i) := com.i0_f(i);
close(com, true);
open(com, 4, to_name, 0);
i := monitor(76)lookup h and t:(com, r, to_entry);
if i <> 0 then system(9)alarm:(0*write(out,
_ nl, 2, to_name, <: disapeared:>), <:<10>lookup:>);
\f
comment fileswoptx * page 8 29 05 80, 12.13
0 1 2 3 4 5 6 7 8 9 ;
if fm_size > 0 then
begin
<* area - entry *>
outrec_6(com, 34);
for i := 1 step 1 until 17 do
_ com.i0_f(i) := fm_entry(i);
close(com, true);
monitor(10)release:(com, 0, fm_entry <*dummy*>);
_
comment connect fileswoptx-proc;
______________________________
open(com, 0, <:fjols:>, 0);
getshare_6(com, shdes, 1);
to_entry(1) := 0;
for t := 4 step 1 until 10 do
_ sh_des(t) := to_entry(t-3);
sh_des(11) := -1;
setshare_6(com, shdes, 1);
i := monitor(16)send messg:( com, 1, shdes);
if i = 0 then
begin
write(out, nl, 2, <:***ingen message buffere ledige:>, nl, 1);
system(9)alarm:(i, <:<10>sorry:>);
end;
r := monitor(18)wait answ:( com, 1, shdes);
if r = 1 then
begin
if shdes(8) <> 0 then write(out, <: rename not ok :>,
_ case shdes(8) of (<::>, <:cat i/o error:>,
_ <:not found:>, <:protected:>, <:in use:>,
_ <:nameformat illegal:>, <:catalog inconsistent:>),
nl, 1, "+", 11, true, 12, sh_des.name_f, <:= :>);
write(out, <:set:>, shdes(6), sp, 1,
_ to_entry.mv_f.name_f, nl, 1);
end
else
begin
close(com, true);
open(com, 4, to_name, 0);
monitor(48)remove entry:(com, 0, fm_entry);
write(out, nl, 2, <:***answer :>,
_ case r-1 of (<:rejected:>,
_ <:unintelligible:>,
_ <:receiver malfunction:>,
_ <:receiver does not exists:>,
_ <:infile error:>),
_ nl, 1, if shdes(8) > 0 and shdes(8) < 6 then
_ (case shdes(8) of (<:resfile bases troubles:>,
_ <:infile bases troubles:>,
_ <:infile does not exists:>,
_ <:resfile changearea not ok:>,
_ <:infile error status ::>,
_ <:workname not generated:>,
_ <:rename tofile error:>,
_ <::>))
_ else <:dummy answer:>);
if shdes(8) = 5 then write_status(out, shdes(1));
write(out, nl, 1, to_name, <: removed :>, nl, 2);
end;
\f
comment fileswoptx * page 9 29 05 80, 12.13
0 1 2 3 4 5 6 7 8 9 ;
end <* area - entry *>
else
begin
if fm_size extract 23 = 4 then
_ write(out, <:set bs :>) else
_ write(out, <:set :>, <<d>, fm_size shift (-12),
_ <:.:>, fm_size extract 12, sp, 1);
write(out, to_entry.mv_f.name_f, nl, 2);
end;
close(com, true);
if name_read then
begin
name_read := false;
fm_name.r0f(1) := par(1);
fm_name.r0f(2) := par(2);
j := k;
end
else
j := read_param(fm_name.r0f);
end <* repeat loop *>;
until j <> 2 or -, name_copy;
if j <> 0 then
begin
if name_copy then system(9)alarm:(j, <:<10>param:>)
else system(9)alarm:(0*write(out, nl, 1,
_ <:too many params, only the first is processed:>),
_ <:<10>param:>);
end;
end
else
system(9)alarm:(j, <:<10>param:>);
end;
message nu kører vi
end
finis
▶EOF◀