DataMuseum.dk

top - metrics - download

    Length: 29184 (0x7200)
    Types: TextFileVerbose
    Names: »wtest«

└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system
    └─⟦72244f0ef⟧ 
        └─⟦this⟧ »wtest« 

TextFileVerbose

process test(testname    : alfa; semvector: system_vector);

    (***************************************************
    *
    * function:    the test module is used to initialise buffers,
    *              signal them to semaphores, and to write their
    *              contents, when they have been handled by another
    *
    * externals:   none
    *
    * var params:  none
    *
    * semaphores:  the module sends to the system semaphore
    *              "operatorsem".
    *
    *
    * programmed may 1980 by wib and stb
    *
    ***************************************************)

const
version = "vers  0.41 /";


\f


const
size_listen = 16;
opbufsize = 80; (* no. of bytes in buffers to the operator module *)
messbufsize= size_listen; (*words*)
testbufsize= size_listen*4;
noofmodules= 11;
noofsemaphores= 40;
pu= 0; (* processing unit number *)
pr= -1; (* timeslicing priority *)
 
noparam= " no param ";
alreadyexists= " already exists     ";
doesntexist= " doesn't exist      ";
illegalno= "illegal no";
createerror= "error in createcall ";
 
linelength= 80;
firstindex= 6 + alfalength;
lastindex= firstindex + (linelength - 1);
ok= 0; (* result from operator *)
 
 
type
opbuftype=
record
first,
last,
next: integer;
name: alfa;
data: array (firstindex..lastindex) of char
end;

messbuftype= array (1..messbufsize) of integer;
testbuftype= array (1..testbufsize) of integer;
 
createchtype=
record
controlinfo, timeout: byte
end;
 
atbuffer= array (0..1) of byte;

 
alfa10= array (1..10) of char;
alfa20= array (1..20) of char;
 
var
(*********  pools  *********)
opbufpool: pool 3 of opbuftype;
messbufpool: pool 20 of testbuftype;

(**********  semaphores  **********)
countsem,    (* used by "t"-command *)
wsem,        (* buffers written by the operatormodule is
                returned here *)
wrsem        (* buffers with content read by the operator
                module is returned here *)
: semaphore;

(**********  references  **********)
countref,    (* used by "t"-command *)
opinref,    (* ref. to buffer from operator *)
opoutref,   (* ref. to buffer to operator *)
cur           (* ref. to current buffer *)
: reference;

(**********  pointers  **********)
opsem: ^semaphore;

(**********  zones  **********)
z: zone;

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


(**********  integers  **********)
base,            (* number base for input and output *)
cv,              (* create value *)
firstword,       (* used by "o"-command *)
i,
incharsleft,   (* no. of not yet read chars in opinbuffer *)
j,
k,
lastword,       (* used by "o"-command *)
leftbyte,       (* used by "p"-command *)
moduleno,       (* tested module *)
noofparams,     (* no. of params in operator line *)
oldbase,        (* used by the "b" command *)
rightbyte,      (* used by "p"-command *)
semno,           (* typed semaphore number *)
st              (* storage requirements *)
: integer;

(**********  booleans  **********)
readok,         (* indicates if the last call of readinteger
                   yielded a result *)
testmode
: boolean;

(**********  arrays  **********)
params: array(1..50) of integer; (* holds parameters from operator *)
sh: array(1..noofmodules) of shadow; (* ref. to process incarn. *)
sem: array (1..noofsemaphores) of semaphore;

(**********  user types  **********)
opbuf: opbuftype;
messbuf: messbuftype;
\f

\f

 
(**********  externals **********)
<*/////////////////////////////////////////////////////
process tssuper(
tssname: alfa;
semvector: system_vector;
var ts_sem : ts_sem_vector);
external;
 
process at_handler(
at_hname: alfa;
dc_addr: alarmnetaddr;
var ts_sem : ts_sem_vector;
var lam_sem_tab: lam_tab;
sys_sem_tab: system_vector);
external;
 
process vc_handler(
vc_hname: alfa;
dc_addr: alarmnetaddr;
var ts_sem : ts_sem_vector;
var lam_sem_tab: lam_tab;
sys_sem_tab: system_vector);
external;
 
