DataMuseum.dk

top - metrics - download

    Length: 50688 (0xc600)
    Types: TextFile
    Names: »tdynamic«

└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
    └─⟦6b41451d2⟧ 
        └─⟦this⟧ »tdynamic« 

TextFile

process dynamic(var semvector:system_vector);

(*********************************************************************
*                                                                    *
*        P R O G R A M :  D Y N A M I C.                             *
*                                                                    *
*********************************************************************)


(********************************************************************
*                                                                   *
*   FUNCTION:      The dynamic module is used to gather statistics  *
*                  for the dynamic instruction frequence.           *
*                                                                   *
*   EXTERNALS:     None                                             *
*                                                                   *
*   VAR PARAMS:    None                                             *
*                                                                   *
*   SEMAPHORES:    The module sends to the system semaphore         *
*                  " operatorsem."                                  *
*                                                                   *
*   PREREQUISITES: Special HW-module CPU202 - with modified         *
*                  microprogram. Probably one or two additional     *
*                  MEM-modules are required too.                    *
*                                                                   *
********************************************************************)


const
version=0;
revision=
11
;





(*  const *)

const
noofproc=30;     (* increase, if more processes should be involved *)
        (* in the instruction freqence gathering *)
write=2;
read=1;
firstindex=6+alfalength;
linelength=80;
lastindex=firstindex+(linelength-1);
ok=0;
opbufsize=80;
pu=0;
priority=-1;
procincsize = maxint;    (* size in words *)
noinstmin1 = 255;
maxlevel = 10;    (* the tree searched cannot be deeper *)
quant = 50;   (* used as upper limit in sorting the most freequent
instructions *)
findappetite = maxlevel*50;
listappetite = maxlevel*50;
tproc = "total proc. ";
sp20 = "                    ";
adamname = "adam        ";
nameerror = "name not found      ";
ancestormissing = "ancestor not found  ";
namein = "name inserted       ";
treedeptherror = "tree too deep       ";
notdef = "channel not defined ";

(* type *)

type

quantitytype = (all,from,top,illegal);

formattype = (prc,r,a,dummy);

qconvtype = array(char) of quantitytype;

fconvtype = array(char) of formattype;

ptrrecord = record
p : ^shadow;
end;
ptrshadow = ^shadow;
alfa6 = array(1..6) of char;
int = array(0..noinstmin1) of alfa6;

nameentry = packed record
pred : 0..255;
succ:0..255;
index : integer;
name : alfa;
procinc : ^shadow;
end;

resulttype = (okay , rangeerror, toomanyproc , multible);
exresult = (fine , notfound , indexerror );

long = record
least,
most : integer;
end;

real =
record
first,
last
: integer;
end;

totaltype = array(0..noofproc) of long;
proctype = array(0..255) of long;

tabletype = array(0..noofproc) of proctype;

toptype = array(0..quant) of integer;

opbuftype = record
first,
last,
next : integer;
name : alfa;
data : array(firstindex..lastindex) of char;
end;

alfa20 = array(1..20) of char;

const

bl = "      ";

iname=int(bl,"jmphc ",bl,"jmppd ","jmprw ","jmcht ","jmzeq ","jmzne ",
"jmzlt ","jmzgt ","jmzle ","jmzge ",4***bl,
"csign ","cwait ","csens ","csell ","cstdr ","cstop ","cllst ","cufst ",
"sched ","crget ","crput ","cskip ","      ",bl,"crram ","cwram ",
"crele ","cwtac ","      ","      ","cgreg ","cslev ","cexch ",bl,
8***bl,
"iowc  ","iogo  ","iors  ","iorw  ","ioww  ","iogi  ","iorbb ","iorbw ",
"iowbb ","iowbw ","      ","iocci ","iocda ","      ","ioibx ","ionci ",
8***bl,
"uadd  ","usub  ","umul  ","udiv  ","umod  ","teqad ","swap  ","xor   ",
"neg   ","not   ","tnill ","abs   ","compl ","add   ","sub   ","mul   ",
"div   ","mod   ","sha   ","and   ","or    ","shc   ","ult   ","eq    ",
"ne    ","lt    ","gt    ","le    ","ge    ","setcr ","setun ","setin ",
"setdi ","seteq ","setsb ","setsp ","settm ","setad ","tlock ","topen ",
"intrs ","index ","inprs ","inpss ",4***bl,
8***bl,
"renpb ","renhb ","rechw ","rechd ","reaxd ","reaad ","reard ","reald ",
"reagd ","reaid ","reasd ","uadhw ",4***bl,
"revpw ","revpd ","rfvab ","revaw ","revad ","revaf ","revlb ","revlw ",
"revld ","revlf ","revgb ","revgw ","revgd ","revgf ","revib ","reviw ",
"revid ","revif ","revsb ","revsw ","revsd ","revsf ","      ","revsm ",
"moveg ","moveb ",6***bl,
"stnhb ","stvab ","stvaw ","stvad ","stvaf ","stvlb ","stvlw ","stvld ",
"stvlf ","stvgb ","stvgw ","stvgd ","stvgf ","stvib ","stviw ","stvid ",
"stvif ","stvsb ","stvsw ","stvsd ","stvsf ",3***bl,
"      ","stcea ","      ","      ","setst ",3***bl,
"pcals ","pcald ","pexit ",5***bl,
8***bl,
"lpush ","lpop  ","lrese ","llock ",4***bl,
8***bl,
"mnoop ","mcist ","mbtes ","mbset ","mxept ","madlu ","mwi   ","mwt   ",
"mwis  ","mwit  ","mwst  ","mwist ","mwtac ","mtime ","mcis  ","mcit  ");

qtable=qconvtype(97***illegal,all,4***illegal,from,13***illegal,top,11***illegal);

ftable = fconvtype(37***dummy,prc,59***dummy,a,16***dummy,r,13***dummy);


var

(* pools *)

opbufpool : pool 2 of opbuftype;
tablepool: pool 1 of tabletype;

(* semaphores *)

tablesem,    (* used in connection with alloc only *)
wsem,        (* buffers written by the operator module
is returned here after output *)
wrsem        (* buffers with content read by the operator
module is returned here after input *)
: semaphore;

(* references *)

chmess,      (* channel message used to modify reg.ps indivisible *)
stopmsg,
tableref,    (* ref to table *)
opinref,     (* ref to buffer from operator *)
opoutref     (* ref to buffer to operator *)
: reference;

(* pointers *)

ressh : ^shadow;
ancsh : ^shadow;
opsem : ^semaphore;
nilp : !^shadow;

(* char *)

command : char; (* the first char typed by the operator *)

