DataMuseum.dk

top - metrics - download

    Length: 36096 (0x8d00)
    Types: TextFile
    Names: »feaosjob«

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

TextFile

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





\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.20 /";



\f


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

\f


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  **********)
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  **********)
opsem: sempointer;
worksem: sempointer;
sem : ts_pointer_vector;

\f


(**********  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;

\f


(**********  externals **********)
PROCESS fesupervisor(
op: sempointer;
VAR input_sem, write_sem, que_sem : ! ts_pointer;
VAR stream_sem, netc_sem, com_pool : ! sempointer);
EXTERNAL;

PROCESS streamer(
VAR input_sem, xmitter, receiver : ! ts_pointer;
retrans_max : integer;
op : sempointer);
EXTERNAL;
  
process fpadriver(
var sem : ! ts_pointer;
level, block : integer;
rec : boolean;
op: sempointer);
EXTERNAL;

PROCESS timeout(
opsem: sempointer;
VAR timeoutsem: !ts_pointer;
ticklength, max: integer);
EXTERNAL;

PROCESS lam(
opsem: sempointer;
pu, level: integer;
VAR inputsem: !ts_pointer);
EXTERNAL;

PROCESS tap(
opsem: sempointer;
VAR tab_sem: !ts_pointer);
EXTERNAL;

PROCESS dtesimulator (
op_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;
op_sem : sempointer;
\f


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 osif (
op_sem : sempointer;
VAR inputsem : !ts_pointer;
VAR streemsem, lamsem : !sempointer;
port : byte);
EXTERNAL;

process dcmodule(
opsem : sempointer;
var sem1, sem2, sem3, sem4 : !sempointer;
var sem5, sem6, sem7, sem8 : !ts_pointer );
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;

\f


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
a(7+i):=params(par+i);
FOR i:= 10 TO 14 DO
a(i) := 0;
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 = "fesupervisor";
n2 = "streamer    ";
n3 = "osif        ";
n4 = "timout      ";
n5 = "lam         ";
n6 = "tap         ";
n7 = "netconnector";
n8 = "dtesimulator";
n9 = "tapdte      ";
n10= "tapnet      ";
n11= "dcmodule    ";
n12= "fpadriver   ";
BEGIN
CASE index OF
1: (* fesup *)
init_proc(index, n1, n1,
fesupervisor( opsem,
sem(fesup_sem_no), sem(fesup_write), sem(fesup_que),
sem(stream_sem_no).s, sem(netc_sem_no).s, sem(com_pool).w ),
fesup_size, fesup_pri );
2: (* streamer *)
init_proc(index, n2, n2,
streamer( sem(stream_sem_no), sem(stream_xmit),
sem(stream_rec), 3, opsem), stream_size, stream_pri);
3: (* osif *)
init_proc(index, n3, n3,
osif( opsem, sem(osif_sem_no), sem(stream_sem_no).s,
sem(lam_sem_no).s, 7),
osif_size, osif_pri);
4: (* timeout *)
init_proc(index, n4, n4,
timeout( opsem, sem(timeout_sem_no), time_out_unit, 40),
tim_size,tim_pri);
5: (* lam *)
init_proc(index, n5, n5,
lam( opsem, pu, 5, sem(lam_sem_no)),
lam_size, lam_pri);
6: (* tap *)
init_proc(index, n6, n6,
tap( opsem, sem(tap_sem_no)),
512, 0);
11: (* tap01 *)
init_proc(index, n6, "tap01       ",
tap ( opsem, sem(tap1_sem_no)),
512, 0);
7: (* netconnector *)
init_proc ( index, n7, n7,
\f


netconnector( glob_timeout, opsem,
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);

8: (* dtesimulator *)
init_proc ( index, n8, n8,
dtesimulator ( opsem, sem( pax_pool), sem(dte_sem_no),
sem( netc_sem_no).s,
sem( pax_sem_1).s, sem( pax_sem_2).s,
dte_pax_addr(3)),
netc_size, netc_pri);
9: (* tapdte *)
init_proc ( index, n9, n9,
tapdte ( opsem, sem(tap_dte_sem_no)),
512,0);
10: (* tapnet *)
init_proc ( index, n10, n10,
tapnet ( opsem, sem(tap_net_sem_no)),
512,0);

12: (* dc simulator *)
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 );
 
13: (* fpa rec *)
init_proc( index, n12, "fparec      ",
fpadriver( sem(stream_rec), 6, 2, true, opsem),
512, 0);
 
14: (* fpa xmit *)
init_proc( index, n12, "fpaxmit     ",
fpadriver( sem(stream_xmit), 7, 2, false, 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;
\f



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


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


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


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


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


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,own.incname,opsem);
testout(z,version,fe_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;

(*  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_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
\f


alloc (opoutref, opbufpool, wsem);
opoutref^.u1:=2; (* write *)
LOCK opoutref AS opbuf: opbuftype DO
WITH opbuf DO
BEGIN
first:= firstindex;
name:= opsysname;
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:= opsysname;
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);

\f


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: (* 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 := packextnode(3);
facility_l := l_facilities;
facility := params(6);
END;
END;
\f


END;
(* ie d 2  1  0 0 3  0 sends a call to 3 on stream 1 *)
(* ie d 2  2  0 0 4  0 sends a call to 4 on stream 2 *)

3: (* 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;
(* ie d  3  1  0 0 3  0 0 2  0  is 3 accepting call from 2 *)

4: (* send data to remote user *)
BEGIN
nref^.u1 := dte_sdata;
nref^.u3 := params(2);
LOCK nref AS buf : dte_sdata_data DO
WITH buf DO
BEGIN
q_bit := false;
m_bit := false;
control.op_code := dte_sdata;
END
END;
(* ie d  4  1      sends data on stream 1 *)



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

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

IF NOT nil( nref) THEN
BEGIN

nref^.u2 := 7;

CASE params(1) OF

1: (* update pax-table from local sup *)
BEGIN
nref^.u3 := tss_route;
nref^.u4 := #hac;

LOCK nref AS buf : RECORD
a:alarmlabel;
i : integer;
p:paxnet_e;
END DO
WITH buf DO
BEGIN
a.update := insert_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 := packextnode(11);
i := params(14);
p.stream_no := params(15);
END;
(*       receiver sender al-mac  pax indx stream       *)
(* ie n 1  0 0 0  1 0 0  1 2 2  0 0 2  1  0 sets netc address *)
(* ie n 1  1 2 2  1 0 0  1 2 2  0 0 2  2  1 sets tssup addr   *)
(* ie n 1  1 2 2  1 0 0  1 2 0  0 0 2  3  2 sets ncsup addr   *)
(* ie n 1  1 2 2  1 0 0  1 3 2  0 0 3  4  0 sets global ts-adr*)
(* ie n 1  1 2 2  1 0 0  1 3 0  0 0 3  5  0 sets global nc-adr*)
END;

\f


2 : (* update pax-table from net *)
BEGIN
nref^.u3 := params(15);
nref^.u4 := to_link;

LOCK nref AS buf : RECORD
x,y,z:integer;
b1,b2:boolean;
d:byte;
control: control_field_type;
a:alarmlabel;
i:integer;
p:paxnet_e;
END DO
WITH buf DO
BEGIN
a.update := insert_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 := packextnode(11);
i:=params(14);
p.stream_no := 0;
END;
END;
(*       receiver sender al-mac  pax  indx stream  *)
(* ie n 2  1 2 2  1 0 0  1 4 2  0 0 4  6  1   sets global ts-addr *)
(* ie n 2  1 2 2  1 0 0  1 4 0  0 0 4  7  1   sets global nc-addr *)
(* ie n 2  1 2 2  1 0 0  1 5 2  0 0 5  8  1   sets global ts-addr *)
(* ie n 2  1 2 2  1 0 0  1 5 0  0 0 5  9  1   sets global nc-addr *)

\f


3:  (* send alarmmessage *)
BEGIN
nref^.u3 := tss_route;
nref^.u4 := #h30;

LOCK nref AS abuf : alarmlabel DO
abuf.rec.macro := packmacro(2);

(*        receiver *)
(* ie n 3  1 2 2   gives an alarm to tssup itself  *)
(* ie n 3  1 2 0   gives an alarm to ncsup local   *)
(* ie n 3  1 3 2   gives an alarm to tssup global  *)
(* ie n 3  1 3 0   gives an alarm to ncsup global  *)
END;


OTHERWISE
outstring10("undef test");
END;
signal( nref, sem( netc_sem_no).s^);
END
ELSE
outstring10("no paxbufs");
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
\f


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


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◀