process timeout(
timeoutname: alfa;
opsem : ^semaphore;
var timeoutsem: semaphore;
(*  systimsem: semaphore;     (**  not used when using the real systimer   **)
ticklength, max: integer);
external;
 
process atconnector(
atcname: alfa;
semvector: system_vector;
var atcsem,
athsem,
driversem,
timsem: semaphore;
ownaddr: integer;
channelno: byte);
external;
 
process vcatc(
vcatcname: alfa;
semvector: system_vector;
var messem,
vchsem,
lamsem,
timeoutsem: semaphore;
dcaddr: macroaddr;
micaddr: integer;
channelno: byte);
external;
 
process tsconnector(
tscname: alfa;
semvector: system_vector;
var inputsem,
tsssem,
dcsem,
lamsem,
timeoutsem,
semint1,
semint2,
semint3,
semint4,
semint5,
semint6: semaphore);
external;
 
process lam(
lamname: alfa;
semvector: system_vector;
pu, level: integer;
var inputsem: semaphore);
external;
 
process vagt(
vagt_name : alfa;
semvector : system_vector;
var sem: ts_sem_vector);
external;
  
process dcmodule(
dc_name : alfa;
semvector : system_vector;
var sem1,sem2,sem3,sem4,sem5,sem6,sem7: semaphore);
external;
  
/////////////////////////////////////*>
 
(********** forwards **********)

procedure getparams;
forward;
 
procedure outdecimal(int,positions: integer);
forward;

procedure outinteger(int,positions: integer);
forward;
 
procedure outstring10(text: alfa10);
forward;

procedure outstring20(text: alfa20);
forward;


function readchar: char;
forward;
 
function readinteger: integer;
forward;

procedure repeatchar;
forward;

procedure testmodeout (text: alfa20; i: integer);
forward;
 
procedure writenl;
forward;

\f


function createok(createvalue: integer): boolean;
(* tests if the value of a create-call was ok
and writes an errormessage if not *)
begin
if createvalue=0 then createok:=true
else 
begin (* not ok *)
outstring20(createerror);
outdecimal (createvalue,4);
createok:=false;
end;
end; (* create ok *)



\f


procedure getinput;
(* reads input from console into opinref^ *)
begin
 
testmodeout ("getinput called     ",0);

repeat
lock opinref as opbuf: opbuftype do
opbuf.next:= firstindex;
signal (opinref, opsem^);
wait (opinref, wrsem);
until opinref^.u2= ok (* 0*);

lock opinref as opbuf: opbuftype do
with opbuf do
begin
incharsleft:= next - first;
next:= firstindex;
end;
command:= readchar;

testmodeout ("command read:       ",ord(command));
 
getparams;
end (* getinput *);
\f

 
procedure getparams;
(* reads integer parameters *)
var newbase: boolean;
begin
testmodeout ("getparams called    ",0);

noofparams:= 0;
 
if command in (."a","b","c","e","f","k","o","p","s","t","w".)
then
begin (* change to decimal *)
oldbase:= base;
base:= 10;
newbase:= true;
end
else
newbase:= false;
 
repeat
noofparams:= noofparams + 1;
params(noofparams):= readinteger;
testmodeout ("parameter read:     ",params(noofparams));
if (noofparams=1) then
if command in (."e","f","p".) then
begin (* change to old *)
base:= oldbase;
newbase:= false;
end;
 
until (not readok) or (noofparams= 50);

noofparams:= noofparams - 1;
 
if newbase then
(* change back to old base *)
base:= oldbase;
end (* getparams *);
\f


function moduleready(moduleno: integer): boolean;
(* tests if an incarnation of the module is existing
and writes an errormessage if so *)
begin
if nil( sh( moduleno) ) then moduleready:=true
else
begin  (* module is already existing *)
outdecimal(moduleno,4);
outstring20(alreadyexists);
moduleready:=false;
end;
end (* module ready *);


\f


procedure outchar(ch:char);
(* writes ch into the output buffer *)
begin
lock opoutref as opbuf: opbuftype do
with opbuf do
begin
last:= last + 1;
data (last):= ch;
end;
end (* outchar *);
\f


procedure outdecimal (int, positions: integer);
(* writes the integer "int" decimally into opbuf starting
at "last", which is updated accordingly *)
 
begin
oldbase:= base;
base:= 10;
outinteger(int,positions);
base:= oldbase;
end (* outdecimal *);
\f

 
procedure outinteger(int,positions:integer);
(* writes the integer "int" into opbuf starting at
"last", which is updated accordingly *)
const
maxpos = 20; (* max number of positions in layout *)

var
bits: array(0..15) of bit;
digits:array(1..maxpos) of char;
curdigit, (* current pos. in digits-array to be filled out *)
curpos,   (* cur. pos. in the nunber being computed *)
h, i,
m, newm,
noofdig,  (* no. of digits in the resulting number *)
noofpos,  (* no. of pos. from bits-array for one number *)
res,      (* resulting number *)
used: integer;
 
negative, zeroes: boolean;
 
begin
used:= 1;

(* first we initialise the digits array *)
for i:=1 to maxpos do digits(i):=sp;

if base= 10 then
begin
i:=maxpos;

negative:= int<0;

repeat
(* now we unpack the digits backwards and put them
into the digits array *)

digits(i):= chr (abs(int mod base) + ord("0"));
int:=int div base;
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):= "*";
end (* if base= 10 *)
 