(* integers *)

mostsignificant,leastsignificant,
indx,barrier,
depth,branchno,
firstword,
lastword,
incharsleft,
number,
i,
j,
k
: integer;

(* booleans *)

longowerflow,  (* soft overflow from addlong *)
readok          (* indicates if the last call of readinteger was
succesfull *)
: boolean;
forever : boolean := false;
debugon : boolean := false;
foundcandidate : boolean;
argerror : boolean;

(* user types *)

format,quantity : alfa;
onoff : alfa;
candidate : alfa;
ancestor : alfa;
total : totaltype;
totalall : long;
adammsgheader : message_header;
adamshadow : shadow;
adamaddr : addr;
adamsh : ^shadow;
monitormsgheader : message_header;
monitorshadow : shadow;
monitoraddr : addr;
monitorsh : ^shadow;

timermsgheader : message_header;
timershadow : shadow;
timeraddr : addr;
timersh : ^shadow;

allocmsgheader : message_header;
allocshadow : shadow;
allocaddr : addr;
allocsh : ^shadow;

linkermsgheader : message_header;
linkershadow : shadow;
linkeraddr : addr;
linkersh : ^shadow;

start : addr;   (* used to contain address of table *)
includedtable : packed record
used : 0..255;
free : 0..255;
namelist : array(1..noofproc) of nameentry;
end;

(* externals *)

procedure getregister(var value : integer;index : integer); external;

procedure setregister(value,index : integer); external;

procedure initref(var x : reference; var y : message_header); 
external;

function asgnptradr(a : addr) : ^shadow; external;

function refshadow(var sh : shadow) : ^shadow;
external;

procedure checkstack(appetite : integer);
external;
(* forwards *)

procedure outtext12(text : alfa);
forward;

procedure outinteger(int,positions : integer);
forward;

procedure writenl;
forward;

procedure relprocinc(x : ptrshadow);
forward;

procedure debug(ch : char;i : integer);
forward;



(* functions and procedures *)


function equalptr(x,y : ^shadow) : boolean;
var
p1,p2 : ptrrecord;

begin
p1.p := x;
p2.p := y;
if p1 = p2 then equalptr := true else equalptr := false;
end;   (* equalptr *)


procedure initincludedtable;
(* all elements in includedtable are placed in the free list *)
const
noplusone = noofproc + 1;
var
i : integer;
begin
with includedtable do
begin
free := 1;
used := 0;
for i := 1 to noofproc do
begin
namelist(i).pred := i-1;
namelist(i).succ := (i+1) mod noplusone;
end
end
end; (* initincludedtable *)

procedure clearincluded;
(* the used list in included table is cleared and the processes excluded*)
var
i : integer;

begin
with includedtable do
begin
i := used;
while i < 0 do
begin
relprocinc(namelist(i).procinc);
i := namelist(i).succ;
end
end
end;  (* clear included *)
function insertname(xname : alfa; no : integer; x : ^shadow) : resulttype;

(* the function inserts xname into includedtable and checks for:
   -multible index occourance: result:=multible, xname inserted
   -index bounds violation: result:=rangeerror
   -noofproc exceeded: result = toomanyproc
   -succesfull insertion: result:=ok *)

var
idx,
occupied
: boolean;
i : integer;
freeold,usedold : integer;
begin
idx := (1 <= no) and (no <= noofproc);
if idx then
with includedtable do
begin
i := used;
debug("j",i);                   (* debugging *)
occupied := false;
while i <> 0 do
begin
debug("k",namelist(i).index);        (* debugging *)
if namelist(i).index = no then
begin
insertname := multible;   (* index already used *)
occupied := true;
i := 0;
end
else
i := namelist(i).succ;
end;  (* while i *)
debug("l",free);                     (* debugging *)
if free <> 0 then
begin
freeold := free;
usedold := used;
namelist(free).index := no;
namelist(free).procinc := x;
namelist(free).name := xname;
used := free;
free := namelist(freeold).succ;
namelist(used).pred := 0;
namelist(used).succ := usedold;
if usedold <> 0 then namelist(usedold).pred := used;
if free <> 0 then namelist(free).pred := 0;
if not occupied then insertname := okay;
end
else
insertname := toomanyproc;
end (* with *)
else
insertname := rangeerror;
end; (* insertname *)

function excludename(xname : alfa; no : integer;x : ^shadow) : exresult;

(* the function finds xname among the names in includedtable and
removes the entry from the used list if succesfull. result is:
- notfound if xname is not present
- indexerror if no <> index in all occourances of xname in table
- ok otherwise   *)

var
found : boolean;
i : integer;
begin
with includedtable do
begin
excludename := notfound;
found := false;
i := used;
debug("m",i);                         (* debugging *)
while i <> 0 do
if namelist(i).name = xname then
begin
excludename := indexerror;
found := true;
if (namelist(i).index = no) and (equalptr(x,namelist(i).procinc)) then
begin
excludename := fine;
if namelist(i).pred = 0 then used := namelist(i).succ
else
namelist(namelist(i).pred).succ := namelist(i).succ;
if namelist(i).succ <> 0 then
namelist(namelist(i).succ).pred := namelist(i).pred;
namelist(i).pred := 0;
namelist(i).succ := free;
if free <> 0 then namelist(free).pred := i;
free := i;
i := 0;
end (* if namelist *)
else
begin
i := namelist(i).succ;
debug("n",i);                              (* debugging *)
end
end (* while i <> *)
else
begin
i := namelist(i).succ;
debug("o",i);                         (* debugging *)
end;
end; (* with *)
end;  (* excludename *)


function findincluded(candidate : alfa; index : integer) : exresult;

(* candidate,index are searched for in the includedtable *)

var
found : boolean;
i : integer;

begin
with includedtable do
begin
findincluded := notfound;
found := false;
i := used;
while i <> 0 do
begin
debug("p",i);                         (* debugging *)
if namelist(i).name = candidate then
begin
findincluded := indexerror;
found := true;
if namelist(i).index = index then 
begin
findincluded := fine;
i := 0;
end
else
i := namelist(i).succ;
end
else
i := namelist(i).succ;
end
end
end;  (* findincluded *)


procedure listincluded;
(* the names of the process incarnations, which are in the used list
of the includedtable, are listed on the console *)

var
i : integer;
begin
with includedtable do
begin
i := used;
while i <> 0 do
begin
outtext12(namelist(i).name);
outinteger(namelist(i).index,3);
writenl;
i := namelist(i).succ;
end
end
end; (* listincluded *)

procedure outchar(ch : char);

(* writes ch into next free position in the output buffer *)

