⟦7a8356434⟧

TextFile

job jg 7 200 time 11 0 area 10 size 100000
(source=copy 25.1
tstoslst= set 1 disc1
tstoslst= indent source mark lc
listc= cross tstoslst
o errors
head 1
message tstos program
pascal80 spacing.3000 codesize.3000 jgenv source
o c
lookup pass6code
if ok.yes
(tstosbin=set 1 disc1
tstosbin=move pass6code
scope user tstosbin
)
tstoslst=copy listc errors
scope user tstoslst
convert errors
finis
)
  
  
  
process tsopsys(var 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  3.16 /";


\f


const
opbufsize = 80; (* no. of bytes in buffers to the operator module *)
(***   bufs   ***)
messbufsize= size_listen; (*words*)
testbufsize= size_listen*5;
maxbufsize= size_listen*3;
minbufsize=  1;
noofmodules= 16;
noofsemaphores= ts_sem_total;
pu= 0; (* processing unit number *)
pr= -1; (* timeslicing priority *)
 
valparam= "param val ";
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;

(***   bufs   ***)
messbuftype= array (1..messbufsize) of integer;
testbuftype= array (1..testbufsize) of integer;
minbuftype = array (1.. minbufsize) of integer;
maxbuftype = array (1.. maxbufsize) 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;
 
(* type necessary to compare sempointers *)
point_rec = record
a: sempointer;
end;
 
var
(*********  pools  *********)
opbufpool: pool 3 of opbuftype;
(***   bufs   ***)
testbufpool: pool 12 of testbuftype;
messbufpool: pool no_listen of messbuftype;

(**********  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;
ts_sem : array (1..ts_sem_total) of 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: sempointer;
worksem: sempointer;
sem : ts_pointer_vector;

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

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


(**********  integers  **********)
base,            (* number base for input and output *)
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 *)
curbufsize,     (* in words *)
curbuftype,     (* 0 - 4 *)
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. *)

(********** param to use in create **********)
dc_addr: macroaddr := macroaddr(7,0,0);
nc_addr: macroaddr := macroaddr(7,5,0);
ts_addr: macroaddr := macroaddr(7,5,4);
 
(*** auxiliary to compare sempointers ***)
ap,bp : point_rec;
\f

\f

 
(**********  externals **********)
process tssuper(
op: sempointer;
var ts_sem : !ts_pointer_vector);
external;
 
process at_handler(
op: sempointer;
var
dc_addr,
ts_addr: !macroaddr;
var ts_sem : !ts_pointer_vector);
external;
 
process vc_handler(
op: sempointer;
var
dc_addr,
ts_addr: !macroaddr;
var ts_sem : !ts_pointer_vector);
external;
 
process timeout(
opsem: sempointer;
var timeoutsem: !ts_pointer;
ticklength, max: integer);
external;
 
process atconnector(
opsem: sempointer;
var
atcsem,
quesem : !ts_pointer;
var
athsem,
driversem,
timsem,
com_sem: !sempointer;
var
dc_addr,
ts_addr: !macroaddr;
ownaddr: integer;
channelno: byte);
external;
 
process vcc(
opsem: sempointer;
var
messem,
quesem : !ts_pointer;
var
vchsem,
lamsem,
timeoutsem,
com_sem: !sempointer;
var
dcaddr,
tsaddr: !macroaddr;
micaddr: integer;
channelno: byte);
external;
 
process tsconnector(
opsem: sempointer;
var
tsssem,
dcsem,
ncsem,
lamsem,
timeoutsem,
com_sem: !sempointer;
var
inputsem,
semint1,
semint2,
semint3,
semint4: !ts_pointer);
external;
 
process lam(
opsem: sempointer;
pu, level: integer;
var inputsem: !ts_pointer);
external;
 
process vagt(
opsem: sempointer;
var sem: !ts_pointer_vector);
external;
  
process dcmodule(
opsem: sempointer;
var sem1,sem2,sem3,sem4: !sempointer;
var sem5,sem6,sem7,sem8: !ts_pointer);
external;
  
process tap(
opsem: sempointer;
var tab_sem: !ts_pointer);
external;
 
process ncsup(
opsem: sempointer;
var
main,
free,
done: !ts_pointer;
var
net_sem,
timeoutsem: !sempointer);
external;
 
procedure setoflowmask( oflow: boolean);
external;
  
 
(********** forwards **********)

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

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

procedure outstring12(text: alfa);
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


procedure get_curbuftype;
begin
if cur^.size < minbufsize then
curbuftype:= 0 else
if cur^.size < messbufsize then
curbuftype:= 1 else
if cur^.size < maxbufsize then
curbuftype:= 2 else
if cur^.size < testbufsize then
curbuftype:= 3 else
curbuftype:= 4;
  
