DataMuseum.dk

top - metrics - download

    Length: 43776 (0xab00)
    Types: TextFileVerbose
    Names: »tsaosjob«

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

TextFileVerbose

job oer 7 200 time 11 0 area 10 size 100000
(source=copy 25.1
tsaoslst= set 1 disc1
tsaoserr=set 1 disc1
tsaoslst= indent source mark lc
listc= cross tsaoslst
o tsaoserr
head 1
message tsaos program
pascal80 spacing.3000 codesize.3000 evaenv alarmenv paxenv source
o c
lookup pass6code
if ok.yes
(tsaosbin=set 1 disc1
tsaosbin=move pass6code
scope user tsaosbin
)
tsaoslst=copy listc tsaoserr
scope user tsaoslst
scope user tsaoserr
finis output.no
)
  
  
\f

  
process alarm_opsys(var semvector: system_vector;
var evavector: appl_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  4.08 /";


\f


const
opbufsize = 80; (* no. of bytes in buffers to the operator module *)
(***   bufs   ***)
messbufsize= 64; (*words*)
testbufsize= 120;
maxbufsize= 120;
minbufsize=  16;
noofmodules= 21;
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

(*---- for alarmenv later  ------*)

paxpooltype = pool no_pax_bufs of min_rut_mess;

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;
paxbufpool : paxpooltype;

(**********  semaphores  **********)
spool_sem,
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  **********)
nref,
countref,    (* used by "t"-command *)
opinref,    (* ref. to buffer from operator *)
opoutref,   (* ref. to buffer to operator *)
cur           (* ref. to current buffer *)
: reference;

(**********  pointers  **********)
spool_test_sem : sempointer;
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  **********)
netc_locals : netc_loc_sems;
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;
node_no : byte;
dte_addr : int_pax_addr := int_pax_addr(0,0,0,3);
\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 timout(
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;

process dtesimulator (
test_sem : sempointer;
var
pax_pool_sem,
dte_sem : !ts_pointer;
var
netc_sem,
rut_trm_sem,
rut_rec_sem : !sempointer;
dte_addr : int_pax_addr
);
external;

process netconnector (
global_timeout : byte;
test_sem : sempointer;
var
pax_pool_sem,
main_sem : !ts_pointer;
local_sem_table : netc_loc_sems;
var
com_pool_sem,
timeout_sem,
dte_sem : !sempointer
);
external;

process tapdte (
op_sem : sempointer;
var sem : ! ts_pointer );
external;

process tapnet (
op_sem : sempointer;
var sem : !ts_pointer );
external;

process testoutput (
 insem,
opsem : sempointer );
external;


procedure setoflowmask( oflow: boolean);
external;
  
procedure readram( var result:byte; index : integer);
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


function dte_pax_addr (i:integer): int_pax_addr;
var pax_adr : int_pax_addr;
begin
pax_adr.net_addr := params(i);
pax_adr.reg_addr := params(i+1);
pax_adr.node_addr := params(i+2);
pax_adr.ext_addr := params(i+3);
dte_pax_addr := pax_adr;
end;

procedure make_phead (
i : integer; op_code : byte;
var p : format_1_packet_header );
begin
with p do
begin
format := rut_format_1;
priority := rut_prio_0;
packet_type := rut_pack_type;
state := 0;
org := dte_pax_addr(i);
dst := dte_pax_addr(i+3);
facility := params(9);
user_field := op_code *256 + params(2);
top_of_data := 0;
end;
end;
\f


function packmacro (
par:integer):macroaddr;
var
a:macroaddr;
begin
a.dc_addr := params( par);
a.nc_addr := params( par+1);
a.ts_addr := params( par+2);
packmacro := a;
end;

function packextnode (
par:integer) : ext_pax_addr;
var
i:integer;
a:ext_pax_addr;
begin
for i:=1 to 6 do
a(i):=0;
for i:=0 to 2 do
begin
a(7+i):=params(par+i);
testout(z,"params      ", params(par+i));
end;
for i:= 10 to 14 do
a(i) := 0;
for i := 1 to 14 do
testout(z,"a           ", a(i));
packextnode := a;
end;
\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","d","e","f","k","n","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 = "timout      ";
n5 = "atconnector ";
n6 = "vcatc       ";
n7 = "tsconnector ";
n8 = "atvagtsim   ";
n9 = "lam         ";
n10= "tap         ";
n11= "dcmodule    ";
n13= "ncsupervisor";
n14= "vcitc       ";
n15= "itvagtsim   ";
n16= "alc         ";
n17= "netconnector";
n18= "dtesimulator";
n19= "tapdte      ";
n20= "tapnet      ";
n21= "testoutput  ";
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,
timout( 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(pax_sem_2), sem(pax_sem_1),
sem(pax_ncp_sem), sem(dte_sem_no)),
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, 1);
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);
17: (* netconnector *)
init_proc ( index, n17, n17,
netconnector( glob_timeout, spool_test_sem,
sem( pax_pool),sem( netc_sem_no), netc_locals,
sem( com_pool).w, 
sem( timeout_sem_no).s, sem( dte_sem_no).s),
netc_size, netc_pri);

