|
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: 8448 (0x2100)
Types: TextFile
Names: »basemove3tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »basemove3tx «
basemove=algol connect.no,
; xref.yes list.yes bossline.yes blocks.yes survey.yes
begin
comment program for moving the entry bases of all entries with
a given base to another base without changing the content of the entry
in any other way. Program call:
basemove from.<l. lim>.<u. lim> to.<l. lim><u. lim>
The program scans the catalog, and whenever it finds an entry where
the base exactly corresponds to the from-base, an attempt is made to move
the bases of that entry. A message is issued for each entry found. This
message states the result of the attempted moving.
When the whole catalog has been scanned, a message containing the number
of entries found, and - if any - the number of entries which could not be
moved of various reasons.
Alarm messages:
call err 1 The from parameters cannot be found.
call err 2 The to parameters cannot be found.
base err 0 The std base of the process in which this
program runs does not contain both sets of bases.
base err 1 Something wrong with the from bases.
base err 2 Something wrong with the to bases
In case of any of these alarms, no base moving will be made at all.;
\f
integer i, j, entries, notmoved, parno, result, sepleng;
integer array frombase, tobase(1:2), procbase(1:8);
long array progname, outfile, chainname (1:2);
real array param, areaname(1:2);
integer field first;
integer array field base;
long array field name;
zone cat(128, 1, eod), entry(1, 1, stderror);
boolean single, move, explain;
procedure eod(z, s, b);
zone z;
integer s, b;
if s extract 1 = 1 then stderror(z, s, b) else goto endcat;
procedure callerror;
begin
if outfile(1)<>long <::> then
unstack_current_output;
write (out, "nl", 1, <:***:>, progname, <: call error:>,
"nl", 2,
<: call :
(<outfile> =)
00
basemove from.<lower>.<upper> to.<lower>.<upper>
1
or
basemove name.<area> from.<low>.<up> to.<low>.<up>
:>, "nl", 1);
errorbits := 3;
goto exit;
end;
\f
integer
procedure stack_current_output (file_name);
long array file_name ;
begin
integer result ;
result := 2;
<*1<1 <=> 1 segment, preferably disc*>
fp_proc (29, 0, out, chain_name);
<*stack c o*>
fp_proc (28, result, out, file__name);
<*connect *>
if result <> 0 then
fp_proc (30, 0, out, chain_name);
<*unstack *>
stack_current_output := result;
end stack_current_output;
procedure unstack_current_output ;
begin
fp_proc (34, 0, out, 25);
<*close up*>
fp_proc (79, 0, out, 0);
<*terminate*>
fp_proc (30, 0, out, chain_name);
<*unstack *>
end unstack_current_output;
\f
trapmode := 1 shift 10;
<*no end alarm written*>
system (4, 0, out_file);
sepleng :=
system (4, 1, progname);
if sepleng shift (-12) <> 6 <*=*> then
begin <*noleft side, progname is param after programname*>
for i := 1, 2 do
begin
prog_name (i) := out_file (i);
out__file (i) := long <::> ;
parno := 1 ;
end;
end <*no left side*>
else
parno := 2;
if out_file (1) <> long <::> then
begin <*stack current out and connect*>
result := stack_current_output (out_file);
if result <> 0 then
begin
write (out, "nl", 1, <:***:>, progname, "sp", 1, <:connect :>, outfile,
"sp", 1, case result of (
<:no resources:>,
<:malfunction:>,
<:not user, not exist:>,
<:convention error:>,
<:not allowed:>,
<:name format error:> ));
out_file (1) := long <::>;
end;
end <*stack current out and connect*>;
explain:=true;
\f
nextparam:
single:=false;
move:=true;
param(1):=0;
entries := notmoved := 0;
first := base := 2;
name := 6;
i := system (4) fpparam :(parno, param);
if i = 0 then
begin
if explain then callerror else
goto stop
end
else
if i <> 4 shift 12 + 10 then
callerror;
explain:=false;
if param(1)=real <:name:> then
begin
i:=system(4, parno+1, areaname);
if i<> 8 shift 12 + 10 then callerror;
parno:=parno+2;
single:=true;
move:=false;
end
else
if param(1)<>real<:from:> then
callerror;
for i := 1, 2 do
begin
if system (4) fpparam :(parno+i, param ) <> 8 shift 12 + 4 then
callerror;
frombase (i) := round param (1);
end;
system(4)fpparam:(parno+3, param);
if param(1)<>real<:to:> then callerror;
for i := 1, 2 do
begin
if system (4) fpparam :(parno+i+3, param) <. 8 shift 12 + 4 then
callerror;
tobase (i) := round param (1);
end;
system(11)catbases:(0, procbase);
i := tobase(1);
if i > frombase(1) then i := frombase(1);
j := tobase(2);
if j < frombase(2) then j := frombase(2);
if procbase(3) > i or
procbase(4) < j then
begin
write(out, <:<10>***:>, progname,<: base error<10>:>);
write(out, <:entry base outside process base<10>:>,
<<-dddddddd>, <:entry base :>, i,j, <:<10>:>,
<:proc base :>, procbase(3), procbase(4), <:<10>:>);
errorbits := 3;
goto stop;
end;
open(cat, 4, <:catalog:>, 1 shift 18);
open(entry, 0, <::>, 0);
monitor(72)setcatbase:(entry, 0, frombase);
for i := inrec6(cat, 34) while true do
if cat.first shift(-12) <> 4095 then
begin
if cat.base(1) = frombase(1) and
cat.base(2) = frombase(2) then
begin
close(entry, false);
j:=1;
open(entry, 0, cat.name(increase(j)), 0);
if single then
begin
if areaname(1) shift (-24) extract 24 = cat.name(1) shift (-24) extract 24
and
areaname(1) extract 24 = cat.name(1) extract 24
and
areaname(2) shift (-24) extract 24 = cat.name(2) shift (-24) extract 24
and
areaname(2) extract 24 = cat.name(2) extract 24
then
begin
move:=true;
end
else
begin
move:=false;
end;
end;
if move then
begin
entries:=entries+1;
j := monitor(74)setentrybase:(entry, 0, tobase);
if j <> 0 then notmoved := notmoved + 1;
write(out, true, 12, cat.name, true, 28, case j+1 of
(<: bases moved properly:>,
<: undefined base error:>,
<: catalog io error:>,
<: not found/name conflict:>,
<: protected/base illegal:>,
<: entry in use:>,
<: name format illegal:>,
<: maincat not present:>),
"sp", 1, <<ddddddd>, <:from.:>, frombase (1), frombase (2),
<: to.:>, tobase (1), tobase (2),
if j > 0 then <: not moved<10>:> else <:<10>:>);
end;
end;
end;
endcat:
write(out, entries, if entries >1 then <: entries found:> else <: entry found:>);
if notmoved = 0 then write(out, <: and moved ok<10>:>)
else
write(out, <:<10>***:>, notmoved,
if notmoved >1 then <: entries :> else <: entry :>, <:not moved, see above!<10>:>);
close(entry, false);
open(entry, 0, <::>, 0);
monitor(72)setcatbase:(entry, 0, procbase);
parno:=parno+6;
close (entry, true);
close (cat,true);
errorbits := 2;
<*warning.yes*>
goto nextparam;
stop:
if outfile (1) <> long <::> then
unstack_current_output;
exit:
end
scope login basemove
finis
▶EOF◀