begin
lock opoutref as p : opbuftype do
with p do
begin
last := last + 1;
data(last) := ch;
end;
end; (* outchar *)

procedure outtext6(text : alfa6);

(* writes the text occupying 6 chars in the output buffer *)

var
i : integer;
begin
for i := 1 to 6 do
outchar(text(i));
end;  (* outtext6 *)

procedure outtext12(text : alfa);

(* writes the text occupying 12 chars into the output buffer *)

var
i : integer;
begin
for i := 1 to 12 do
outchar(text(i));
end; (* outtext *)

procedure outtext20(text : alfa20);

(* as outtext12 except for the number of chars *)

var
i : integer;
begin
for i := 1 to 20 do
outchar(text(i))
end; (* outtext20 *)

procedure outerror;
begin
outtext6("error ");
end;  (* outerror *)

procedure outargument;
begin
outtext12("in argument:");
end;   (* outargument *)


procedure outinteger(int, positions : integer);

(* writes the integer int into the output buffer occupying positions
chars of the buffer starting at last, which is updated accordingly *)

const
maxpos = 20;
var
digits : array(1..maxpos) of char;
i,
used : integer;
negative
: boolean;
begin
for i := 1 to maxpos do digits(i) := sp;
i := maxpos;
negative := int < 0;
repeat
digits(i) := chr(abs(int mod 10 + ord("0")));
int := int div 10;
i := i-1;
until (i = 1) or (int = 0);
if negative then
begin
digits(i) := "-";
i := i - 1;
end;
used := maxpos - i;
if int <> 0 then digits(1) := "*";
if (not(positions in(.1..maxpos.))) or
(positions < used) then positions := used;
for i := maxpos+1-positions to maxpos do
outchar(digits(i));
end;  (* outinteger *)

procedure outerrorarg(i : integer);
begin
outerror;
outargument;
outinteger(i,3);
end;  (* outerrorarg *)

procedure writenl;

(* prepares the output buffer for output to operator, and signals
the buffer to the operator semaphore *)

begin
if not nil(opoutref) then
begin
outchar(nl);
signal(opoutref,opsem^);
end;
wait(opoutref,wsem);
lock opoutref as p : opbuftype do
p.last := firstindex;
end;  (* writenl *)

procedure debug(ch : char; i : integer);
begin
if debugon then
begin
outchar(ch);
outchar(sp);
outinteger(i,8);
writenl;
end
end; (* debug *)

function readchar : char;

(* reads the next char from the input buffer, next is incremented
and charsleft is decremented *)

begin
lock opinref as p : opbuftype do
with p do
begin
readchar := data(next);
next := next+1;
end;
incharsleft := incharsleft-1;
end;  (* readchar *)

procedure repeatchar;

(* the char just used is redefined to be next char in the inputbuffer *)

begin
lock opinref as p : opbuftype do
p.next := p.next-1;
incharsleft := incharsleft+1;
end; (* repeatchar *)

function readinteger : integer;

(* reads the next integer from input buffer *)

const
digits = (."0".."9".);
signs = (."+".."-".);

var
negative, digit : boolean;
result : integer;
ch, oldchar : char;

begin
readok := false;
oldchar := nul;
ch := nul;
digit := false;
if incharsleft > 0 then
repeat
oldchar := ch;
ch := readchar;
digit := (ch in digits);
until digit or (incharsleft <= 0);
result := 0;
negative := oldchar = "-";
if digit then
begin
if ch in digits then result := ord(ch)-ord("0");
readok := true;
end;
while digit and (incharsleft > 0) do
begin
ch := readchar;
digit := ch in digits;
if digit then
begin
if negative and (result = 3276) and (ch = "8") then
begin
result := -32768;
negative := false;
end
else
result := result*10+(ord(ch)-ord("0"));
end
end; (* while *)
if negative then result := -result;
readinteger := result;
if incharsleft > 0 then
repeatchar;  (* put the stopchar back into the input buffer *)
end;  (* read integer *)

function readalfa : alfa;

(* reads the next name in the input buffer *)

const
digits = (."0".."9".);
letters = (."a".."å","%","_".);

var
ch : char;
i : integer;

begin
readok := false;
if incharsleft > 0 then
repeat
ch := readchar;
until (ch in letters) or (incharsleft = 0) ;
if ch in letters then
begin
readalfa(1) := ch;
readok := true;
for i := 2 to 12 do
begin
if incharsleft > 0 then
begin
ch := readchar;
if (ch in letters) or (ch in digits) then
readalfa(i) := ch
else
begin
readalfa(i) := sp;
repeatchar;
end
end
else
readalfa(i) := sp;
end
end
end;  (* readalfa *)

procedure getinput;

(* fetches input buffer from the console process incarnation *)

begin
repeat
lock opinref as p : opbuftype do
p.next := firstindex;
signal(opinref,opsem^);
wait(opinref,wrsem);
until opinref^.u2 = ok;   (* ok = 0 *)
lock opinref as p : opbuftype do
with p do
begin
incharsleft := next-first;
next := firstindex;
end
end;  (* getinput *)

function sublong(x,y : long) : long;

(* only implemented for x > y *)

begin
if x.least >= y.least then
begin
sublong.least := x.least-y.least;
sublong.most := x.most-y.most;
end
else
begin
sublong.least := 32767-y.least+x.least+1;
sublong.most := x.most-y.most-1;
end;
end; (* sublong *)

function addlong(x,y : long) : long;

(* x+y might be outside the representation contained in a long,
in this case the global variable, longowerflow, is set to true,
and the result is undefined *)

begin
if x.least > 32767-y.least then (* least field owerflow *)
begin
addlong.least := x.least-32767+y.least-1;
x.most:=x.most+1;
end
else
addlong.least := x.least+y.least;
if x.most > 32767-y.most then
begin
addlong.most := x.most-32767+y.most-1;
longowerflow := true;
end
else
begin
addlong.most := x.most+y.most;
longowerflow := false;
end
end;  (* addlong *)

function greatherlong(x,y : long) : boolean;

begin
if x.most < y.most then
greatherlong := false
else
if x.most > y.most then
greatherlong := true
else
if x.least < y.least then
greatherlong := false
else greatherlong := true;
end;  (* greatherlong *)

function rshiftlong(x : long ) : long;

(* the long x is divided by 2 *)

var
rem : integer;
begin
rshiftlong.most := x.most div 2;
rem := x.most mod 2;
case rem of
0: rshiftlong.least := x.least div 2;
1: rshiftlong.least := (x.least div 2)+16384;
end
end;  (* rshiftlong *)

function divlong(x,y : long) : real;