else (* base= 2, 8, or 16 *)
begin
(* initialise bits-array *)
if int>=0 then
begin
for i:= 15 downto 1 do
begin
bits(i):= int mod 2;
int:= int div 2;
end;
bits(0):= int mod 2;
int:= int div 2;
end
else
(* int<0 *)
begin
(* subtract abs(int) from 1111111...1 *)
for i:= 15 downto 1 do
begin
bits(i):= 1+(int mod 2);
int:= int div 2;
end;
bits(0):= 1+(int mod 2);
int:= int div 2;
 
(* add 1 *)
m:= 1;
for i:= 15 downto 1 do
begin
newm:= (bits(i)+m) div 2;
bits(i):= (bits(i)+m) mod 2;
m:= newm;
end;
newm:= (bits(0)+m) div 2;
bits(0):= (bits(0)+m) mod 2;
m:= newm;
end (*int<0*);
 
(* compute digits-array *)
case base of
2: begin
noofpos:= 1;
noofdig:= 16;
end;
 
8: begin
noofpos:= 3;
noofdig:= 6;
end;
 
16: begin
noofpos:= 4;
noofdig:= 4;
end;
end (* case *);
 
curdigit:= maxpos -noofdig +1;
 
if base= 8 
then curpos:= 3
else curpos:= 1;
res:= 0;
zeroes:= true;
 
for h:= 0 to 15 do
begin
res:= res*2 + bits(h);
if curpos= noofpos then
begin (* time to fill out a pos. in digits-array *)
if zeroes and (res=0) then
begin
if curdigit=maxpos 
then digits(curdigit):= "0"
(*else digits (curdigit):= " "*);
end
else
if res<=9
then digits(curdigit):= chr (res + ord ("0"))
else digits(curdigit):= chr (res + ord ("7"));
if (res<>0) and zeroes then
begin
zeroes:= false;
used:= maxpos - curdigit + 1;
end;
res:= 0;
curpos:= 0;
curdigit:= curdigit + 1;
end;
curpos:= curpos + 1;
end;
end (* base= 2, 8, of 16 *);
  
if positions<used then outchar(sp);

if (not (positions in (. 1 .. maxpos .)) )
or (positions < used) then
positions:=used;

for i:=maxpos+1-positions to maxpos do
begin
outchar( digits(i) );
end

end (* out integer *);


\f


procedure outstring10(text: alfa10);
(* writes the text into opbuf starting at outputpointer
which is updated accordingly *)
var
i: integer;
begin
for i:=1 to 10 do
outchar( text(i) );
end (* out string 10 *);
\f

 
procedure outstring20(text: alfa20);
(* analogue to outstring10 *)
var
i: integer;
begin
for i:=1 to 20 do
outchar( text(i) );
end (* out string 20 *);



\f


function readchar: char;
(* reads the next char from opinref^.
next is incremented and charsleft is 
decremented *)
begin
lock opinref as opbuf: opbuftype do
with opbuf do
begin
readchar:= data(next);
next:= next + 1;
end;
incharsleft:=incharsleft-1;
end (* readchar *);