case curbuftype of
0: curbufsize:= 0;
1: curbufsize:= minbufsize;
2: curbufsize:= messbufsize;
3: curbufsize:= maxbufsize;
4: curbufsize:= testbufsize;
end;
end;
\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","x".)
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 (."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


procedure init_proc(
index: integer;
name,
inc_name : alfa;
p    : processrec;
size,
prio : integer);
var
okl,
ok   : integer;
begin
if not nil(sh(index)) then
outstring20(alreadyexists) else
begin
if noofparams<2 then st:= size;
okl:= link(name,p.processref^);
ok:= create(inc_name,p,sh(index),st);
if ok=0 then
start(sh(index),prio) else
begin
ok:= ok*100+okl;
outstring20(createerror);
outstring12(inc_name);
outdecimal(ok,5);
writenl;
okl:= unlink(p.processref^);
end;
end;
end;
\f


procedure init_modul(index: integer);
const
n1 = "tssupervisor";
n2 = "at_handler  ";
n3 = "vc_handler  ";
n4 = "timeout     ";
n5 = "atconnector ";
n6 = "vcatc       ";
n7 = "tsconnector ";
n8 = "atvagtsim   ";
n9 = "lam         ";
n10= "tap         ";
n11= "dcmodule    ";
n13= "ncsupervisor";
n14= "vcitc       ";
n15= "itvagtsim   ";
n16= "alc         ";
begin
case index of
 1: (* tssup *)
init_proc(index, n1, n1,
tssuper( opsem, sem),
tss_size,tss_pri);
 2: (* ath *)
init_proc(index, n2, n2,
at_handler( opsem, dc_addr, ts_addr, sem),
ath_size,ath_pri);
 3: (* vch *)
init_proc(index, n3, n3,
vc_handler( opsem, dc_addr, ts_addr, sem),
vch_size,vch_pri);
 4: (* timeout *)
init_proc(index, n4, n4,
timeout( opsem, sem(timeout_sem_no), time_out_unit, 40),
tim_size,tim_pri);
 5: (* atc *)
init_proc(index, n5, n5,
atconnector( opsem, sem(atc_sem_no), sem(atc_sem_no+1),
sem(ath_sem_no).s, sem(lam_sem_no).s, sem(timeout_sem_no).s,
sem(com_pool).w, dc_addr, ts_addr, 257, 7),
atc_size,atc_pri);
 6: (* vcatc *)
init_proc(index, n6, n6,
vcc( opsem, sem(vcc_sem_no), sem(vcc_sem_no+1),
sem(vch_sem_no).s, sem(vas_sem_no).s, sem(timeout_sem_no).s,
sem(com_pool).w, dc_addr, ts_addr, 63, 2),
vac_size, vcc_pri);
 7: (* tsc *)
init_proc(index, n7, n7,
tsconnector( opsem, sem(tssup_sem_no).s,
sem(dc_sem_no).s,
sem(nc_sem_no).s, sem(lam_sem_no).s, sem(timeout_sem_no).s,
sem(com_pool).w, sem(netc_sem_no),
sem(net_int1), sem(net_int2),
sem(net_int3), sem(net_int4)),
tsc_size, tsc_pri);
 8: (* atvagtsim *)
init_proc(index, n8, n8,
vagt( opsem, sem),
vas_size, vc_sim_pri);
 9: (* lam *)
init_proc(index, n9, n9,
lam( opsem, pu, 5, sem(lam_sem_no)),
lam_size, lam_pri);
10: (* tap *)
init_proc(index, n10, n10,
tap( opsem, sem(tap_sem_no)),
512, 0);
11: (* dc *)
init_proc(index, n11, n11,
dcmodule( opsem, sem(lam_sem_no).s, sem(netc_sem_no).s,
sem(com_pool).w, sem(timeout_sem_no).s,
sem(dc_sem_no), sem(dc_int1), sem(dc_int2), sem(dc_int3)),
dc_sim_size, dc_sim_pri);
12: (* tap01 *)
init_proc(index, n10, "tap01       ",
tap ( opsem, sem(tap1_sem_no)),
512, 0);
13: (* ncsupervisor *)
init_proc(index, n13, n13,
ncsup( opsem, sem(nc_sem_no), sem(ncsup_int1), sem(ncsup_int2),
sem(netc_sem_no).s, sem(timeout_sem_no).s),
nc_sup_size, tss_pri);
14: (* vcitc *)
init_proc(index, n14, n14,
vcc( opsem, sem(vcc_sem_no+2), sem(vcc_sem_no+3),
sem(vch_sem_no).s, sem(vis_sem_no).s, sem(timeout_sem_no).s,
sem(com_pool).w, dc_addr, ts_addr, 64, 3),
vic_size, vcc_pri);
15: (* itvagtsim *)
init_proc(index, n15, n15,
vagt( opsem, sem),
vis_size, vc_sim_pri);
otherwise
begin
outdecimal(index,4);
outstring10(illegalno);
end;
end (* case *)
end;
\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 *);
 
procedure outstring12(text: alfa);
var
i: integer;
begin
for i:=1 to 12 do
outchar(text(i));
end;
\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

