|
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: 9984 (0x2700)
Types: TextFile
Names: »fjolsprogtx«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »fjolsprogtx«
; file swopper prog * page 1 29 05 80, 12.17;
fjolsprog = algol
begin
zone to_z(128, 1, stderror),
_ fm_z(128, 1, fjols_error),
_ mpr(1, 1, stderror);
long array pr_name, to_name, fm_name, wk_name(1:2);
integer array bases, fm_b, to_b(1:2),
_ messg(1:12), fm_entry(1:20);
long array field name_f;
integer field segm_f;
integer array field base_f, ia_f;
integer t, i, buf_addr, entr_sum,
_ segm, to_segm, fm_segm;
long fm_segm_sum, to_segm_sum, start_time;
boolean stat;
procedure fjols_error(z, s, b);
zone z;
integer s, b;
begin
integer i;
messg(1) := s;
messg(8) := 5;
messg(9) := 2;
monitor(72)cat_bases:(mpr, 0, to_b);
monitor(64)remove_process:(to_z, 0, fm_entry);
if wk_name(1) <> 0 then
_ monitor(46)rename:(to_z, 0, wk_name.ia_f);
monitor(72)cat_bases:(mpr, 0, fm_b);
close(fm_z, true);
monitor(72)cat_bases:(mpr, 0, to_b);
close(to_z, true);
monitor(72)cat_bases:(mpr, 0, bases);
monitor(22)send answer:(mpr, buf_addr, messg);
write(out, nl, 2, fm_name, <: error status ::>);
write_status(out, s);
set_position(out, 0, 0);
goto RESTART;
end fjols_error;
\f
comment file swopper prog * page 2 29 05 80, 12.17
0 1 2 3 4 5 6 7 8 9 ;
_
comment statistics init;
________________________
fm_segm_sum :=
to_segm_sum := 0;
entr_sum := 0;
start_time := date_time;
_
comment prepare base changes;
_____________________________
system(11)catbase:(0, messg);
bases(1) := messg(1);
bases(2) := messg(2);
open(mpr, 0, <::>, 0);
_
comment fields of cat entries;
______________________________
ia_f := 0;
name_f := 6;
base_f := 2;
segm_f := 16;
wk_name(1) := 0;
write(out, nl, 2, <:File Jump Over Limit Service:>,
_ nl, 1, <:ready:>, nl, 1);
setposition(out, 0, 0);
\f
comment file swopper prog * page 3 29 05 80, 12.17
0 1 2 3 4 5 6 7 8 9 ;
_
RESTART: <* after fm_z error from fjols_error *>
_______
_
<* wait message loop *>
__________________________
while true do
begin
procedure stop(no, cause);
integer no, cause;
begin
messg(8) := 5 + no;
messg(9) := 4; <* malfunction *>
goto CONT;
end;
i := monitor(20)wait mess:(to_z, buf_addr, messg);
if true then
begin
get_zone(to_z, fm_entry);
pr_name(1) := fm_entry.name_f(0);
pr_name(2) := fm_entry.name_f(1);
write(out, nl, 2, <:message to fjolsprog:>, i,
_ <: from :>, pr_name, nl, 1, messg(1),
_ messg(2), messg(3), sp, 1, messg.name_f,
_ messg(8), nl, 2);
set_position(out, 0, 0);
end;
if i > 0 and messg(1) = 0 then
begin
if messg(8) = -1 then
<*xfer messg*>
______________
begin
_
comment copy mess and collect out-file descr;
_____________________________________________
to_b(1) := messg(2);
to_b(2) := messg(3);
to_name(1) := messg.name_f(1);
to_name(2) := messg.name_f(2);
for t := 2 step 1 until 8 do messg(t) := 0;
\f
comment file swopper prog * page 4 29 05 80, 12.17
0 1 2 3 4 5 6 7 8 9 ;
_
comment collect in-file descr;
______________________________
i := monitor(72)set cat base:(mpr, 0, to_b);
if i = 0 then
begin
open(to_z, 4, to_name, 0);
inrec_6(to_z, 34);
to_segm := to_z.segm_f;
fm_b(1) := to_z.base_f(1);
fm_b(2) := to_z.base_f(2);
fm_name(1) := to_z.name_f(1);
fm_name(2) := to_z.name_f(2);
setposition(to_z, 0, 0);
if fm_name(1) = to_name(1) and
_ fm_name(2) = to_name(2) then
begin
wk_name(1) := to_name(1);
wk_name(2) := to_name(2);
close(to_z, true);
<* generate name *>
if monitor(68, fm_z, 0, fm_entry) <> 0 then
_ stop(1, 2);
get_zone(fm_z, fm_entry);
to_name(1) := fm_entry.name_f(0);
to_name(2) := fm_entry.name_f(1);
i := monitor(46)rename:(to_z, 0, to_name.ia_f);
if i <> 0 then stop(2, i);
open(to_z, 4, to_name, 0);
end
else
wk_name(1) :=
wk_name(2) := 0;
\f
comment file swopper prog * page 5 29 05 80, 12.17
0 1 2 3 4 5 6 7 8 9 ;
_
comment set base for in-file;
_____________________________
i := monitor(72)set cat base:(mpr, 0, fm_b);
if i = 0 then
begin
open(fm_z, 4, fm_name, -1 shift 2
_ -(1 shift 5));
inrec_6(fm_z, 0);
<* sætter nametable address *>
_
comment get actual size of in-file;
___________________________________
i := monitor(76)lookup h and t:(fm_z, 0, fm_entry);
if i = 0 then
begin
fm_segm := fm_entry.segm_f;
segm := if to_segm <= fm_segm then to_segm
_ else fm_segm;
_
comment copy files;
___________________
monitor(72)catbase:(mpr, 0, to_b);
for t := 1 step 1 until segm do
begin
inrec_6(fm_z, 4*128);
outrec_6(to_z, 4*128);
to_from(to_z, fm_z, 4*128);
end;
_
comment release out_file;
_________________________
i := changearea(to_z, 0 add 1);
setposition(to_z, 0, 0);
monitor(64)remove process:(to_z, 0, fm_entry);
if i = 0 then
begin
_
comment statistics;
___________________
to_segm_sum := to_segm_sum + to_segm;
fm_segm_sum := fm_segm_sum + fm_segm;
entr_sum := entr_sum + 1;
_
comment send answer;
____________________
messg(1) := 1 shift 1;
messg(6) := segm;
messg(9) := 1;
\f
comment file swopper prog * page 6 29 05 80, 12.17
0 1 2 3 4 5 6 7 8 9 ;
end
else
<*changearea not ok*>
begin
messg(1) := i shift 1;
messg(8) := 4; <*alarm address*>
messg(9) := 4; <*malfunction*>
end;
end
else
<*infile not found*>
begin
messg(1) := i shift 1;
messg(8) := 3; <*alarm address*>
messg(9) := 3; <*unintelligible*>
end infile not found;
monitor(72)catbases:(mpr, 0, fm_b);
close(fm_z, true);
end
else
begin
<*input area base trouble*>
messg(1) := i shift 1;
messg(8) := 2; <*alarm address*>
messg(9) := 4; <*malfunction*>
end input area base trouble;
monitor(72)cat_bases:(mpr, 0, to_b);
close(to_z, true);
if wk_name(1) <> 0 then
begin
i := monitor(46)rename:(to_z, 0, wk_name.ia_f);
if i <> 0 then
begin
messg.name_f(0) := to_name(1);
messg.name_f(1) := to_name(2);
messg(8) := i;
end;
wk_name(1) := 0;
end;
_
CONT: <* from stop *>
____
end
else
begin
<*output area base troubles*>
messg(1) := i shift 1;
messg(8) := 1; <*alarm address*>
messg(9) := 4; <*malfunction*>
end output area base troubles;
monitor(72)catbases:(mpr, 0, bases);
monitor(22)send answ:(mpr, buf_addr, messg);
\f
comment file swopper prog * page 7 29 05 80, 12.17
0 1 2 3 4 5 6 7 8 9 ;
if fp_mode(1) or true then
begin
write(out, nl, 2, to_name, <<d>, <:.:>,
_ to_b(1), <:.:>, to_b(2), <: = fjolsprog :>);
if messg(8) <> 1 then write(out, fm_name, <<d>,
_ <:.:>, fm_b(1), <:.:>, fm_b(2), sp, 1);
write(out, case (messg(8) + 1) of (
_ <:ok:>,
_ <:output area base troubles:>,
_ <:input area base troubles:>,
_ <:infile not found:>,
_ <:changearea troubles:>,
_ <:workname not generated:>,
_ <:rename to<95>file error:>,
_ <::>), nl, 1,
_ <:; called from :>, pr_name, nl, 2);
setposition(out, 0, 0);
end;
end xfer mess
else
_
<*xfer statistics*>
___________________
begin
stat := true;
for t := 2 step 1 until 8 do
stat := stat and messg(t) = 0;
if stat then
begin
write(out, nl, 3, <:fjols statistics:>, sp, 3);
wr_date_time(out, start_time);
write(out, <:__-__:>);
start_time := date_time;
wr_date_time(out, start_time);
write(out, nl, 2, <<-dddddddddd>,
<:from-segments:>, fm_segm_sum, nl, 1,
<:to_-_segments:>, to_segm_sum, nl, 1,
<:files________:>, entr_sum, nl, 1);
setposition(out, 0, 0);
fm_segm_sum :=
to_segm_sum := 0;
entr_sum := 0;
end acc stat mess;
end test stat mess;
end wait mess loop;
end permanent loop;
close(mpr, true);
end;
message ude
fjolsprog
end
finis
▶EOF◀