|
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: »checktapetx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »checktapetx «
mode list.yes
checktape=algol,
survey.yes
begin
integer file, block, length, format, i, sepleng, segm, giveup;
long array name, param (1:2);
boolean test;
real array field from, to;
write (out,
"nl", 2, <:call : checktape ( segm.<integer> ):>,
"nl", 2, <: default : segm.9:>);
setposition (out, 0, 0);
param (1) := param (2) := long <::>;
i := 1;
segm := 9; <*default*>
for sepleng := system (4, increase (i), param) while
sepleng = 4 shift 12 + 10
do
if param (1) = long <:segm:> and
system (4, increase (i), param) = 8 shift 12 + 4 then
segm := param (1);
write (out,
<:<10>segm : :>, segm, "nl", 1);
setposition (out, 0, 0);
begin <*block for zone*>
zone z (segm * 128<* + 2*>, 1, ignore_eot);
integer
procedure out_text_in_int (z, text);
zone z ;
string text ;
begin
integer int;
write (z, text);
setposition (z, 0, 0);
read (z, int );
setposition (z, 0, 0);
out_text_in_int := int;
end out_text_in_int;
procedure ignore_eot (ztape, status, hwds);
value status ;
zone ztape ;
integer status, hwds ;
begin
<**********************************************************>
<* *>
<* The procedure acts as a block procedure in the zone *>
<* ztape and supposes that there are *>
<* no other user bits in the status than 1<18, e. o. d., *>
<* and 1 shift 14, mode error. *>
<* The purpose of the procedure is to : *>
<* *>
<* If give up bit is raised , dummy answer : *>
<* - give up and call stderror *>
<* *>
<* If give up bit is raised, normal answer : *>
<* - write out the status word and ignore *>
<* *>
<* If end of document status : *>
<* - ignore the status if the operation was output *>
<* - simulate a block of 2 halfs if the operation was in- *>
<* put and nothing was transferred *>
<* *>
<* If mode error status : *>
<* - try the next mode in the reportoire and give up if *>
<* all have been tried *>
<* - close the zone, open it again with new mode, setpo- *>
<* sition, check position operation (with possible call *>
<* of block procedure) and return with bytes transfer- *>
<* red = 0. *>
<* *>
<**********************************************************>
integer array zdescr (1:20), sdescr (1:12);
integer operation, i, j, nextmode;
long array field docname;
own
integer startmode;
docname := 2; <*fields docname in zone*>
if status extract 2 = 1 then
<*dummy answer, give up bit*>
std_error (ztape, status, hwds)
else
if status extract 2 = 3 then
begin <*normal answer, give up bit*>
write (out,
"nl", 2, <:*status = :>);
for i := 0 step 1 until 23 do
if status shift i < 0 then
write (out,
"sp", 1, case (i + 1) of (
<:intervention:>,
<:parity error:>,
<:timer:>,
<:data overrun:>,
<:block length error:>,
<:end of document:>,
<:load point:>,
<:tape mark:>,
<:writing enabled:>,
<:mode error:>,
<:read error:>,
<:disk error:>,
<:checksum error:>,
<:bit 13:>,
<:bit 14:>,
<:stopped:>,
<:word defect:>,
<:position error:>,
<:process does not exist:>,
<:disconnected:>,
<:unintelligible:>,
<:rejected:>,
<:normal answer:>,
<:give up:>
));
end <*normal answer, give up bit*>;
getzone__6 (ztape, zdescr );
getshare_6 (ztape, sdescr, zdescr (17)); <*used share*>
operation := sdescr ( 4) shift (-12);
if status shift (-18) extract 1 = 1 <*eot*> and
operation = 3 <*input*> and
hwds = 0 <*nothing xferred*> then
begin <*eot and nothing input*>
hwds := 2;
status := 0;
end else
if status shift (-14) extract 1 = 1 then
begin <*mode error*>
if startmode = 0 then
startmode := 1 shift 11 add (zdescr (1) shift (-12) extract 11);
for i := 1 step 1 until 6 do
if zdescr (1) shift (-12) extract 11 = ( case i of (
0, 2, 4, 6, 128, 132 ) ) then
begin j := i; i := 6; end;
j := if j = 6 then 1 else j + 1;
nextmode := 1 shift 11 add ( case j of (
0, 2, 4, 6, 128, 132 ) );
if test then
write (out,
"nl", 2, <:block procedure tape zone :>,
"nl", 1, <:operation = :>, operation,
"nl", 1, <: , mode = :>, sdescr (4) extract 12,
"nl", 1, <:status = :>, status,
"nl", 1, <:hwds xferred = :>, hwds,
"nl", 1, <:file count = :>, zdescr (7),
"nl", 1, <:block count = :>, zdescr (8),
"nl", 1, <:startmode = :>, startmode extract 11,
"nl", 1, <:next mode = :>, next_mode extract 11);
if nextmode = startmode then
std_error (ztape, status, hwds);
close (ztape, false);
open (ztape, nextmode shift 12 + 18, zdescr.docname, giveup);
setposition (ztape, zdescr (7), zdescr (8));
write (out,
"nl", 2, <:*mode error on :>, true, 12, zdescr.docname,
"sp", 1, <:, trying :> , case j of (
<:mtlh:>, <:mte :>, <:mtll:>, <:nrze:>, <:mthh:>, <:mthl:>));
status := hwds := 0; <*position checked ok, in case of inrec repeat*>
end <*mode error*> else
if status shift (-6) extract 1 = 1 then
begin <*position error*>
hwds := 2;
status := 0;
end;
end <*ignore eot*>;
test := false;
giveup := 1 shift 18 + 1 shift 14 + 1 shift 7; <*eot, mode error, w.defect*>
write (out, <:<10>name : :>); setposition (out, 0, 0);
readstring (in, name, 1);
open (z, 18, name, giveup);
for format := out_text_in_int (out, <:
format : 0 all below except bits
1 halfword
2 word
3 long
4 real
5 text
6 text
7 bits
8 chars
9 all
: :>)
while format >= 0 do
begin <*format*>
for file := out_text_in_int (out, <:<10>file : :>)
while file >= 0 do
begin <*file*>
for block := out_text_in_int (out, <:<10>block : :>)
while block >= 0 do
begin <*block*>
setposition (z, file, block);
length := inrec6 (z, 0);
inrec6 (z, length);
for from := out_text_in_int (out, <:<10>from hwd : :>)
while from >= 0 do
begin <*from*>
for to := out_text_in_int (out, <:<10>to hwd : :>)
while to >= 0 do
begin <*to*>
if from > length then from := length;
if to > length then to := length;
if to < from then to := from ;
write (out, <:<10>tapename : :>, name, <: file : :>, file,
<: block : :>, block, <: length : :>, length);
if length > 0 then
write_all (out, z.from, to - from + 2, format);
end <*to*>;
end <*from*>;
end <*block*>;
end <*file*>;
end <*format*>;
close (z, false);
end <*block for zone*>;
end;
scope user checktape
end
▶EOF◀