18: (* dtesimulator *)
init_proc ( index, n18, n18,
dtesimulator ( spool_test_sem, sem( pax_pool), sem(dte_sem_no),
sem( netc_sem_no).s,
sem( pax_sem_1).s, sem( pax_sem_2).s,
dte_addr),
netc_size, netc_pri);
19: (* tapdte *)
init_proc ( index, n19, n19,
tapdte ( opsem, sem(tap_dte_sem_no)),
512,0);
20: (* tapnet *)
init_proc ( index, n20, n20,
tapnet ( opsem, sem(tap_net_sem_no)),
512,0);

21: (* testoutput *)
init_proc ( index, n21, n21,
testoutput ( spool_test_sem, opsem),
512,0);



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; var t_sem : semaphore);
(* test the semaphore t_sem, and
writes its status on the console if it is
non-passive *)
var more: boolean;
begin

if i>0 then
begin
ap.a := sem(i).s;
bp.a := sem(i).w;
end
else ap:=bp;
if open(t_sem) 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, t_sem);
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,t_sem);
end;

writenl;
end (* open *)
else
if locked( t_sem) 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);
spool_test_sem := ref( spool_sem);
testmode:= false;
testopen (z,own.incname,opsem);
testout(z,version,al_env_version);

readram(node_no,10);
node_no := node_no mod 16;
dte_addr.net_addr := 0;
dte_addr.reg_addr := 0;
dte_addr.node_addr := node_no;
dte_addr.ext_addr := 3;


testout(z,"ext-pax-addr",
paxnet_config( node_no,3)*1000 + paxnet_config( node_no,6)*100 +
paxnet_config( node_no,9)*10  + paxnet_config( node_no,14) );
 