ap.a := sem(i).s;
bp.a := sem(i).w;
if open (ts_sem(i)) then
begin (* user semaphore no. i is open *)
if ap=bp then
outchar(" ") else outchar("^");
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, ts_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, ts_sem(i));
end;

writenl;
end (* open *)
else
if locked( ts_sem(i)) then
begin (* user semaphore no. i is locked *)
if ap=bp then
outchar(" ") else outchar("^");
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

opsem:= semvector(operatorsem);
testmode:= false;
testopen (z,"test-opsys  ",opsem);
testout(z,version,al_env_version);
 
(* initialise pointers *)
for i:=1 to ts_sem_total do
begin
sem(i).s:= ref(ts_sem(i));
sem(i).w:= sem(i).s;
end;

(* 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;
 
for i:= 1 to no_listen do
begin
alloc(cur,messbufpool,sem(com_pool).s^);
return(cur);
end;
st:= 1024;
base:= 10;
firstword:= 1;
lastword:= 10;

setoflowmask(true);
 
noofparams:= 0;
(* insert auto create with edit here *)

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

getinput;
 
case command of
 
";": (* comment command *)
begin
end;
\f


"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, testbufpool, sem(semno).s^);
with cur^ do
begin
u1:= 0;
u2:= 0;
u3:= 0;
u4:= 0;
end;
get_curbuftype;
outstring10("  bufsize ");
outinteger(curbufsize, 5);
outinteger(cur^.size, 5)
end
else outstring10(illegalno)
else outstring20("you already have one")
else outstring10(noparam)
end (* alloc*);
\f


"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;
\f


"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 init_modul(moduleno);
end (* if noofparams >= 1 *)
else outstring10 (noparam);
(* end create *)
\f


"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 <= curbufsize then
begin
case curbuftype of
1: lock cur as minbuf: minbuftype do
minbuf(i):= params(j);
2: lock cur as messbuf: messbuftype do
messbuf(i):= params(j);
3: lock cur as maxbuf: maxbuftype do
maxbuf(i):= params(j);
4: lock cur as testbuf: testbuftype do
testbuf(i):= params(j);
otherwise
end;
i:= i + 1;
end;

end (* params ok *)
end (* fill *);
\f


"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("i: init point 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: exch point 2     "); writenl;
outstring20(";: comment          ");
end;
\f


"i": (* initialise pointers *)
if noofparams=0 then
for i:=1 to noofsemaphores do sem(i).w:= sem(i).s else
if (params(1)>0) and (params(1)<=noofsemaphores) then
sem(params(1)).w:= sem(params(1)).s else
outstring10(valparam);
\f


"e", (* exception *)
     (* call of exception routine in one or more incarnations *)
"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
if command="e" then
break(sh(moduleno),#h2f) else
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 ");
\f


"m": (* testmode *)
testmode:= not testmode;
\f


"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)<= curbufsize) then
firstword:= params(1);
 
if (noofparams>=2) and (params(2)<=curbufsize) then
lastword:= params(2);
if lastword>curbufsize then 
lastword:= curbufsize;
 
if cur^.size<curbufsize then
outstring20("too small buffer    ") else
for i:= firstword to lastword do
begin
outdecimal(i,3);
outchar(":");
case curbuftype of
1: lock cur as minbuf: minbuftype do
   j:= minbuf(i);
2: lock cur as messbuf: messbuftype do
   j:= messbuf(i);
3: lock cur as maxbuf: maxbuftype do
   j:= maxbuf(i);
4: lock cur as testbuf: testbuftype do
   j:= testbuf(i);
otherwise
  j:= 0;
end;
if base= 2 then
outinteger(j,17)
else
outinteger(j,7);
writenl;
end;
end (* ok *);
end (* output *);
\f


"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 *);
\f


"r": (* return *)
(* returns current buffer *)
if nil(cur)
then outstring10("no buffer ")
else return(cur);
\f


"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).s^)
else outstring10("no buffer ")
else outstring10(illegalno)
else outstring10(noparam)
end (* signal *);
\f


"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 *);

\f


"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 *)

\f


"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).w^);
if nil(cur) then
outstring20("semaphore not open  ")
else
begin
get_curbuftype;
outstring10("  bufsize ");
outinteger(curbufsize, 5);
outinteger(cur^.size, 5)
end;
end
else outstring10(illegalno)
else outstring20("you already have one")
else outstring10(noparam)
end (* wait *);
\f


"x": (* exchange pointer *)
begin
if noofparams >= 2 then
if (params(1)>0) and (params(1)<=noofsemaphores) then
if (params(2)>0) and (params(2)<=noofsemaphores) then
begin
worksem:= sem(params(1)).w;
sem(params(1)).w:= sem(params(2)).w;
sem(params(2)).w:= worksem;
end
else outstring10(valparam)
else outstring10(valparam)
else outstring10(noparam)
end (* exchange pointer *);
 
 
otherwise (* error *)
outstring20 ("illegal comm. type h");
end (* case *);

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



▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦7a8356434⟧ TextFile

Derivation

TextFile