\f


function readinteger : integer;
(* reads the next integer from opinref^ starting
at "inputpoint". upon return "inputpoint" will be
the position just after the last char read.

the global boolean "readok" will be true if an
integer was read and false otherwise *)

const
digits = (. "0" .. "9" .);
hexdigits = (. "a" .. "f" .);
signs =  (. "+" , "-" .);

var
negative, digit: boolean;

curdigit, noofdigit,
result: integer;
 
 ch,lastchar: char;


begin
readok:=false;
lastchar:=nul;
ch:=nul;
digit:=false;

(* now skip until a digit is encountered *)

if incharsleft > 0 then
repeat
lastchar:=ch;
ch:=readchar;
digit:= (ch in digits) or
((base= 16) and (ch in hexdigits))
until digit or (incharsleft<=0);

result:=0;
if base= 10 then
negative:= lastchar= "-"
else negative:= false;


if digit then
begin 
if ch in digits
then result:= ord (ch) - ord ("0")
else result:= ord (ch) - 87 (*ord ("W")*);
readok:=true;
end;

if base=10 then
begin
while digit and (incharsleft>0) do
begin (* read the digits *)
ch:= readchar;

digit:= (ch in digits) or
((base= 16) and (ch in hexdigits));
if digit then
begin
if negative and (result=3276) and (ch="8")
then begin
result:= -32768;
negative:= false;
end
else
begin
if ch in digits
then result:= result*base+(ord(ch)-ord("0"))
else result:= result*base+(ord(ch)-87(*ord("W")*));
end;
end;
end (* while *);

if negative then result:= - result;

end (* base= 10 *)

else
begin (* base= 2, 8, or 16 *)
 
case base of
2:begin
if ch="1" then negative:= true;
noofdigit:= 16;
end;

8: begin
if ch="1" then negative:= true;
noofdigit:= 6;
end;
 
16: begin
if ch>="8" then negative:= true;
noofdigit:= 4;
end;
end (*case*);
curdigit:= 1;
 
while digit and (incharsleft>0) do
begin
ch:= readchar;
digit:= (ch in digits) or
((base=16) and (ch in hexdigits));
if digit
then begin
curdigit:= curdigit+1;
if (curdigit=noofdigit) and negative then
begin
case base of
2: result:= result - 16384 (*2^14*);
8: result:= result -  4096 (*2^12*);
16:result:= result -  2048 (*2^11*);
end (*case*)
end;
if ch in digits then
result:= result*base + (ord(ch)-ord("0"))
else
result:= result*base + (ord(ch)-87 (*ord("W")*));
if (curdigit=noofdigit) and negative
then begin
if result=0
then result:= -32768
else result:= -((32767-result)+1);
end;
end (*if digit*);
end (*while digit*);
end (* base= 2, 8, or 16 *);
if incharsleft > 0 then
(* we read one char too many - spit it out *)
repeatchar;

readinteger:=result;
end (* read integer *);
\f


procedure repeatchar;
begin
lock opinref as opbuf: opbuftype do
opbuf.next:= opbuf.next - 1;
incharsleft:= incharsleft + 1;
end;
\f

  
function testinterval (i,first,last: integer): boolean;
(* true if first<=i<=last *)
begin
if (i<first) or (i>last) then
begin
outstring10(illegalno);
outinteger(i,4);
writenl;
testinterval:= false
end
else
testinterval:= true;
end;
\f


procedure testmodeout (text: alfa20; i: integer);
begin
if testmode then
begin
outstring20 (text);
outinteger (i, 4);
writenl;
end;
end (* testout *);
\f


procedure testsem(i: integer);
(* test the semaphore "sem( semno)", and
writes its status on the console if it is
non-passive *)
var more: boolean;
begin

if open( sem(i) ) then
begin (* user semaphore no. i is open *)
outdecimal(i,3);
outchar(":");
more:= true;

(* now count the no. of buffers on this semaphore *)
j:=0; (* j is the counter *)

while more do
begin
sensesem(countref, sem(i) );
if nil(countref) then
more:= false
else
begin
signal(countref,countsem);
j:=j+1;
end
end;