(* 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;

(*  initialize pointers to eva semaphores *)
sem(pax_sem_2).s:=ref(evavector(px_urec1));
sem(pax_sem_2).w:=sem(pax_sem_2).s;
sem(pax_sem_1).s:=ref(evavector(px_utrm1));
sem(pax_sem_1).w:=sem(pax_sem_1).s;
sem(pax_sem_3).s := ref(evavector(px_urec2));
sem(pax_sem_3).w := sem(pax_sem_3).s;
sem(pax_sem_4).s := ref(evavector(px_utrm2));
sem(pax_sem_4).w := sem(pax_sem_4).s;
sem(pax_ncp_sem).s:=ref(evavector(px_ncp));
sem(pax_ncp_sem).w:=sem(pax_ncp_sem).s;
sem(lam_sem_no).s := ref( evavector(al_lam1));
sem(lam_sem_no).w := sem( lam_sem_no).s;

(*  initialize local semaphores for netconnector  *)

netc_locals(1):=sem(tssup_sem_no).s;
netc_locals(2):=sem(nc_sem_no).s;

(* 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:= "alarm       ";
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:= "alarm       ";
end;
 
(*-------    allocate all listenbuffers ---*)
for i:= 1 to no_listen do
begin
alloc(cur,messbufpool,sem(com_pool).s^);
return(cur);
end;

(*-------    allocate all paxnetbuffers ---*)
for i:=1 to no_pax_bufs do
begin
alloc( cur, paxbufpool, sem(dte_sem_no).s^);
signal( cur, sem( pax_pool).s^);
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 ((semno>0) and (semno <= noofsemaphores))
or ((semno<0) and (semno >= -applsem_max)) then
begin
if semno > 0 then
alloc (cur, testbufpool, ts_sem(semno))
else
alloc (cur, testbufpool, evavector(-semno));
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


"d": (*  test dtesimulator  *)
begin
outstring10("test dte  ");

sensesem( nref, sem( pax_pool).w^);

if not nil( nref) then
begin
nref^.u2 := 7;
nref^.u4 := from_link;

case params(1) of



1: (* answer to connect ext *)
begin
nref^.u1 := rut_con;
nref^.u2 := rut_ok;
nref^.u3 := 7;

lock nref as buf: rut_prefix_type do
buf.ext_no := params(2);
(* ie  d 1 20  answers on connect ext 20 *)
end;

2 : (* send ric buffer *)
begin
nref^.u1 := dte_ric;
nref^.u4 := to_link;
end;
(* ie d 2  sends a ric-buffer to dte *)

3: (* receive call from remote user *)
begin
nref^.u1 := rut_rec;
nref^.u2 := rut_ok;
nref^.u3 := rut_default;
lock nref as buf : rut_trp_pdata do
with buf do
begin
make_phead( 3, dte_car, phead);
for i := label_size+3 to l_listen do
alarm_mess.da(i) := i;
end
end;
(*        stream    sender  receiver  facility  *)
(* ie d 3   1       0 0 4   0 0 2     0     is 4 sending call to 2 *)
\f


4 : (* send receipt for call *)
if params(2) = 1 then
begin  (* aic *)
nref^.u1 := dte_aic;
nref^.u3 := 1;
nref^.u4 := to_link;
lock nref as buf : aic_buf_type do
begin
buf.aic_id := 1;
buf.aic_q := false;
end
end
else
begin   (* rejic *)
nref^.u1 := dte_rejic;
nref^.u3 := 1;
nref^.u4 := to_link;
lock nref as buf : rejic_buf_type do
begin
buf.rejic_id := 1;
buf.rejic_diag := params(3);
end
end;
(* ie d  4  1  sends aic-buffer   *)
(* ie d  4  0  sends rejic-buffer *)

5: (* receive data from remote user *)
begin
nref^.u1 := rut_rec;
nref^.u2 := rut_ok;
nref^.u3 := rut_default;
lock nref as buf : rut_trp_pdata do
with buf do
begin
make_phead( 3, dte_sdata, phead);
control.op_code := opc_command;
for i := label_size+3 to l_listen do
alarm_mess.da(i) := i;
end;
end;
(*        strm    sender   rec   fac   *)
(* ie d 5  1      0 0 4   0 0 2   0   sends data from 4 to 2 *)
\f


6: (* clear from remote user *)
begin
nref^.u1 := rut_rec;
nref^.u2 := rut_ok;
nref^.u3 := rut_default;
lock nref as buf : rut_trp_pdata do
with buf do
begin
make_phead( 3, dte_clr, phead);
end;
end;
(*          strm   sender   rec   fac  *)
(* ie d  6   1     0 0 4   0 0 2   0   clears stream 1 from 4 to 2 *)


\f


10: (* call request *)
begin
nref^.u1 := dte_car;
nref^.u3 := params(2);
nref^.u4 := to_link;
lock nref as buf:car_buf_type do
with buf do
begin
first := ric_first_val;
last := ric_first_val+l_control+l_listen-1;
q_bit := false;
with call_buf do
begin
control.op_code := dte_car;
dte_adr_l := l_dte_adr;
dte_adr := paxnet_config( params(5));

facility_l := l_facilities;
facility := params(6);
for i := label_size+3 to l_listen do
alarm_mess.da(i):=i;
end;
end;
end;
(*       strm rec   fac     *)
(* ie d 10  1  0 0 3  0 sends a call to 3 on stream 1 *)
(* ie d 10  2  0 0 4  0 sends a call to 4 on stream 2 *)
\f


11: (* call accepted from remote user *)
begin
nref^.u1 := rut_rec;
nref^.u2 := rut_ok;
nref^.u3 := rut_default;
lock nref as buf: rut_trp_pdata do
with buf do
make_phead( 3, dte_aic, phead);
end;
(*         strm  sender  rec  fac  *)
(* ie d  11  1  0 0 3  0 0 2  0  is 3 accepting call from 2 *)

12: (* send data to remote user *)
begin
nref^.u1 := dte_sdata;
nref^.u3 := params(2);
nref^.u4 := to_link;
lock nref as buf : dte_sdata_data do
with buf do
begin
q_bit := false;
m_bit := false;
control.op_code := opc_command;
for i := label_size+3 to l_listen do
alarm_mess.da(i) := i;
end
end;
(* ie d  12  1      sends data on stream 1 *)

13: (* clear stream to remote user *)
begin
nref^.u1 := dte_clr;
nref^.u4 := to_link;
nref^.u3 := params(2);
lock nref as buf : clear_buf_type do
buf.diag_code := params(3);
end;

(*         strm   diag-code  *)
(* ie d 13  1        16    sends clear stream to dte *)


otherwise

outstring10("undef test");
end;
signal( nref, sem( dte_sem_no).s^);
end
else
outstring10("no paxbufs");

end;
\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


"n": (*  test netconnector *)
begin

outstring10("test netc ");


case params(1) of
\f


1: (* update pax-table from local sup *)
begin
sensesem( nref, sem( com_pool).w^);

if not nil( nref) then
begin
nref^.u2 := 7;
nref^.u3 := netc_route1;
nref^.u4 := #hac;

lock nref as buf : record
a:alarmlabel;
i : integer;
p:paxnet_e;
end do
with buf do
begin
a.no_of_by := l_listen;
a.update := modify_code;
a.rec.macro := packmacro(2);
a.rec.micro := netc_mic_addr;
a.send.macro := packmacro(5);
p.al_mac_addr := packmacro(8);
p.pax_addr := paxnet_config( params(13));

i := params(14);
p.stream_no := params(15);
p.max_retrans := 1;
end;
end;
(*       receiver sender al-mac  pax indx stream       *)
(* ie n 1  0 0 0  1 0 0  1 2 2  0 0 2  1  1 sets netc address *)
(* ie n 1  1 2 2  1 0 0  1 2 0  0 0 2  2  2 sets ncsup addr   *)
(* ie n 1  1 2 2  1 0 0  1 3 2  0 0 3  7  0 sets global ts-adr*)
(* ie n 1  1 2 2  1 0 0  1 3 0  0 0 3  8  0 sets global nc-adr*)
end;
\f


2 : (* update pax-table from net *)
(*---- comming in a ric-buffer --*)
begin
sensesem( nref, sem(pax_pool).w^);

if not nil( nref) then
begin
nref^.u1 := dte_ric;
nref^.u2 := 0;
nref^.u3 := 7;
nref^.u4 := to_link;

lock nref as buf : tst_ric_type do
begin
buf.c_i := params(16);
with buf.c_b do
begin
a_l.no_of_by := l_listen;
a_l.op_code := #hac;
a_l.update := modify_code;
a_l.rec.macro := packmacro(2);
a_l.rec.micro:=netc_mic_addr;
a_l.send.macro:=packmacro(5);
a_l.send.micro := 1;
p_e.al_mac_addr := packmacro(8);
p_e.pax_addr := paxnet_config( params(13));

indx:=params(15);
p_e.stream_no := params(14);
p_e.max_retrans := 1;
d_a := p_e.pax_addr;
end;
end
end;
end;
(*       receiver sender al-mac  pax  strm indx call-id  *)
(* ie n 2  1 2 2  1 0 0  1 4 2  0 0 4   1    9  1   sets global ts-addr *)
(* ie n 2  1 2 2  1 0 0  1 4 0  0 0 4   2   10  2   sets global nc-addr *)
(* ie n 2  1 2 2  1 0 0  1 5 2  0 0 5   3   11  3   sets global ts-addr *)
(* ie n 2  1 2 2  1 0 0  1 5 0  0 0 5   4   12  4   sets global nc-addr *)
\f


3:  (* send alarmmessage from local *)
begin
sensesem( nref, sem(com_pool).w^);

if not nil( nref) then
begin
nref^.u2 := 7;
nref^.u3 := tss_route;
nref^.u4 := #h30;

lock nref as abuf : max_alarm_mess do
with abuf do
begin
al.no_of_by := l_listen;
al.rec.macro := packmacro(2);
al.rec.micro := 0;
al.send.macro := packmacro(5);
al.send.micro := 0;
for i := label_size+3 to l_listen do
da(i) := i;
end;

(*        receiver sender *)
(* ie n 3  1 2 0   1 0 0  gives an alarm to ncsup local   *)
(* ie n 3  1 3 2   1 0 0  gives an alarm to tssup global  *)
(* ie n 3  1 3 0   1 0 0  gives an alarm to ncsup global  *)
end;
end;
\f


4:  (* update pax-table from net *)
(*--- comming in a databuffer ---*)
begin
sensesem( nref, sem( pax_pool).w^);

if not nil(nref) then
begin
nref^.u1 := dte_rdata;
nref^.u2 := 0;
nref^.u3 := params(2) mod 256;
nref^.u4 := to_link;

lock nref as buf : tst_sdata_data do
with buf do
begin
control.op_code := opc_command;
with a_l do
begin
no_of_by := l_listen;
op_code := #hac;
update := modify_code;
rec.macro := packmacro(3);
rec.micro := netc_mic_addr;
send.macro := packmacro(6);
send.micro := 0;
end;
indx := params(9);
with p_e do
begin
al_mac_addr := packmacro(10);
pax_addr := paxnet_config( params(15));

stream_no := params(16);
max_retrans := 1;
end;
end;
end;
end;

(*     strm receiver sender indx al-mac pax strm *)
(* n 4  1    1 2 2   1 0 0   1   1 4 2 0 0 4  1  *)
\f


5: (* send data or receipt from net *)
begin
sensesem( nref, sem(pax_pool).w^);

if not nil( nref) then
begin
nref^.u1 := dte_rdata;
nref^.u2 := 0;
nref^.u3 := params(4) mod 256;
nref^.u4 := to_link;

lock nref as buf : tst_sdata_data do
with buf do
begin
control.op_code := params(2);
control.data := params(3);
a_l.rec.macro := packmacro(5);
a_l.rec.micro := 0;
a_l.op_code := #h30;
end;
end;
end;

(*        opcode  data   stream   receiver  *)
(* n 5      x      x        1       1 2 2   *)
(* dte-aic  16     128   data-received *)
(* dte-rej  20      64   data-not-received *)
(* opc-rec  96           *)
(* opc-com  48           *)


otherwise
outstring10("undef test");
end;
if not nil( nref) then
signal( nref, sem( netc_sem_no).s^)
else
outstring10("no buffers");
end;

\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,ts_sem(semno))
else outstring10("no buffer ")
else
if (semno <= -1) and (semno >= -applsem_max) then
signal( cur, evavector( -semno))
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:= -applsem_max to -1 do
testsem( i,evavector(-i));

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

for i:=1 to noofparams do
if (params(i)=0) or (params(i)>noofsemaphores)
or (params(i) < -applsem_max) then
begin (* illegal no. *)
outstring20("illegal no.:        ");
outdecimal(params(i),3);
writenl;
end (* illegal no *)
else
begin
if params(i)>0 then
testsem( params(i), ts_sem(params(i)))
else
testsem( params(i), evavector(-params(i)));
end
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 ((semno>0) and (semno <= noofsemaphores))
or ((semno<0) and (semno >= -applsem_max)) then
begin
if semno > 0 then
sensesem( cur, ts_sem(semno))
else
sensesem( cur, evavector(-semno));
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»