(* the function will only work for positive longs which
furthermore ensures that 0 < x < 32768*y  
divlong.last is the decimal part of the resulting real,
and it has to be divided by 10^4 to obtain the correct
result with an accurancy of 2 decimals *)

var
i,j,res : integer;
a : packed array(1..10) of 0..1;
x1, y1 : long;

begin
if ( y.most > 0 ) or ( y.least > 0 ) then

begin

i := 0;
y1 := y;
x1 := x;
debug("u",x1.most); debug("u",x1.least);
debug("v",y1.most);
debug("v",y1.least);
while greatherlong(x1,y1) do
begin
x1 := sublong(x1,y1);
i := i+1;
end;
if y1.most > 16384 then
begin
y1 := rshiftlong(y1);
x1 := rshiftlong(x1);
end;   (* divisor and dividend are divided by 2 to avoid owerflow
in the addlong function. this will not influence the accurancy  *)

for j := 1 to 10 do
begin
x1 := addlong(x1,x1);
if greatherlong(x1,y1) then 
begin
a(j) := 1;
x1 := sublong(x1,y1);
end
else a(j) := 0;
end;
divlong.first := i;
debug("g",i);                     (* debugging*)
res := 0;
i := 5000;   (* 2^-2 * 10^4 *)
for j := 1 to 10 do
begin
if a(j) = 1 then
res := res+i;
i := i div 2;
end;
divlong.last := res;
debug("g",res);                     (* debugging *)
end
else outtext12("0-division!!");

end;  (* divlong *)

function div10long(x : long) : long;

(* the long x is divided by 10 *)

var
r0, r1, r2, r3, r4 : integer;

begin
with x do
begin
r1 := most mod 10;
r0 := most div 10;
r2 := least div 10;
r3 := least mod 10;
r4 := ((8*r1)+r3) div 10;
debug("h",r0); debug("h",r1); debug("h",r2);    (* debugging *)
debug("h",r3); debug("h",r4);                   (* debugging *)
debug("i",3276*r1+r2+r4);                       (* debugging *)
end;
div10long.most := r0;
div10long.least := 3276*r1+r2+r4;
end;  (* divlong *)

function mod10long(x : long) : integer;

(* the resulting integer is the long x modulo 10 *)

var
r0, r1 : integer;

begin
r0 := x.most mod 10;
r1 := x.least mod 10;
mod10long := (r1+(8*r0)) mod 10;
end;  (* mod10long *)

procedure outlonginteger(int : long; position : integer);

(* writes the long int into the output buffer occupying
position chars of the buffer starting at last, which is 
updated accordingly *);

const
maxpos = 20;

var
digits : array(1..maxpos) of char;
i,
used : integer;
negative : boolean;

begin
for i := 1 to maxpos do digits(i) := sp;
i := maxpos;
repeat
digits(i) := chr(abs(mod10long(int)+ord("0")));
int := div10long(int);
i := i-1;
until (i = 1) or ((int.most = 0) and (int.least = 0));
used := maxpos - i;
if not ((int.most = 0) and (int.least =0)) then digits(1) := "*";
if ( not (position in (.1..maxpos.))) or
(position < used) then position := used;
for i := maxpos+1-position to maxpos do outchar(digits(i));
end;  (* outlonginteger *)

procedure outtotal(ind : integer);
begin
outtext20("total occurence     ");
outlonginteger(total(ind),15);
writenl;
end;   (* outtotal *)

procedure initheader(var msg : message_header;
kind,msize : integer; mstart : addr);

(*initialises the message header*)

begin
with msg do
begin
owner := ref(own.exit_semaphore);
answer := owner;
messagekind := kind;
size := msize;
start := mstart;
end
end;  (* initheader *)
 
 
procedure findprocinc(candidate : alfa;from : ^shadow;var res : ^shadow;
 level,number : integer);

(*the procedure scans the subtree with root : from, for occourance of
a process incarnation with the name : candidate. the scanning is
performed to the leaves from left to right . level will hold the tree depth
and number will hold the local branch number -number in shadow-chain *)

var
sha : addr;
sh : ^shadow;
finis : boolean ; 
stopmsg : reference;

begin
debug("q",0);                            (* debugging *)
if not nil(from^.r) then
begin
(*
checkstack(findappetite);
wait(stopmsg,own.secret_pointer^(stopsem)^);
*)
level := level+1;
debug("r",level);                 (* debugging *)
lock from^.r as p : ext_incarnation_descriptor do
begin
if debugon then begin outtext12(p.incname);         (* debugging *)
writenl; end;
if p.incname <> candidate then 
begin
sha := p.shadowchain;
sh := asgnptradr(sha);  (* transform an addr to ^shadow *)
if (nil(sh)) or ( level >= maxlevel) then
begin
if level >= maxlevel then
begin
outtext20(treedeptherror);
writenl;
end
end
else
findprocinc(candidate,sh,res,level,1);
if not foundcandidate then
begin
finis := false;
if not nil(sh) then
repeat
sh := sh^.next;
if not nil(sh^.r) then
number := number +1;
debug("s",number);
if not nil(sh) then
begin
findprocinc(candidate,sh,res,level,number);
if foundcandidate then finis := true;
end
else
finis := true;
until finis;
end
end
else
begin
foundcandidate := true;
res := from;
end;
end;
(*
release(stopmsg);
*)
end
end;     (*findprocinc*)


procedure listall(res : ^shadow; level,number : integer);

(* the process incarnation names in the subtree from the process
incarnation pointed out by res are written with depth, branchno *)

var
sha : addr;
sh : ^shadow;
finis : boolean;
stopmsg : reference;
shmem,shdisp : integer;

begin
if not nil(res^.r) then
begin
(*
checkstack(listappetite);
wait(stopmsg,own.secret_pointer^(stopsem)^);
*)
level := level+1;
shdisp := res^.r^.start.disp;
shmem := res^.r^.start.base.mem_no;
lock res^.r as p : ext_incarnation_descriptor do
begin
outtext12(p.incname);
outtext6(" depth");
outinteger(level,5);
outtext12("   branchno:");
outinteger(number,5);
writenl;
if debugon then
begin
outtext20("incarnation stack:  ");
outinteger(shmem,3); outchar(":");
if shdisp < 0 then
begin
outtext12("  32*2^10 + ");
shdisp := shdisp + 32767 + 1;
end;
outinteger(shdisp,7);
writenl;
end;
sha := p.shadowchain;
sh := asgnptradr(sha);    (* transform an addr to ^shadow *)
if (nil(sh)) or (level >= maxlevel) then
begin
if level >= maxlevel then
begin
outtext20(treedeptherror);
writenl;
end
end
else
listall(sh,level,number);
if not nil(sh) then
repeat
sh := sh^.next;
if not nil(sh) then
begin
if not nil(sh^.r) then
number := number+1;
listall(sh,level,number);
end
else
begin
number := 1;
level := level-1;
finis := true;
end
until finis;
end;
(*
release(stopmsg);
*)
end
end; (*listall*)