outdecimal(j,3);

while open(countsem) do
begin (* return the buffers to sem(i) *)
wait(countref,countsem);
signal(countref,sem(i) );
end;

writenl;
end (* open *)
else
if locked( sem(i) ) then
begin (* user semaphore no. i is locked *)
outdecimal(i,3);
outchar(":");
outstring10(" locked   ");
writenl;
end;
end (* testsem *);




\f

 
procedure writenl;
(* prepares opbuf for output to the operator and signals
it to operator module *)
begin
if not nil(opoutref) then
begin
outchar(nl);
signal(opoutref, opsem^)
end;
wait(opoutref, wsem);
lock opoutref as opbuf: opbuftype do
opbuf.last:= firstindex;
end (* writenl *);
 
\f





      (****************************************
      *                                       *
      *       m a i n   p r o g r a m         *
      *                                       *
      ****************************************)






begin

testmode:= false;
testopen (z,"test        ",semvector(operatorsem));
testout(z,version,0);

(* initialise buffers *)
for i:= 1 to 2 do
begin
alloc (opoutref, opbufpool, wsem);
opoutref^.u1:=2; (* write *)
lock opoutref as opbuf: opbuftype do
with opbuf do
begin
first:= firstindex;
name:= "test        ";
data(firstindex):= "!";
end;
return (opoutref);
end;
writenl;

alloc(opinref, opbufpool, wrsem);

opinref^.u1:=1; (* read *)

lock opinref as opbuf: opbuftype do
with opbuf do
begin
first:= firstindex;
last:= lastindex;
name:= "test        ";
end;
 
opsem:= semvector(operatorsem);
st:= 1024;
base:= 10;
firstword:= 1;
lastword:= 10;

(* output initial line to the operator console *)

repeat
(* read a line of input from the operator and execute it *)

getinput;
 
case command of
 
";": (* comment command *)
begin
end;
 
"a": (* alloc *)
(* a buffer is allocated from the messbufpool to the current
reference "cur".
1st param is the answersem *)
begin
semno:= params(1);

if noofparams >= 1 then
if nil(cur) then
if (1<=semno) and (semno<=noofsemaphores) then
begin
alloc (cur, messbufpool, sem(semno));
with cur^ do
begin
u1:= 0;
u2:= 0;
u3:= 0;
u4:= 0;
end;
end
else outstring10(illegalno)
else outstring20("you already have one")
else outstring10(noparam)
end (* alloc*);
 
"b": (* base *)
(* defines the number base for input as well as output *)
(* the base is always read decimally *)
begin
if noofparams < 1 then
begin
base:= oldbase;
outstring10(noparam)
end
else

if not (params(1) in (. 2, 8, 10, 16 .) ) then
begin (* illegal base *)
outstring20("illegal base        ");
base:= oldbase;
end
else
base:= params(1);
end;
 
"c": (* create *)
(* an incarnation of each of the predefined modules to be tested
is created and started.
params are nos. of the modules to be created and started *)

if noofparams >= 1 then
 
begin
moduleno:= params(1);

if noofparams>1 then st:= params(2);

if (moduleno<1) or (moduleno > noofmodules) then
begin (* illegal no *)
outdecimal(moduleno,4);
outstring10(illegalno);
end
else
if moduleready(moduleno) then

case moduleno of

1:
begin
outdecimal (moduleno, 4);
outstring10(illegalno);
end;
<*///////////////////////////////////////////
1:
if not nil(sh(1)) then
outstring20 (alreadyexists)
else

begin
if noofparams<2 then st:= tss_size;
link("tssupervisor",tssuper);
cv:= create(
tssuper(
"tssupervisor",
semvector,
sem),
sh (1), st, pu);
 
if createok(cv) then
start(sh(1),pr) else unlink(tssuper)
end;
 
2:
if not nil(sh(2)) then
outstring20 (alreadyexists)
else

begin
if noofparams<2 then st:= ath_size;
link ("at_handler  ",at_handler);
cv:= create (at_handler(
"at_handler  ",
alarmnetaddr(macroaddr(7,0,0),0),
sem,
lam_sem_tab,
semvector),
sh(2), st, pu);
 
