|
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: 13056 (0x3300)
Types: TextFile
Names: »discinfo5tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »discinfo5tx «
(discinfo = algol connect.no
end)
begin
<* initboot fra rc8000, tilrettet rc9000
discinfo 890224/pon
-"- 890707/fgs *>
boolean change_disc, change_dev_no, lookupkit;
integer autodesc, i, j, k, p, process_addr,
_ newline_separator, space_separator, point_separator,
_ integer_kind, name_kind, device_no, l_disc, test,
_ max_discs, dev_no_idx;
integer array dummy(1:1), process_description(1 : 6),
dev_no(1 : 256), discdesc(1:256);
integer array field iaf;
real array discname, arr, paramname(1:2);
long array progname, outfile, chainname (1:2);
zone discfile(128,1,stderror);
procedure syntax(no);
integer no ;
begin
write(out,"nl",1, <:***:>, progname, <: syntax, param no:>,<<ddd>,no,
_ "nl",2, <:(outfile =):>,
_ "nl",2, <: :>, progname,
_ "sp",1, <:<discname> (lookup/discs/disc/chdevno):>,
_ "nl",2, <:<lookup> = lookup:>,
_ "nl",1, <:<discs> = discs.<no of logical discs>:>,
_ "nl",1, <:<disc> = disc.<discno>.<first segm>.<no of segs>.<type>.<logical devno>:>,
_ "nl",1, <:<chdevno> = chdevno.<old devno>.<new devno>:>,
_ "nl",2 );
goto stop;
end;
procedure monitor_error(text,no);
integer text,no ;
begin
write(out,<:<10>***:>, progname, <: :>);
if text = 1 then
write(out,<:create, :>, case no of (
<:function forbidden in calling process:>,
<:calling proc not user; catalog i/o error:>,
<:name conflict:>,
<:device no does not exist:>,
<:device is reserved by another user:>,
<:name format illegal:>),<:<10>:>)
else
write(out,<:reserve, :>, case no of (
<:reserved by another process:>,
<:calling proc not user; proc cannot be reserved:>,
<:process does not exist:>),<:<10>:>);
goto stop;
end;
procedure print_discinfo (d);
integer array d;
begin
if test > 255 then test := 255
else
test := ((test + 3) // 4) * 4 - 1;
for i := 0 step 4 until test do
begin
write (out, "nl",1, <<ddd>, i * 2);
for j := 1 step 1 until 4 do
write (out, <<ddddd>, d.iaf(i+j) shift (-12) extract 12,
_ d.iaf(i+j) extract 12,
_ <<-dddddddd>, d.iaf(i+j) );
if d.iaf (i + 4) = -1 then i := test;
end;
end;
integer
procedure stack_current_output (file_name);
long array file_name ;
begin
integer result ;
result := 1 shift 2; <*1<2 <=> 1 segment, temporary*>
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;
procedure maybe_device_status (z);
zone z ;
<***********************************************************>
<* *>
<* The procedure writes on the zone z a device status mes- *>
<* sage with document name and status bit names the same *>
<* way fp does if the program was to terminate with a give *>
<* up alarm instead of having trapped one. *>
<* *>
<***********************************************************>
begin
integer status, cause, param, bit;
long array text (1:4);
long array field docname;
docname := 8; <*fields possible docname in text*>
status := getalarm (text);
cause := alarmcause extract 24 ;
param := alarmcause shift (-24);
if cause = -11 then
begin <*give up*>
write (z, "nl", 1,
<:device status :>, text.docname);
for bit := 0 step 1 until 23 do
if status shift bit < 0 then
write (z, "nl", 1, case (bit + 1) of (
<:intervention:>,
<:parity error:>,
<:timer:>,
<:data overrun:>,
<:block length error:>,
<:end of document:>,
<:load point:>,
<:tape mark or attention:>,
<:writing enabled:>,
<:mode error:>,
<:read error:>,
<:card rejected or disk error:>,
<:checksum error:>,
<:bit 13:>,
<:bit 14:>,
<:stopped:>,
<:word defect:>,
<:position error:>,
<:process does not exist:>,
<:disconnected:>,
<:unintelligible:>,
<:rejected:>,
<:normal:>,
<:hard error:>));
write (z, "nl", 1);
end;
end maybe device status;
trapmode := 1 shift 10;
newline_separator := 2;
space_separator := 4;
point_separator := 8;
integer_kind := 4;
name_kind := 10;
deviceno := -1;
lookupkit := true;
change_dev_no := false;
test := 0;
l_disc := 6; <* length of a logical disc description *>
iaf := 0;
maxdiscs := 7000;
dev_no(1) := -1;
dev_no_idx := -1;
discdesc(1) := 0;
for i:= 2 step 1 until 256 do
begin
dev_no(i) := discdesc(i):= -1;
end;
errorbits := 3; <*ok.no, warning.yes*>
trap (error);
system (4, 0, out_file);
k :=
system (4, 1, progname);
if k 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 <::> ;
p := 1 ;
end;
end <*no left side*> else
p := 2;
if out_file (1) <> long <::> then
begin <*stack current out and connect*>
i := stack_current_output (out_file);
if i <> 0 then
begin
write (out, "nl", 1, <:***:>, progname, "sp", 1, <:connect :>, outfile,
"sp", 1, case i 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*>;
<********** check <discname> **********>
k:= system(4, increase (p), discname);
if k extract 12 <> name_kind then
syntax (1);
<********** check <params> **********>
for k:= system(4,p,paramname) while k <> 0 do
begin
if k <> space_separator shift 12 add name_kind
then syntax(p);
p:= p + 1; k:= system(4,p,arr);
if paramname(1) = real <:test:> then
test := arr(1)
else
if paramname(1) shift (-16) shift 16 = real <:look:> then
lookupkit:= true
else
if paramname(1) = real<:discs:> then <* discs.<no of log. discs> *>
maxdiscs:= arr(1)
else
if paramname(1) = real<:disc:> then
begin <* disc.<discno>.<1.segm>.<no of segm>.<type>.<log. devno> *>
change_disc := true;
if change_dev_no then syntax(p);
if k <> point_separator shift 12 add integer_kind then syntax(p);
i:= arr(1);
if i > discdesc(1) then discdesc(1):= i;
for j:= 0 step 1 until 3 do
begin
k:= system(4,p+1,arr);
if k <> point_separator shift 12 add integer_kind then syntax(p+1);
if j=3 then
discdesc(i*3+1):= discdesc(i*3+1) shift 12 + arr(1)
else
discdesc(i*3+j-1):= arr(1);
p:= p+1;
end;
end else
if paramname(1) shift (-24) shift 24 = real <:chd:> then
begin <* chdevno.<old devno>.<new devno> *>
change_dev_no := lookupkit := true;
if change_disc then syntax(p);
if k <> point_separator shift 12 add integer_kind then syntax(p);
dev_no_idx := dev_no_idx + 2;
dev_no (dev_no_idx) := arr(1);
k := system (4, p+1, arr);
if k <> point_separator shift 12 add integer_kind then syntax(p+1);
dev_no (dev_no_idx + 1) := arr(1);
p := p + 1;
end else
syntax (p); <* not found *>
p:= p + 1;
end;
<********** open discfile, create and reserve discprocess **********>
trap (error);
i:= 1;
open(discfile, 0, string discname(increase(i)),0);
process_addr := monitor(4)process_description:(discfile, 0, dummy);
i:= monitor(8)reserve_process:(discfile,0,dummy);
if i <> 0 then monitor_error(2,i);
<* check if discprocess*>
system(5)copy core:(process_addr, process_description);
if process_description(1) = 6 then
begin
setposition(discfile,0,0);
inrec6(discfile,512);
if test > 0 then
print_discinfo (discfile.iaf);
i:= discfile.iaf(1)*2+1;
autodesc := discfile.iaf(1);
if maxdiscs <= discfile.iaf(i+1) extract 12 then discdesc(1):= maxdiscs
else if discfile.iaf(i+1) extract 12 > discdesc(1) then
discdesc(1):=discfile.iaf(i+1) extract 12;
discdesc(1):= discdesc(1) + l_disc shift 12;
j:= (discfile.iaf(i+1) extract 12) * (l_disc/2);
i:= i+1;
for k:= 1 step 1 until j do
if discdesc(k+1)=-1 then
discdesc(k+1):= discfile.iaf(k+i);
setposition(discfile,0,0);
end else
begin
i := 1;
write (out, <:<10>***:>, progname, <:, :>, string discname(increase(i)),
_ <:, not a disc:>, "nl",1,
_ <: kind =:>, process_description(1) );
if test > 0 then
for i := 1 step 1 until 6 do
write (out, "nl",1, <<ddddddddd>, process_description (i) );
goto stop;
end;
if change_disc or change_dev_no then
begin
i:= autodesc * 2 + 2;
j:= (discdesc(1) extract 12) * (l_disc/2);
if i+j > 256 then
write(out,<:<10>***:>, progname, <: descriptor segment too big:>)
else
begin
setposition(discfile,0,0);
outrec6(discfile,512);
if change_dev_no then
begin
boolean not_found;
integer i;
for i := 1 step 2 until dev_no_idx do
begin
not_found := true;
for k := 2 step 3 until j+1 do
if dev_no(i) = discdesc(k+2) extract 12 then
begin <* log. device number found *>
boolean dev_no_used;
integer x;
<* undersøg om nyt devno er i brug *>
dev_no_used := not_found := false;
for x := 2 step 3 until j+1 do
if dev_no(i+1) = discdesc (x+2) extract 12 then
dev_no_used := true;
if -,dev_no_used then
begin <* indsæt nyt devno *>
discdesc(k+2) := discdesc(k+2) shift (-12) shift 12 + dev_no (i+1);
write (out, <:<10>logical devno changed from:>, dev_no (i),
<: to:>, dev_no(i+1) );
dev_no(i) := dev_no(i+1) := 0;
end else
_ write (out, <:<10>*** new logical devno :>, dev_no(i+1),
_ <: in use:>);
end for k;
if not_found then
write (out, <:<10>*** logical devno :>, dev_no(i), <: not found:>);
end for i;
end;
<* flyt discbeskriv tilbage *>
for k:= 1 step 1 until j+1 do
discfile.iaf (i+k-1) := discdesc (k);
if test > 0 then
print_discinfo (discdesc);
end;
end;
if lookupkit then
begin
j := 1;
i := discdesc(1) extract 12;
write(out, "nl",2, <:lookup, disc: :>, string discname(increase(j)),
"nl",1, <:no of logical discs:>, <<ddd>,i,
"nl",2, <:discno:>, "sp", 8,
<:first segm no of segs type devno:>, "nl",1 );
for j:= 1 step 1 until i do
write(out, <<dddd>, j, "sp",10, <:: :>, <<dddddddd>, discdesc(j*3-1),
"sp",5, discdesc(j*3),
<<dddd>, "sp",5, discdesc(j*3+1) shift (-12),
"sp",5, discdesc(j*3+1) extract 12, "nl",1 );
end;
if false then
error: stop:
maybe_device_status (out);
close (discfile, false);
monitor (10)release process:(discfile, 0, dummy);
if outfile (1) <> long <::> then
unstack_current_output;
end
▶EOF◀