procedure listfrom(candidate : alfa);

(* finds candidate and lists the subtree from this point in tree *)

var
res : ^shadow;
xlevel,xnumber : integer;

begin
xlevel := 0;
xnumber := 1;
checkstack(findappetite);
wait(stopmsg,own.secret_pointer^(stopsem)^);
if candidate = "monitor     " then res := monitorsh
else if candidate = "timer       " then res := timersh
else if candidate = "allocator   " then res := allocsh
else if candidate = "linker      " then res := linkersh
else
begin
foundcandidate := false;
findprocinc(candidate,adamsh,res,xlevel,xnumber);
end;
release(stopmsg);
if foundcandidate then
begin
xnumber := 1;
xlevel := 0;
checkstack(findappetite);
wait(stopmsg,own.secret_pointer^(stopsem)^);
listall(res,xlevel,xnumber);
release(stopmsg);
end
end;   (* listall *)


procedure initprocinc(x : ^shadow; start : addr; index : integer);



(* the process incarnation descriptor is redifined, as the field
statistic are set to start of table + index shift 10 used by the
microprogram, and the dump.ps flag bit for statistic gathering
is turned on to be detected by the microprogram *)

var
curval : integer;

begin
if not nil(chmess) then
lock x^.r as p : ext_incarnation_descriptor do
begin
p.statistic := (index * 1024)+start.disp;
channel chmess do
if p.level <> 0 then
begin
if p.incname = "monitor     " then
begin
getregister(curval,1+(8*(3-p.level)));
if curval < 16348 then setregister(curval,1+(8*(3-p.level)));
end;
getregister(curval,1+(8*p.level));
if curval < 16384 then setregister(curval+16384,1+(8*p.level));
end
else
if p.dumpps < 16384 then p.dumpps := p.dumpps+16384;  (* bit 1 is flag bit *)
end
else
begin
outtext20(notdef);
writenl;
end;
end;  (* initprocinc *)


procedure relprocinc(x : ptrshadow);

(* releases the process incarnation descriptor from statistic 
gathering *)

var
curval : integer;
begin
if not nil(chmess) then
lock x^.r as p : ext_incarnation_descriptor do
channel chmess do
begin
if p.level <> 0 then
begin
if p.incname = "monitor     " then
begin
getregister(curval,1+(8*(3-p.level)));
if curval < 0 then curval := (abs(curval) mod 16384)+(-32768)
else curval := curval mod 16384;
setregister(curval,1+(8*(3-p.level)));
end;
getregister(curval,1+(8*p.level));
if curval < 0 then curval := (abs(curval) mod 16384)+(-32768)
else curval := curval mod 16384;
setregister(curval,1+(8*p.level));
end
else
begin
if p.dumpps < 0 then p.dumpps := (abs(p.dumpps) mod 16384)+(-32768)
else p.dumpps := p.dumpps mod 16384;
end
end
else
begin
outtext20(notdef);
writenl;
end
end;   (* relprocinc *)


procedure initwregbase(start : integer);

(* pu - error mask is used in correspondance with the microprogram *)

begin
setregister(start,1018);
end;   (*initwregbase*)

procedure turnonglobal(startaddr : addr);

(* w register(1018) is initialised so the micro-program will start
statistic gathering *)

var
x : integer;

begin
x := startaddr.base.mem_no-32767-1;        (*bit 0*)
initwregbase(x);
end;   (*turnonglobal*)


procedure turnoffglobal(startaddr : addr);

(* w register(1018) is initialised so that the microprogram will stop
statistic gathering *)

begin
initwregbase(startaddr.base.mem_no);
end;   (* turnoffglobal *)



procedure outprocincname(x : alfa);

begin
outtext20("process incarnation ");
outtext6("name: ");
outtext12(x);
writenl;
end;


procedure outfigure;

(* produces the horizontal axe for the percentage presentation *)

var
i,j : integer;

begin
for i := 1 to 3 do
outtext20("                    ");
outtext6(" 1    ");
writenl;
outtext12("            ");
for i := 1 to 10 do
begin
j := i mod 10;
outinteger(j,5);
end;
writenl;
outinteger(0,12);
for i := 1 to 10 do outinteger(0,5);
writenl;
for i := 1 to 62 do outchar("-");
outchar(">");
outchar("%");
writenl;
end;   (* outfigure *)

procedure outrelstart(limit : integer);

(* produces the start text in all relative output formats *)

begin
outtext20("relative occurrence ");
outtext20("of instructions not ");
outtext12("less than:  ");
outinteger(limit,10);
writenl;
end;


procedure outgreaterpercentage(name : alfa; index, barrier : integer);

(* produces a histogram of the percentage occurrence of instructions
if the occurrence is greater than or equal to barrier *)

var
x, total100 : long;
rx : real;
i,j : integer;

begin
outrelstart(barrier);
outprocincname(name);
outfigure;
total100 := div10long(div10long(total(index)));
lock tableref as table : tabletype do
begin
for i := 0 to noinstmin1 do
if iname(i) <> "      " then
begin
x := table(index,i);
rx := divlong(x,total100);
if rx.first >= barrier then
begin
if rx.last >= 5000 then rx.first := rx.first+1;
outtext6(iname(i));
outtext6("     !");
while rx.first > 0 do
begin
rx.first := rx.first-2;
if rx.first < 0 then outchar(".") else outchar("-");
end;
for j := 0 to 9 do outchar(dle);
writenl;
end
end
end;
outtotal(index);
end;  (* outgreaterpercentage *)


procedure inittable(mostsignificant,leastsignificant : integer);

(* the resulttable "table" is initialised with respect to all longs *)

var
i,j : integer;
begin
lock tableref as table : tabletype do
begin
for i := 0 to noofproc do
begin
for j := 0 to noinstmin1 do
begin
table(i,j).most := mostsignificant;
table(i,j).least := leastsignificant;
end
end
end
end;


function tabletotal : totaltype;

(* all longs in the resulttable, table, is summed *)

var
i,j : integer;
x,y : long;

