|
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: 16128 (0x3f00)
Types: TextFile
Names: »printz3tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »printz3tx «
mode list.yes
printzones=algol connect.no,
; details.8.8 xref.yes list.yes bossline.yes blocks.yes survey.yes
begin
comment
This program will print the key variables of a stopped algol 8
program located either in core or as an image on disk or tape. The
image may be made by the operating systems S or BOSS.
It is assumed that:
1) The core area or core image actually contains an algol 8 program
stopped by its parent.
2) The file processor, FP, has not been removed by the algol program.
3) The image of a process is large enough to hold the entire process.
Strange error reactions will occur if these assumptions do not
hold.
Call of the program:
1) printzones
2) printzones <internal process name>
3) printzones <file descriptor>
In the first case, the program will try to conect itself to a file called
"image". In the second case, the program will try to print the key variables
directly from core. In the third case, connection is made to a disk area
or an other file, described by the name of the file descriptor.
Various error messages may occur. Some are given and explained below.
1) block 2 recprocs6
called from .....
2) giveup 8 algolcheck
called from .....
..... .....
***device status <file>
stopped
process does not exist
3) call error, as <explanation>
no run 0 .....
called from .....
where the explanation may be:
3a) no file or process name
3b) internal process unreadable
3c) internal process invisible
3d) no coredump area exists
\f
The usual explanations are:
1: The core dump image could not hold the entire process.
2: Too few area processes or the file descriptor describes a non-
existing area.
3a: The program has been called with a left hand side, or an integer
follows the name of the program.
3b: The CPA of the calling process does not permit analysis of the
internal process to be analyzed.
3c: The address base of the calling process does not permit analysis
of the internal process to be analyzed, or the process has some
primary store in common with the analyzing process. In this case
the process to be analyzed is either an ancestor not fulfilling
assumption 1 above, or it is a process swopped out at present.
3d: The file descriptor given in the call does not exist. ;
\f
zone corepict(128, 1, stderror);
integer field i, j, k, recbase, lastby, reclen, lowix,
nta, modekind, basebuf, lastbuf, chain, iff2, iff,
segcount, zonest, usedsh, firstsh, lastsh, state,
opmode, first, last, segno, top, czc, cappetite, cmode,
firstarray, lastarray, cfirstvar;
long lay, blay;
long array str, progname, outfile, chainname (1:2);
integer chainaddr, noofshares, bias, shlast, shfirst, shuse, kind,
act, activities, azone, curcza, atable, acur, csr, endchain,
threesp, base,openkind, openfile, openblock, threechar,
sepleng, paramno, result;
long array field name, laf; integer array field iaf;
procedure printkey(addr, s);
value addr ;
integer addr ;
string s ;
write(out, ".", 54-write(out, "nl", 1,
string lay, addr+chain, <:: :>, s),
":", 1, string lay, getword(corepict, addr));
\f
procedure printz;
begin integer i, j, k; integer field iff;
for iff := 2 step 2 until 8 do str.iff :=
logand(logor(getword(corepict, name + iff), threesp), threechar);
write(out, "*", 73 - write(out,
<:<10><10>******************************zone::>, <<d>, chain),
"nl", 2);
write(out, string lay, ".", 25-write(out,
<:basebuf, lastbuf:>), <:::>, getword(corepict, basebuf), <:,:>,
getword(corepict, lastbuf), <:<10>:>);
k:= getword(corepict, reclen); j := getword(corepict, recbase);
write(out, string lay, ".", 25 - write(out,
<:recbase, reclast, reclen:>), <:::>, j,<:,:>, j+k+1,
<:,:>, k,<:<10>:>);
write(out, string lay, ".", 25 - write(out,
<:last by, lower ix(=0):>), <:::>,
getword(corepict, lastby), <:,:>, getword(corepict, lowix));
write(out, ".", 26-write(out, <:<10>name in zone:>),
":", 1, "sp", 5, str);
i := getword(corepict, modekind);
kind := i extract 12; i := i shift(-12) extract 11;
write(out, ".", 26 - write(out, <:<10>mode, kind, n.t.addr:>),
string lay, <:::>, i, <:,:>, kind, <:,:>, getword(corepict, nta),
"nl", 1);
write(out, string lay, ".", 25 - write(out,
<:segm count, zstate:>), <:::>, getword(corepict, segcount),
<:,:>, getword(corepict, zonest), <:<10>:>);
shlast := getword(corepict, lastsh) - chain;
shfirst := getword(corepict, firstsh) - chain;
shuse := getword(corepict, usedsh) - chain;
noofshares := (shlast - shfirst)//24 + 1;
for i := 1 step 1 until noofshares do
begin
write(out, ".", 25 - write(out, <:share no, addr, state:>), ":", 1,
string lay, (shuse-shfirst)//24 + 1, ",", 1, shuse+chain,
",", 1, getword(corepict, shuse+state), "nl", 1);
j := getword(corepict, shuse+opmode);
write(out, ".", 25 - write(out, "-", 5, <: operation, mode:>), ":", 1,
string blay, 0, "sp", 1, string lay, j shift(-12),
",", 1, j extract 12, "nl", 1);
write(out, ".", 25 - write(out, "sp", 6, <:first, last shared:>),
":", 1, string blay, 0, "sp", 1, string lay,
getword(corepict, shuse+first), ",", 1,
getword(corepict, shuse+last), "nl", 1);
write(out, ".", 25 - write(out, "sp", 6, if kind = 4 then
<:segm no, :> else <:..., :>, <:top trf:>), ":", 1, string blay,
0, "sp", 1, getword(corepict, shuse+segno), string lay,
",", 1, getword(corepict, shuse+top), "nl", 1);
shuse := if shuse < shlast then shuse+24 else shfirst;
end shareprinting;
end printz;
\f
integer procedure error(s); string s;
begin
write(out, <:<10>***:>, progname, <: call error, as :>, s);
system(9, 0, <:<10>no run:>);
end;
integer procedure getword(z, addr);
value addr ;
zone z ;
integer addr ;
begin integer field rel; own integer oldseg;
addr := addr - bias + chain;
rel := logand(addr, 510) + 2; <*similar to slang addressing*>
if addr shift (-9) <> oldseg then
begin
oldseg := addr shift(-9);
if base <> 0 then system(5)move_core:(oldseg shift 9 + base, z) else
begin
setposition(z, openfile, openblock+oldseg); inrec6(z, 512);
end;
end;
getword := z.rel;
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
segcount := -10; zonest := -2;
recbase := 0; lastby := 2; reclen := 4; lowix := 6;
nta := -16; modekind := name := -26;
lastbuf := -34; basebuf := -36;
usedsh := -32; firstsh := -30; lastsh := -28;
state := 0; opmode := 6; first := 2;
act := activities := 0; azone := curcza := 1 shift 22;
atable := acur := 0; cappetite := 2; cfirstvar := 4;
firstarray := -10; lastarray := 8; cmode := 6;
last := 4; czc := -6; segno := 12; top := 22;
iff2 := 2; lay := long<< -d ddd ddd>; blay := long<< -b ddd ddd>;
threesp := (32 shift 8 + 32)shift 8 + 32;
threechar := (127 shift 8 + 127)shift 8 + 127;
base := iaf := openblock := openfile := openkind := 0;
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 <::> ;
param_no := 1 ;
end;
end <*no left side*> else
param_no := 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*>;
\f
base := system(4) fp_param :(paramno, str);
if base = 0 then
begin
str(1) := long <:image:>; str(2) := 0;
end else if base <> 4 shift 12 + 10 then error(<:no file or process name:>);
open(corepict, 0, str, 0); close(corepict, false); <*to insert the name*>
if base <> 0 then
begin
base := monitor(4)process_descr:(corepict, 0, corepict.iaf);
if base <> 0 then
begin
system(5)move_core:(base, corepict);
if corepict.iff2 <> 0 then base := 0
else
begin integer phlow, phtop, mybase, mycpa;
base := corepict.iaf(50);
phlow := corepict.iaf(12)+base;
phtop := corepict.iaf(13)+base;
system(5)move_core:(system(6)own_process:(0, str), corepict);
mybase := corepict.iaf(50); mycpa := corepict.iaf(51);
base := if phtop <= corepict.iaf(12) then phlow else
if phlow < corepict.iaf(13)+mybase then
error(<:internal process invisible:>) else
if phtop > mycpa then error(<:internal process unreadable:>) else
( phlow - mybase);
system(5)move_core:(base, corepict);
end;
end;
end;
if base = 0 then
begin
if monitor(42)lookup entry:(corepict, 0, corepict.iaf) <> 0
then error(<:no coredump area exists:>);
if corepict.iaf(1) < 0 then
begin
openkind := corepict.iaf(1) extract 23;
laf := 2;
str(1) := corepict.laf(1); str(2) := corepict.laf(2);
end else openkind := 4;
openfile := corepict.iaf(7);
openblock := corepict.iaf(8);
open(corepict, openkind, str, 0);
setposition(corepict, openfile, openblock);
inrec6(corepict, 512);
end;
bias := corepict.iff2;
chain := 1536+bias;
write(out, "=", write(out, "nl", 1, "=", 79,
<:<10><10>key variables of running system<10>:>)-83, "nl", 1);
printkey( 0, <:victim:>);
printkey( 44, <:n.t.a, program name:>);
for iff := 2 step 2 until 8 do str.iff :=
logand(logor(getword(corepict, 34+iff), threesp), threechar);
write(out, <:, :>, str);
printkey( 46, <:stack bottom:>);
printkey( 48, <:spare mess buffer:>);
printkey( 60, <:UV as integer, long, and maybe real:>);
for iff := 2, 4 do str.iff := getword(corepict, 56+iff);
write(out, <:,<10>:>, string blay, 0, << -ddd ddd ddd ddd ddd>, str(1));
k := str(1) shift(-46);
if str(1) = 2048 or k = 1 or k = 3 then
write(out, ",", 1, << -d.ddd ddd'+zdd>, real str(1));
printkey( 62, <:last used:>);
printkey( 64, <:last of program:>);
printkey( 66, <:first of program:>);
printkey( 68, <:segment table base:>);
printkey( 76, <:blocksread:>);
printkey( 78, <:saved stackref:>);
printkey( 80, <:saved w3:>);
printkey( 86, <:first of process area:>);
printkey( 98, <:top program segment table:>);
printkey(100, <:last segment table:>);
printkey(102, <:first of segments:>);
printkey(104, <:program mode:>);
printkey(106, <:blocksout:>);
printkey(118, <:n.t.a., name of virtual store:>);
for iff := 2 step 2 until 8 do str.iff :=
logand(logor(getword(corepict, 108 + iff), threesp), threechar);
write(out, <:, :>, str);
if getword(corepict, 148<*CZA*>) <> 1 shift 22 then
begin
printkey(142, <:(incarnation-1)*2:>);
printkey(146, <:yungest context stackref, CSR:>); csr := getword(corepict, 146);
printkey(148, <:youngest context zone, CZA:>); curcza := getword(corepict, 148);
printkey(160, <:current context mode:>);
end;
printkey(164, <:trapmode:>);
activities := getword(corepict, 180<*no activities*>);
if abs activities > 0 then
begin
printkey(170, <:max last used:>);
printkey(172, <:limit last used:>);
printkey(174, <:temp last used:>);
printkey(176, <:current activity, table entry and number:>);
acur := getword(corepict, 178); write(out, ",", 1, string lay, acur);
printkey(180, <:number of activities:>);
printkey(182, <:activity table base:>); atable := getword(corepict, 182);
printkey(184, <:activity zone:>); azone := getword(corepict, 184);
printkey(186, <:activity stackref:>);
printkey(188, <:last used or temp last used:>);
printkey(190, <:current stack bottom:>);
end;
write(out, "=",
write(out, <:<10><10><10>zones in and out<10>:>)-4, "nl", 1);
for chain := 360+bias, 410+bias do printz;
write(out, "nl", 1, "=", 79, "nl", 2);
endchain := chain := bias-12 + 1536+74; <*correction + rel addr in core*>
repeat
if getword(corepict, 12) <> 1 shift 22 then
write(out, "=", write(out, <:zone chain of :>,
if activities >= 0 then
(if act = 0 then <:main program<10>:> else <:this activity<10>:>)
else if act = 0 then <:current activity<10>:> else
if abs acur = act then <:main program<10>:> else
<:this activity<10>:>) - 1);
for chain := getword(corepict, 12) while chain <> 1 shift 22 do
begin
if chain = curcza then
begin
write(out, "*", 73 - write(out,
<:<10><10>****************************context::>, <<d>, chain),
"nl", 2);
curcza := getword(corepict, czc);
write(out, string lay, ".", 25-write(out,
<:stackref, appetite, mode:>), <:::>, csr,
<:,:>, getword(corepict, cappetite), <:,:>,
getword(corepict, cmode), <:<10>:>);
csr := getword(corepict, czc-2);
write(out, string lay, ".", 25 - write(out,
<:f. var, f. arr, l. arr:>), <:::>, getword(corepict, cfirstvar),
<:,:>, getword(corepict, firstarray), <:,:>,
getword(corepict, lastarray), <:<10>:>);
end
else if chain = azone then
write(out, "*", 73 - write(out,
<:<10><10>****************************activity::>, <<d>, chain),
"nl", 2) else printz;
endchain := chain;
end;
act := act+1;
if act <= abs activities then
begin
chain := atable := atable+20;
write(out, "nl", 1, "=", 79);
write(out, "=", write(out, <:<10><10>activity number::>,
string lay, act, if act = acur then <: ****current!!<10>:>
else if act = -acur then <: ****current disabled!!<10>:>
else <:<10>:>) - 3, "nl", 1);
printkey( 0, <:first core:>); k := getword(corepict, 0);
printkey( 2, <:stack bottom:>);
printkey( 4, <:last used:>);
printkey(18, <:limit last used:>);
printkey( 8, <:activity state:>); i := getword(corepict, 8);
csr := getword(corepict, 12);
curcza := getword(corepict, 14); chain := k;
if i <> 0 then
begin
if atable = getword(corepict, -2) then
begin
printkey( 0, <:possible ref to zone having passivated:>);
chain := atable + 10 - 12;
end else chain := endchain;
end
else chain := if abs acur = act then atable+10-12 else endchain;
end;
write(out, "nl", 2);
until act > abs activities;
write(out, "nl", 1, "=", 79, "nl", 1);
if outfile (1) <> long <::> then
unstack_current_output;
end* *slut program
end
finis
▶EOF◀