|
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: 6144 (0x1800)
Types: TextFile
Names: »movevaxtx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »movevaxtx «
mode list.yes
movevax=algol connect.no list.yes survey.yes blocks.yes
begin
procedure blpr (z, s, b);
zone z;
integer s, b;
if s extract 1 = 1 then
stderror (z, s, b);
integer i, j, hwds, chars, pos, startpos, endpos, char, sepleng,
par, result;
integer array zdout, zdin (1:20), tab (0:255), ia (1:10);
long noplchar, no_of_lines, no_of_chars;
long array param, inname, outname, docname (1:2), line (1:14);
real shcl;
zone inz (768, 1, blpr), outz (128, 1, stderror);
trapmode := 1 shift 10;
no_of_lines := no_of_chars := 0;
par := 0;
sepleng := system (4, par, outname);
par := par + 1;
sepleng := system (4, par, param);
if sepleng <> 6 shift 12 + 10 then
begin
write (out,
"nl", 1, <:***:>, outname, <: no outfile param:>, "nl", 1);
goto slut;
end;
par := par + 1;
sepleng := system (4, par, inname);
if sepleng <> 4 shift 12 + 10 then
begin
write (out,
"nl", 1, <:***:>, param, <: no infile param:>, "nl", 1);
goto slut;
end;
result := 21 shift 1;
fpproc (28, result, outz, outname);
if result > 0 then
begin
write (out,
"nl", 1, <:***:>, param, <: connect out error :>, case result of (
<:no resources:> , <:malfunction:>, <:not user/non-exist:>,
<:convention error:>, <:not allowed:>, <:name format error:> ),
"nl", 1);
goto slut;
end;
setblpr (outz, stderror);
getzone6 (outz, zdout);
zdout (10) := 0 ; <*give up mask*>
setzone6 (outz, zdout);
check (outz);
fpproc (27, result, inz, inname);
if result > 0 then
begin
write (out,
"nl", 1, <:***:>, param, <: connect in error :>, case result of (
<:no resources:> , <:malfunction:>, <:not user/non-exist:>,
<:convention error:>, <:not allowed:>, <:name format error:> ),
"nl", 1);
goto slut;
end;
setblpr (inz, blpr);
getzone6 (inz, zdin);
zdin (10) := 1 shift 7; <*give up mask*>
zdin (14) := zdin (19); <*rec base := base buf area*>
zdin (15) := zdin (19) + 4 * zdin (20); <*last half*>
setzone6 (inz, zdin);
check (inz);
getzone6 (outz, zdout);
getzone6 ( inz, zdin );
for i := 1, 2 do
docname (i) := extend zdout (2*i) shift 24 + zdout (2*i+1);
open (outz, zdout (1), docname, 0);
if zdout (1) extract 12 = 18 then
setposition (outz, zdout (7), zdout (8));
for i := 1, 2 do
docname (i) := extend zdin (2*i) shift 24 + zdin (2*i+1);
open (inz , zdin (1), docname , 1 shift 7);
if zdin (1) extract 12 = 18 then
setposition (inz, zdin (7), zdin (8));
isotable (tab);
for i := 32 step 1 until 127 do
tab (i) := 6 shift 12 + i;
for i := 128 step 1 until 255 do
tab (i) := 8 shift 12 + tab (i - 128) extract 12;
intable (tab);
repeat <*until hwds <= 2*>
hwds :=
inrec6 (inz, 0);
inrec6 (inz, hwds);
<*tz write (out, <:<10>hwds := inrec6 = :>, hwds); zt*>
if hwds > 2 then
begin <* non empty block of full lines of 80 chars + maybe 'em'*>
chars := 3 * hwds // 2;
for endpos := chars // 80 * 80 step -80 until 80 do
begin <*for endpos*>
pos := endpos + 1;
startpos := endpos - 79;
<*tz write (out, <:<10>*** 1 *** pos = :>, pos); zt*>
repeat
i := pos := pos - 1;
getchar (inz, i, char);
until
char <> 'sp'
or pos = startpos;
<*tz write (out, <:<10>*** 2 *** pos, char = :>, pos, char); zt*>
putchar (inz, pos, char + 128); <*convert char to iso high*>
end <*for endpos*>;
for i := 1 step 1 until chars // 80 do
begin <*for i*>
pos := (i - 1) * 80 + 1;
<*tz write (out, <:<10>*** 3 *** pos = :>, pos); zt*>
noplchar := gettext (inz, pos, tab, line, -80);
pos := noplchar shift (-24) extract 24 + 1;
char := noplchar extract 12 ;
<*tz write (out, <:<10>*** 3.1 *** pos, char = :>, pos, char); zt*>
putchar (line, pos, char); <*char converted back to iso low*>
no_of_lines := no_of_lines + 1;
no_of_chars := no_of_chars + pos;
<*tz write (out, <:<10>*** 4 *** pos = :>, pos); zt*>
putchar (line, pos, 'nl');
repeat
putchar (line, pos, 'nul');
until pos mod 6 = 1;
<*tz write (out, <:<10>*** 5 *** pos = :>, pos); zt*>
write (outz, line);
end <*for i*>;
end <*if hwds > 2*> else
begin <*'em'*>
pos := 1;
<*tz write (out, <:<10>*** em 1 *** pos = :>, pos); zt*>
putchar (line, pos, 'em');
while pos <= 6 do
putchar (line, pos, 'nul');
<*tz write (out, <:<10>*** em 2 *** pos = :>, pos); zt*>
write (outz, line);
end <*'em'*>;
until hwds <= 2;
getzone6 (outz, zdout);
if zdout (1) extract 12 = 4 then
begin <*area, cut down and set shortclock*>
monitor (42) lookup entry :(outz, 0, ia);
systime (7, 0, shcl);
ia (6) := shcl ; <*shortclock*>
ia (1) := zdout (9) ; <*segments *>
monitor (44) change entry :(outz, 0, ia);
end <*area*>;
close (outz, false );
close (inz , false);
write (out,
"nl", 1, <:no of lines/chars produced : :>, no_of_lines, <:/:>,
no_of_chars, "nl", 1);
slut:
end
end
▶EOF◀