begin
x.most := 0;
x.least := 0;
lock tableref as table : tabletype do
begin
for i := 1 to noofproc do
begin
y.most := 0; y.least := 0;
for j := 0 to noinstmin1 do
begin
x := addlong(x,table(i,j));
y := addlong(y,table(i,j));
end;
tabletotal(i) := y;
end;
end;
debug("b",x.most);
debug("b",x.least);             (* debugging *)
totalall := x;
tabletotal(0) := x;
end;


procedure tabletotalinst;

(* the resulttable, table, is summed over all processes *)

var
i : integer;

begin
lock tableref as table : tabletype do
begin
for i := 0 to noinstmin1 do
begin
table(0,i).most := 0;
table(0,i).least := 0;
end;
for j := 0 to noinstmin1 do
for i := 1 to noofproc do
table(0,j) := addlong(table(0,j),table(i,j));
end;
end;


function min(i,j : integer) : integer;
begin
if i < j then min := i else min := j;
end;   (* min *)



procedure outgreaterabs(candidate : alfa;index,barrier : integer);

(* the statistic for the process incarnation with name candidate
is written with absolute values. only occurrences relatively
greater than barrier is written *)

var
x,total100 : long;
rx : real;
i : integer;

begin
outtext20("absolute occurrence ");
outtext20("of instructions not ");
outtext12("less than:  ");
outinteger(barrier,4);
writenl;
outprocincname(candidate);
total100 := div10long(div10long(total(index)));
lock tableref as table : tabletype do
begin
for i := 0 to noinstmin1 do
if iname(i) <> "      " then
begin
x := table(index,i);
rx := divlong(x,total100);
if rx.first >= barrier then
begin
outtext6(iname(i));
outchar(":");
outlonginteger(x,13);
writenl;
end
end
end;
outtotal(index);
end;  (* outgreaterabs *)


procedure mostfrequent(index : integer; var top : toptype);

(* after call the top-array will contain the indexes to the
"quant" most frequent used instructions in decreasing order with
respect to the process incarnation included under "index" *)

var
i,j,k,l : integer;
minimum,x : long;

begin
lock tableref as table : tabletype do
begin
top(0) := 0;
minimum := table(index,0);
for i := 0 to noinstmin1 do
begin
j := min(i,quant);
x := table(index,i);
if ( greatherlong(x,minimum)) or (j<=quant) then
for k := 0 to j do
begin
if greatherlong(x,table(index,top(k))) then
begin
for l := j downto k+1 do
top(l) := top(l-1);
top(k) := i;
k := j+1;
minimum := table(index,top(j));
end
else if j <= quant then top(j) := j;
end
end
end
end; (* most frequente *)



procedure outtopmostpercentage(candidate : alfa; index,number : integer);

(* writes the number most freqently used instructions in graphic %
with respect to the process incarnation with the name candidate *);

var
x,total100 : long;
rx : real;
i : integer;
ceres : toptype;

begin
outrelstart(0);
outprocincname(candidate);
outtext12("only the    ");
outinteger(min(quant+1,number),3);
outtext20(" most frequente     ");
writenl;
outfigure;
total100 := div10long(div10long(total(index)));
mostfrequent(index,ceres);
debug("c",total100.most); debug("c",total100.least); (* debugging *)
lock tableref as table : tabletype do
begin
for i := 0 to min(number-1,quant) do
begin
x := table(index,ceres(i));
debug("d",x.most); debug("d",x.least);               (* debugging *)
rx := divlong(x,total100);
debug("e",rx.first); debug("e",rx.last);             (* debugging *)
if rx.last >= 5000 then rx.first := rx.first+1;
outtext6(iname(ceres(i)));
outtext6("     !");
while rx.first > 0 do
begin
rx.first := rx.first-2;
if rx.first < 0 then outchar(".") else outchar("-");
end;
writenl;
end
end;
outtotal(index);
end;   (* outtopmostpercentage *)


procedure outgreaterrel(candidate : alfa; index,barrier : integer);

(* writes the relative values of the instruction frequence greater than
barrier with respect to the process incarnation candidate *)

var
x,total100 : long;
rx : real;
i,i1,i2,round : integer;

begin
outrelstart(barrier);
outprocincname(candidate);
total100 := div10long(div10long(total(index)));
lock tableref as table : tabletype do
begin
for i := 0 to noinstmin1 do
if iname(i) <> "      " then
begin
x := table(index,i);
rx := divlong(x,total100);
if rx.first >= barrier then
begin
if rx.last mod 100 >= 50 then round := 1 else round := 0;
rx.last := (rx.last div 100) + round;
rx.first := rx.first + (rx.last div 100);
rx.last := rx.last mod 100;
outtext6(iname(i));
outtext6("  :   ");
outinteger(rx.first,10);
outchar(".");
i1 := rx.last div 10;
i2 := rx.last mod 10;
outinteger(i1,1);
outinteger(i2,1);
writenl;
end
end
end;
outtotal(index);
end;   (* outgreaterrel *)

procedure outtopmostabs(candidate : alfa; index,number : integer);

(* the number most frequently used instruction in the process
incarnation candidate are written in absolute form *)

var
i : integer;
ceres : toptype;

begin
outtext20("absolute occurrence ");
outtext20("of instructions     ");
writenl;
outprocincname(candidate);
outtext12("only the    ");
outinteger(min(quant+1,number),3);
outtext20(" most frequente     ");
writenl;
mostfrequent(index,ceres);
lock tableref as table : tabletype do
begin
for i := 0 to min(number-1,quant) do
begin
outtext6(iname(ceres(i)));
outchar(":");
outlonginteger(table(index,ceres(i)),14);
writenl;
end
end;
outtotal(index);
end;  (* outtopmostabs *)


procedure outtopmostrel(candidate : alfa; index,number : integer);

(* writes the relative values of the number most frequent used 
instructions by the process incarnation associated to index *)

var
x,total100 : long;
rx : real;
i1,i2,
round,i : integer;
ceres : toptype;

begin
outrelstart(0);
outprocincname(candidate);
outtext12("only the    ");
outinteger(min(quant+1,number),3);
outtext20(" most frequent      ");
writenl;
total100 := div10long(div10long(total(index)));
mostfrequent(index,ceres);
lock tableref as table : tabletype do
begin
for i := 0 to min(number-1,quant) do
begin
x := table(index,ceres(i));
rx := divlong(x,total100);
if (rx.last mod 100) >= 50 then round := 1 else round := 0;
rx.last := (rx.last div 100) + round;
rx.first := rx.first + (rx.last div 100);
rx.last := rx.last mod 100;
outtext6(iname(ceres(i)));
outchar(":");
outinteger(rx.first,10);
outchar(".");
i1 := rx.last div 10;
i2 := rx.last mod 10;
outinteger(i1,1);
outinteger(i2,1);
writenl;
end
end;
outtotal(index);
end;    (* outtopmostrel *)