if createok(cv) then
start(sh(2),pr) else unlink(at_handler)
end;
 
3:
if not nil(sh(3)) then 
outstring20 (alreadyexists)
else

begin
if noofparams<2 then st:= vch_size;
link ("vc_handler  ",vc_handler);
cv:= create (vc_handler(
"vc_handler  ",
alarmnetaddr(macroaddr(7,0,0),0),
sem,
lam_sem_tab,
semvector),
sh (3), st, pu);

if createok(cv) then
start(sh(3),pr) else unlink(vc_handler)
end;
 
4:
if not nil(sh(4)) then
outstring20 (alreadyexists)
else

begin
if noofparams<2 then st:= tim_size;
link ("timeout     ",timeout);
cv:= create (timeout(
"timeout     ",
opsem,
sem (timeout_sem_no),
(*  sem(10),              (**  not with systimer      **)
                time_out_unit (* ticklength *),
                40 (* max *)),
                sh(4),st,pu);

if createok(cv) then
start(sh(4),pr) else unlink(timeout)
end;
 
5:
if not nil(sh(5)) then
outstring20 (alreadyexists)
else
 
begin
if noofparams<2 then st:= atc_size;
link ("atconnector ",atconnector);
cv:= create(atconnector(
"atconnector ",
semvector,
sem (atc_sem_no),
sem (ath_sem_no),
sem (lam_sem_no),
sem (timeout_sem_no),
257 (*ownaddr*),
7 (*channelno*)),
                    sh(5),st,pu);

if createok(cv) then
start(sh(5),pr) else unlink(atconnector)
end;
 
6:
if not nil(sh(6)) then
outstring20 (alreadyexists)
else

begin
if noofparams<2 then st:= vcc_size;
link ("vcatc       ",vcatc);
cv:= create(vcatc(
"vcatc       ",
semvector,
sem (vcatc_sem_no),
sem (vch_sem_no),
sem (vagt_sem_no),
sem (timeout_sem_no),
macroaddr(7,0,0),
63, (*own micro*)
2 (*channelno*)),
sh (6), st, pu);

if createok(cv) then
start(sh(6),pr) else unlink(vcatc)
end;
 
7:
if not nil(sh(7)) then
outstring20 (alreadyexists)
else

begin
if noofparams<2 then st:= tsc_size;
link ("tsconnector ",tsconnector);
cv:= create (tsconnector(
"tsconnector ",
semvector (*system_vector*),
sem(netc_sem_no) (*inputsem*),
sem(tssup_sem_no) (*tsssem*),
sem(dc_sem_no) (*dcsem*),
sem(lam_sem_no) (*lamsem*),
sem(timeout_sem_no) (*timeoutsem*),
sem (net_int1),
sem (net_int2),
sem (net_int3),
sem (net_int4),
sem (net_int5),
sem (net_int6)),
sh(7),st,pu);

if createok(cv) then
start(sh(7),pr) else unlink(tsconnector)
end;
  
8: (* vagt *)
if not nil(sh(8)) then
outstring20(alreadyexists)
else
begin
if noofparams<2 then st:= vc_sim_size;
link("vagt        ",vagt);
cv:= create(vagt(
"vagt        ",
semvector,
sem),
sh(8),st,pu);
if createok(cv) then
start(sh(8),pr) else unlink(vagt)
end;
  
 
9: (* lam *)
if not nil (sh(9)) then
outstring20 (alreadyexists)
else

begin
if noofparams<2 then st:= lam_size;
link ("lam         ",lam);
cv:= create (lam(
"lam         ",
semvector,
pu,
5 (*level*),
sem(lam_sem_no)),
sh(9), st, pu);
 
if createok(cv) then
start (sh(9), pr) else unlink(lam)
end;
  
11: (* dc_module *)
if not nil(sh(11)) then
outstring20(alreadyexists)
else
begin
if noofparams<2 then st:= dc_sim_size;
link("dcmodule    ",dcmodule);
cv:= create(dcmodule(
"dcmodule    ",
semvector,
sem(lam_sem_no),
sem(timeout_sem_no),
sem(dc_sem_no),
sem(dc_int1),sem(dc_int2),sem(dc_int3),sem(dc_int4)),
sh(11),st,pu);
if createok(cv) then
start(sh(11),pr) else unlink(dcmodule)
end;
//////////////////////////////////////////*>
 
otherwise
begin
outdecimal(moduleno, 4);
outstring10(illegalno);
end 
end (*case*)
end (* if noofparams >= 1 *)
else outstring10 (noparam);
(* end create *)
 
"f": (* fill *)
(* fills integers into current buffer.
1st param: first word no. to be filled,
following: values to be assigned *)
begin
if noofparams < 2 then
outstring10("param     ")
else
if (params(1) < 1) then
outstring20("illegal start       ")
else
if nil(cur) then 
outstring10("no buffer ")
else
begin (* params are ok *)
i:= params(1); (* i points into the messbuf *)

for j:= 2 to noofparams do
(* j points into the param list *)
if i <= messbufsize then
begin
lock cur as messbuf: messbuftype do
messbuf(i):= params(j);
i:= i + 1;
end;

end (* params ok *)
end (* fill *);
 
"h": (* help *)
(* lists possible commands and no. of parameters *)
(*///////////////////////////////////////////////
begin
outstring20("comm and no of param"); writenl;
outstring20("a: allocate   1     "); writenl;
outstring20("b: base       1     "); writenl;
outstring20("c: create     >=1   "); writenl;
outstring20("e: execute    1     "); writenl;
outstring20("f: fill       2     "); writenl;
outstring20("h: help       0     "); writenl;
outstring20("k: kill       >=1   "); writenl;
outstring20("o: output     0 to 2"); writenl;
outstring20("p: partial    >=3   "); writenl;
outstring20("r: return     0     "); writenl;
outstring20("s: signal     1     "); writenl;
outstring20("t: test       0 or 1"); writenl;
outstring20("u: user param 1 to 4"); writenl;
outstring20("w: wait       1     "); writenl; 
outstring20("x: testmode   0     "); writenl;
outstring20(";: comment          ");
end;
////////////////////////////////////////////////*);
 
"k": (* kill *)
(* removes incarnation of tested module(s) 
params are nos. of modules to be removed *)

(*////////////////////////////////////////////
if noofparams >= 1 then
for i:= 1 to noofparams do
begin
moduleno:= params(i);
if (1<=moduleno) and (moduleno<=noofmodules) then
if not nil(sh(moduleno)) then
remove (sh(moduleno))
else
begin
outdecimal (moduleno, 4);
outstring10(" not alive");
writenl;
end
else
begin
outdecimal (moduleno, 4);
outstring10(illegalno);
writenl;
end
end
else outstring10("no params ");
///////////////////////////////////////////*);
 
"o": (* output *)
(* outputs current buffer incl. user parameters 
1st param is firstword,
2nd param is lastword *)
begin
if nil(cur) then
outstring10 ("no buffer ")
else
begin
outchar("u");
outchar(":");
 
outinteger(cur^.u1,4);
outinteger(cur^.u2,4);
outinteger(cur^.u3,4);
outinteger(cur^.u4,4);
writenl;
 
if (noofparams>=1) and (params(1)>=1)
and (params(1)<= messbufsize) then
firstword:= params(1);
 
if (noofparams>=2) and (params(2)<=messbufsize) then
lastword:= params(2);
if lastword>messbufsize
then lastword:= messbufsize;
 
if cur^.size<messbufsize then
outstring20("too small buffer    ") else
for i:= firstword to lastword do
begin
outdecimal(i,3);
outchar(":");
lock cur as messbuf: messbuftype do
if base= 2 then
outinteger(messbuf(i),17)
else
outinteger(messbuf(i),7);
writenl;
end;
end (* ok *);
end (* output *);
 
"p": (* partial words *)
(* fills partial words i.e. bytes into current buffer.
1st param: word no. in which to start
2nd param: byte no. (of 1st word) in which to start:
-           0: left byte
-           1: right byte
following: byte values to be assigned *)
begin
if noofparams<2 then
outstring10("param     ")
else
if (params(1)<1) then
outstring20("illegal start-word  ")
else
if not (params(2) in (.0,1.)) then
outstring20 ("2nd must be 0 or 1  ")
else
if nil (cur) then
outstring10 ("no buffer ")
else
begin (* params are ok *)
i:= params(1); (* i points into current buffer *)
j:= params(2);
 
if cur^.size<messbufsize then
outstring20("too small buffer    ") else
lock cur as messbuf: messbuftype do
begin
if messbuf(i)<0 then
leftbyte:= (messbuf(i)+255) div 256
else
leftbyte:= messbuf(i) div 256;

for k:= 3 to noofparams do
(* k points into the parameter list *)
if i<= messbufsize then
begin
case j of
0:
begin (* left *)
rightbyte:= abs(messbuf(i) mod 256);
leftbyte := params (k);
end;
1:
begin (* right *)
rightbyte:= params (k);
if leftbyte>=128 then
begin
messbuf(i):= (leftbyte-128)*256 + rightbyte;
if messbuf(i)>0 then
messbuf(i):= -((32767-messbuf(i))+1)
else messbuf(i):= -32768;
end
else
messbuf(i):= leftbyte*256 + rightbyte;
i:= i+1;
end;
 
end (* case *);
 
j:= 1-j;
end;
 
if (j=1) and (i<=messbufsize) then
if leftbyte>=128 then
begin
if messbuf(i)>0 then
messbuf(i):= (leftbyte-128)*256 + rightbyte
else messbuf(i):= - 32768;
messbuf(i):= -((32767-messbuf(i))+1);
end
else
messbuf(i):= leftbyte*256 + rightbyte;
end (* lock *);
end (* params ok *);
end (* partial *);
 
"r": (* return *)
(* returns current buffer *)
if nil(cur)
then outstring10("no buffer ")
else return(cur);

"s": (* signal *)
(* signals current buffer to one of the predefined semaphores.
1st param is semno *)
begin
semno:= params(1);

if noofparams >= 1 then
if (1<=semno) and (semno<=noofsemaphores) then
if not nil(cur) then
signal (cur,sem(semno))
else outstring10("no buffer ")
else outstring10(illegalno)
else outstring10(noparam)
end (* signal *);
 
"t": (* testsem *)
(* tests the status of the specified semaphores.
if none is specified, the status of all the
user semaphores is given.
in both cases nothing will be written for a semaphore
if it is passive. *)
begin
if noofparams=0 then
begin (* test all semaphores *)

for i:=1 to noofsemaphores do
testsem(i)
end (* test all *)
else
begin (* test the specified semaphores *)

for i:=1 to noofparams do
if (params(i)<1) or (params(i)>noofsemaphores) then
begin (* illegal no. *)
outstring20("illegal no.:        ");
outdecimal(params(i),3);
writenl;
end (* illegal no *)
else
testsem( params(i) );
end (* test the specified semaphores *)
end (* testsem *);

 
"u": (* user parameters *)
(* inserts user param into header of current buffer
1st param is u1
2nd param is u2
3rd param is u3
4th param is u4 *)
begin
if nil(cur) 
then outstring10("no buffer ")
else
if noofparams = 0 then
outstring10(noparam)
else
with cur^ do
begin
if testinterval (params(1),0,255) then u1:= params(1);
if (noofparams>=2) then if testinterval(params(2),0,255) then
u2:= params(2);
if (noofparams>=3) then if testinterval(params(3),0,255) then
u3:= params(3);
if (noofparams>=4) then if testinterval(params(4),0,255) then
u4:= params(4);
end
end; (* end user parameters *)


"w": (* wait *)
(* waits for semaphore semno.
1st param is semno *)
begin
semno:= params(1);

if noofparams >= 1 then
if nil(cur) then
if (1<=semno) and (semno<=noofsemaphores) then
begin
sensesem( cur, sem(semno));
if nil(cur) then
outstring20("semaphore not open  ")
end
else outstring10(illegalno)
else outstring20("you already have one")
else outstring10(noparam)
end (* wait *);
 
"x": (* testmode *)
(*///////////////////////
testmode:= not testmode;
////////////////////////////*);
 
 
otherwise (* error *)
outstring20 ("illegal comm. type h");
end (* case *);

if command<>";" then
writenl;
  
until false;
  
end.



«eof»