function outcondition : boolean;

(* tests if global statistic gathering is switched off *)

begin
if (onoff = "off         ") and ((totalall.most <> 0) or (totalall.least <> 0)) then 
outcondition := true
else
outcondition := false;
end;    (* outcondition *)











(*******************************************************
*                                                      *
*           M A I N  P R O G R A M.                    *
*                                                      *
*******************************************************)




begin
alloc(opoutref,opbufpool,wsem);
opoutref^.u1 := write;
lock opoutref as opbuf : opbuftype do
with opbuf do
begin
first := firstindex;
name := "dynamic     ";
data(firstindex) := " ";
end;
return(opoutref);
writenl;

alloc(opinref,opbufpool,wrsem);
opinref^.u1 := read;
lock opinref as opbuf : opbuftype do
with opbuf do
begin
first := firstindex;
last := lastindex;
name := "dynamic     ";
end;

alloc(tableref,tablepool,tablesem);
start := tableref^.start;
adamaddr := own.secret_pointer^(adamstack)^.chain;
initref(adamshadow.r,adammsgheader);
initheader(adammsgheader,16384,procincsize,adamaddr);
adamsh := refshadow(adamshadow);

monitoraddr := own.secret_pointer^(monitorstack)^.chain;
initref(monitorshadow.r,monitormsgheader);
initheader(monitormsgheader,16384,procincsize,monitoraddr);
monitorsh := refshadow(monitorshadow);

timeraddr := own.secret_pointer^(timerstack)^.chain;
initref(timershadow.r,timermsgheader);
initheader(timermsgheader,16384,procincsize,timeraddr);
timersh := refshadow(timershadow);

allocaddr := own.secret_pointer^(allocatorstack)^.chain;
initref(allocshadow.r,allocmsgheader);
initheader(allocmsgheader,16384,procincsize,allocaddr);
allocsh := refshadow(allocshadow);

linkeraddr := own.secret_pointer^(linkerstack)^.chain;
initref(linkershadow.r,linkermsgheader);
initheader(linkermsgheader,16384,procincsize,linkeraddr);
linkersh := refshadow(linkershadow);

opsem := semvector(operatorsem);
firstword := 1;
lastword := 10;
onoff := "on          ";    (* no writing before g-command: off*)

(* output initial message to the operator console *)

outtext20("dynamic instruction ");
outtext20("frequence gathering ");
outtext12("version:    ");
outinteger(version,2);
outchar(".");
outinteger(revision,2);
writenl;

(* the remaining program consists of a repeat statement, inside
which the communication with the operator is performed. evry
input line from the operator forms a command followed by the
parameters. The program decodes the command, and performs a case
on this. The command is carried out if possible, and the program
is ready for the next command *)

initincludedtable;
inittable(0,0);

own.shadowchain := nilp;  (* establish stop criteria for findprocinc *)

lock adamsh^.r as p : ext_incarnation_descriptor do
p.incname := adamname;

repeat
begin
getinput;
command := readchar;
if incharsleft <> -1 then
case command of

"g":
begin
onoff := readalfa;
if readok then
begin
if onoff = "on          " then
turnonglobal(start)
else
if onoff = "off         " then
begin
turnoffglobal(start);
total := tabletotal;
debug("f",totalall.most); debug("f",totalall.least);          (* debugging *)
end
else
begin
outerror;
outargument;
outinteger(1,3);
writenl;
end;
end
else
begin
outerror;
outtext12("in g-command");
writenl;
end;
end;  (* g - command : gather statistic on/off *)

"i":
begin
candidate := readalfa;
if readok then
begin
ancestor := readalfa;
if readok then
begin
number := readinteger;
if readok then
begin
depth := 0;
branchno := 1;
checkstack(findappetite);
wait(stopmsg,own.secret_pointer^(stopsem)^);
foundcandidate := true;
if ancestor = "monitor     " then ancsh := monitorsh
else if ancestor = "timer       " then ancsh := timersh
else if ancestor = "allocator   " then ancsh := allocsh
else if ancestor = "linker      " then ancsh := linkersh
else
begin
foundcandidate := false;
findprocinc(ancestor,adamsh,ancsh,depth,branchno);
end;
release(stopmsg);
if foundcandidate then
begin
depth := 0;
branchno := 1;
checkstack(findappetite);
wait(stopmsg,own.secret_pointer^(stopsem)^);
foundcandidate := false;
findprocinc(candidate,ancsh,ressh,depth,branchno);
release(stopmsg);
if foundcandidate then
case insertname(candidate,number,ressh) of
okay : 
begin
initprocinc(ressh,start,number);
outtext20(namein);
end;
multible:
begin
initprocinc(ressh,start,number);
outtext20(namein);
outtext20("multible index      ");
end;
rangeerror:
outtext20("index out of range  ");
toomanyproc:
begin
outtext20("too many processes  ");
end
end   (* case insertname  *)
else
outtext20(nameerror);
end
else
outtext20(ancestormissing);
end
else
outerrorarg(3);
end
else
outerrorarg(2);
end
else
outerrorarg(1);
writenl;
end;     (* i - command: insert procincname from ancestor *)

"e":    (* exclude *)
begin
candidate := readalfa;
if readok then
begin
ancestor := readalfa;
if readok then
begin
number := readinteger;
if readok then
begin
depth := 0;
branchno := 1;
checkstack(findappetite);
wait(stopmsg,own.secret_pointer^(stopsem)^);
foundcandidate := true;
if ancestor = "monitor     " then ancsh := monitorsh
else if ancestor = "timer       " then ancsh := timersh
else if ancestor = "allocator   " then ancsh := allocsh
else if ancestor = "linker      " then ancsh := linkersh
else
begin
foundcandidate := false;
findprocinc(ancestor,adamsh,ancsh,depth,branchno);
end;
release(stopmsg);
if foundcandidate then
begin
depth := 0;
branchno := 1;
checkstack(findappetite);
wait(stopmsg,own.secret_pointer^(stopsem)^);
foundcandidate := false;
findprocinc(candidate,ancsh,ressh,depth,branchno);
release(stopmsg);
if foundcandidate then
case excludename(candidate,number,ressh) of
fine : begin
relprocinc(ressh);
outtext20("name excluded       ");
end;
notfound : outtext20("name not in table   ");
indexerror: outtext20("index does not match");
end  (*case excludename*)
else
outtext20(nameerror);
end
else
outtext20(ancestormissing);
end
else
outerrorarg(3);
end
else
outerrorarg(2);
end
else
outerrorarg(1);
writenl;
end;   (* e command: exclude procincname searched from ancestor *)


"r":    (* r-command *)
begin
mostsignificant := readinteger;
if readok then
begin
leastsignificant := readinteger;
if readok then
begin
inittable(mostsignificant,leastsignificant);
outtext20("table initialised   ");
end
else
begin
outerror;
outargument;
outinteger(2,3);
end
end
else
begin
outerror;
outargument;
outinteger(1,3);
end;
writenl;
end;     (* reset command *)



"c":    (* clear name table *)
begin
clearincluded;
initincludedtable;
end;



"l":    (* list included names *)
begin
candidate := readalfa;
if readok then
listfrom(candidate)
else
begin
outerror;
outargument;
outinteger(1,3);
writenl;
end
end;   (* list from command *)


"p":   (* perform on level - command *)
begin
indx := readinteger;
if readok then
begin
if reservech(chmess,indx,-1) <> 0 then
outtext20("level not available ")
else
outtext20("level reserved      ");
end
else
begin
outerror;
outargument;
outinteger(1,3);
end;
writenl;
end;     (* p command *)


"s": listincluded;


"w":    (* write - command *)
begin
argerror := false;
candidate := readalfa;
if readok then
begin
indx := readinteger;
if readok then
begin
format := readalfa;

if readok then
begin
quantity := readalfa;
if readok then
begin
case qtable(quantity(1)) of
all:;
from: barrier := readinteger;
top: number := readinteger;
otherwise
begin
argerror := true;
outerror;
outargument;
outinteger(3,3);
writenl;
end
end;     (* case quantity *)
if not readok then argerror := true else argerror := false;
end
else
begin
outerror;
outargument;
outinteger(4,3);
writenl;
end
end
else
begin
outerror;
outargument;
outinteger(3,3);
writenl;
end
end
else
begin
outerror;
outargument;
outinteger(2,3);
writenl;
end
end
else
begin
outerror;
outargument;
outinteger(1,3);
writenl;
end;
if argerror then
begin
outerror;
outargument;
outinteger(5,3);
writenl;
end
else   (* all arguments safe in house *)
begin
case findincluded(candidate,indx) of
fine:
begin
case ftable(format(1)) of
prc:
begin
case qtable(quantity(1)) of
all: outgreaterpercentage(candidate,indx,0);
from: outgreaterpercentage(candidate,indx,barrier);
top: outtopmostpercentage(candidate,indx,number);
end;  (* case quantity *)
end;   (* percentage command *)
r:
begin
case qtable(quantity(1)) of
all: outgreaterrel(candidate,indx,0);
from: outgreaterrel(candidate,indx,barrier);
top: outtopmostrel(candidate,indx,number);
end;   (* case quantity *)
end;   (* relative-command *)
a: begin
case qtable(quantity(1)) of
all: outgreaterabs(candidate,indx,0);
from :outgreaterabs(candidate,indx,barrier);
top: outtopmostabs(candidate,indx,number);
end;   (* case quantity *)
end;   (* topmost - command *)
otherwise
begin
outerror;
outargument;
outinteger(3,3);

writenl;
end
end;   (* case format *)
end;   (* fine *)
indexerror:

begin
outtext20("index does not match");
writenl;
end;
notfound:

begin
outtext20(nameerror);
writenl;
end;
end;   (* case findincluded *)

end; (* else *)
end;   (* w : command - write command *)




"t":    (* total write command *)
begin
tabletotalinst;    (* summation over procincarnations placed in table(0,j)*)
if outcondition then
begin
format := readalfa;
quantity := readalfa;
if readok then

begin
case qtable(quantity(1)) of
all:;
from: barrier := readinteger;
top: number := readinteger;

otherwise readok := false;
end;   (* case quantity *)
if readok then
case ftable(format(1)) of
prc:
case qtable(quantity(1)) of
all: outgreaterpercentage(tproc,0,0);
from: outgreaterpercentage(tproc,0,barrier);
top: outtopmostpercentage(tproc,0,number);
end;  (* case quantity of *)

r:
case qtable(quantity(1)) of
all: outgreaterrel(tproc,0,0);
from: outgreaterrel(tproc,0,barrier);
top: outtopmostrel(tproc,0,number);

end;   (* case quantity *)
a:
case qtable(quantity(1)) of
all: outgreaterabs(tproc,0,0);
from: outgreaterabs(tproc,0,barrier);
top: outtopmostabs(tproc,0, number);
end;   (* case quantity *)
otherwise readok := false;
end;   (* case format *)
if not readok then

begin
outerror;
outargument;
outtext12(" t - command");
writenl;
end
end
else
begin
outtext20("1./2.argument error ");
writenl;
end;
end   (* outcondition *)
else
begin
outtext20("statistic is on     ");
writenl;
end;
end;   (* t: total write command *)

"d": debugon := not debugon;

"h":   (* help - command *)
begin
outtext20("commands to dynamic ");
writenl;
outtext20("g <on>/<off>        ");
outtext20(sp20);
outtext20("gather statistic    ");
writenl;
outtext20("i <name> <from> <ind");
outtext20("ex>                 ");
outtext20("include name        ");
writenl;
outtext20("e <name> <from> <ind");
outtext20("ex>                 ");
outtext20("exclude name        ");
writenl;
outtext20("r <most> <least>    ");
outtext20(sp20);
outtext20("reset table of longs");
writenl;
outtext20("c                   ");
outtext20(sp20);
outtext20("clear all names     ");
writenl;
outtext20("l <from>            ");
outtext20(sp20);
outtext20("names of fromsubtree");
writenl;
outtext20("p <level>           ");
outtext20(sp20);
outtext20("perform indivisible ");
outtext12("on level    ");
writenl;
outtext20("s                   ");
outtext20(sp20);
outtext20("show included names ");
writenl;
outtext20("w <name> <index> <fo");
outtext20("rmat> <quantity>    ");
outtext20("write result of name");
outtext6(",index");
writenl;
outtext20("<%>/<r>/<a> format  ");
outtext20("<a>/<f>/<t> quantity");
writenl;
outtext20("t <format><quantity>");
outtext20(sp20);
outtext20("write totals (as w) ");
writenl;
outtext20("d                   ");
outtext20(sp20);
outtext20("switch debug mode   ");
writenl;
outtext20("h                   ");
outtext20(sp20);
outtext20("help: list commands ");
writenl;
end;   (* h: help - command *)

otherwise
begin
outtext20("illegal command:    ");
outchar(command);
writenl;
end;



end   (* case command of *)
end;
until forever;
end
.
▶EOF◀