DataMuseum.dk

top - metrics - download

    Length: 33024 (0x8100)
    Types: TextFile
    Names: »pxposjob«

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

TextFile

job oer 5 200 time 11 0 size 100000 area 10,
temp disc 15000 15
(source=copy 25.1
pxposlst= set 1 disc1
pxposerr=set 1 disc1
scope user pxposlst
pxposlst= indent source mark lc
listc= cross pxposlst
o pxposerr
head 1
message pxpos program
pascal80 spacing.3000 list.no codesize.3000 xtenv, 
evaenv xncpenv xpoolenv xrouenv routenv testenv source
o c
lookup pass6code
if ok.yes
(pxposbin = set 1 disc1
pxposbin=move pass6code
scope user pxposbin
)
pxposlst=copy listc pxposerr
scope user pxposerr
finis output.no
)
process pax_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.05 /";


\f


const

ts_sem_total = 40;

size_listen=50;  (**************************************   chh   *********************************)
opbufsize = 80; (* no. of bytes in buffers to the operator module *)
messbufsize= size_listen; (*words*)
testbufsize= size_listen*4;
noofmodules= 20;
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 ";
illegalparam='illegal parameters  ';
proc7ncr='proc 7 not created  ';
 
firstindex= 6 + alfalength;
lastindex= firstindex + (80 - 1);
ok= 0; (* result from operator *)
nooftaps=3;   (********************** jli *********************)
noofph=4;    (********* jli **********)
\f

 
 
type
pb_type=array(1..noofph) of ph_type;  (*** jli ***)
tap_state_tp=(stopped,started);
tap_state_type=array(1..nooftaps) of tap_state_tp;  (********* jli *******)
opbuftype=
record
first,
last,
next: integer;
name: alfa;
data: array (firstindex..lastindex) of char
end;

messbuftype= array (1..messbufsize) of integer;
testbuftype= array (1..testbufsize) of integer;
 
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;

\f

 
var
pb:pb_type;   (***** jli *****)
(*********  pools  *********)
consprotpool: pool 1;    (********** jli *****)
opbufpool: pool 3 of opbuftype;
testbufpool: pool 20 of testbuftype;
messbufpool: pool 20 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;
consoleprot: semaphore;  (* ****** jli *****)
tap_sem     (* snooper semaphore ************* jli **************)
: array(1..nooftaps) of semaphore;
ts_sem : array (1..ts_sem_total) of semaphore;
tap_semp: array(1..nooftaps) of tap_pointer; (* snooper pointer semaphore ************ jli ************)

(**********  references  **********)
chhref,     (*************************************    chh    ***********************)
chhstack,   (*************************************    chh    ***********************)
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 : array(1..ts_sem_total) of tap_pointer;     (******    chh     **************)

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

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

\f


(**********  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 *)
st              (* storage requirements *)
: integer;

tap_index: array(1..nooftaps) of integer; (** jli ******)
simsignal: array(1..2) of 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. *)

 
(*** auxiliary to compare sempointers ***)
ap,bp : point_rec;

(*** router definitions ************** jli *************)
ltrm:  ltsmarray;
lrec:  ltsmarray;
ldrv:  ltsmarray;
ldrv2:  ltsmarray;

(* tap definitions **************** jli ************)
tap_state: tap_state_type:=tap_state_type(nooftaps***stopped);
\f


(*------- consts and vars from noah ------*)

const

nwu_del1=125;
nwu_del2=4;

nwb_del1=120;
nwb_del2=11;

var
ownadr: nwadr;

r_lcp_id: integer:= 200;
r_transit_ph: integer:= 10;
r_nnp_ph: integer:= 20;

conn_desc: conn_desc_array;

sh_routsupv: shadow;
sh_poolh: shadow;
sh_poolnnp: shadow;

node_no : byte;
max_hlcon_no : byte;
\f


(**********  externals **********)
process ncp(
var sys_vector: system_vector;
var ncp_sem: ! tap_pointer;
var sc_sem: ! tap_pointer;
var timeout_sem: ! tap_pointer;
ncp_ident: ! integer);
external;

process timeout(procname: alfa;
opsem: ^semaphore;
var main_sem: semaphore;
ticklength,
max: integer;
hh: integer;
mm: integer;
ss: integer);
external;

process pool_handler( var sysvec: system_vector;
var poolh_sem: semaphore;
var ncp_sem : semaphore;
lcp_ident: integer;
var ph: ph_type);
external;

process supervisor( var sysvec: system_vector;
var ncp: ! tap_pointer;
lcp_ident: integer;
var ltrm: ! ltsmarray;
var lrec: ! ltsmarray;
var ldrv: ! ltsmarray;
var ldrv2:! ltsmarray;
var conn_desc: conn_desc_array;
var supv: ! tap_pointer;
var poolh,poolnnp: ! tap_pointer;
udelay1,udelay2,bdelay1,bdelay2: byte;
var ownaddr: nwadr);
external;



process pxtap(opsem: sempointer; 
var sem: ! tap_pointer;
var consoleprot: semaphore);
external;

process ncth(var sys_vector:system_vector;
var consoleprot:semaphore;
var ncth_sem:semaphore;
pu,formatter_prio,comint_prio:integer);
external;


procedure readram( var result: byte; index: integer);
external;


























  
\f

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

procedure init_rout_semp;
begin
ltrm(1):=sem(11);  (* urec1 *)
lrec(1):=sem(12);  (* utrm1 *)
ltrm(2):=sem(15);
lrec(2):=sem(16);
ldrv(2):=sem(17);  (* hdlc1 driver sem *)
ldrv2(2):=sem(26);
ltrm(3) := sem(19);
lrec(3) := sem(20);
ldrv(3) := sem(21);
ldrv2(3):= sem(26);
ltrm(4) := sem(23);
lrec(4) := sem(24);
ldrv(4) := sem(25);
ldrv2(4):= sem(26);
end;

procedure start_tap(i,incno:integer);
begin
if (i=0) or (i>ts_sem_total) or (noofparams<2) then
outstring20('illegal parameter   ') else
begin
if tap_state(incno)=started then
outstring20('already started     ') else
begin
sem(i).s:=ref(tap_sem(incno));
tap_semp(incno).s:=sem(i).w;
tap_index(incno):=i;
tap_state(incno):=started;
init_rout_semp;
end;
end;
end;

procedure stop_tap(incno:integer);
begin
if tap_state(incno)=started then
begin
sem(tap_index(incno)).s:=ref(ts_sem(tap_index(incno)));
tap_state(incno):=stopped;
init_rout_semp;
end;
end;

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 (."e","f","p".) then
begin (* change to old *)
base:= oldbase;
newbase:= false;
end;
 
until (not readok) or (noofparams= 50);

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


procedure init_proc(
index: integer;
name : alfa;
p    : processrec;
size,
prio : integer);
var
ok   : integer;
begin
if not nil(sh(index)) then
outstring20(alreadyexists) else
begin
if noofparams<2 then st:= size;
ok:= link(name,p.processref^);
ok:= create(name,p,sh(index),size);
if ok=0 then
start(sh(index),prio) else
begin
outstring20(createerror);
outdecimal(ok,4);
outstring10("  process ");
outstring12(name);
writenl;
ok:= unlink(p.processref^);
end;
end;
end;

procedure crtap(index:integer;i:integer; n:alfa);
begin
tap_semp(i).w:=ref(tap_sem(i));
start_tap(params(2),i);
init_proc(index,n,
pxtap(semvector(operatorsem),tap_semp(i),consoleprot),
500,stdpriority);
end;


procedure init_modul(index: integer);
const
n1 = "ncp         ";
n2 = "timeout     ";
n6 = "ncth        ";
n7 = "pxtap       ";
n11= 'pxtap2      ';
n12= 'pxtap3      ';
begin
case index of

 1:  (* ncp *)
init_proc(index, n1 ,
ncp( semvector, sem(1), sem(2), sem(3), 576),
900, stdpriority);

 2:  (* timeout *)
begin
if noofparams<>4 then
begin
params(2):= 0;
params(3):= 0;
params(4):= 0;
end;
init_proc(index,n2,
timeout(n2, opsem, sem(3).s^, 900, 0, params(2), params(3), params(4)),
600, stdpriority);
end;

4 : (* supervisor *)
begin

case node_no of
4,5,6 : max_hlcon_no := 2;
2 : max_hlcon_no := 4;
otherwise max_hlcon_no := 3;
end;

conn_desc(1).ctyp := typ_locon;
conn_desc(1).cparams(1) := node_no;
conn_desc(1).cparams(2) := 8;
conn_desc(1).cparams(3) := 8;
conn_desc(1).cparams(4) := 0;
conn_desc(1).cparams(5) := 0;

for i := 2 to max_hlcon_no do
begin
conn_desc(i).ctyp := typ_hlcon;
conn_desc(i).cparams(1) := i-2;
conn_desc(i).cparams(2) := 2;
conn_desc(i).cparams(3) := 1;
conn_desc(i).cparams(4) := 0;
conn_desc(i).cparams(5) := 50;
conn_desc(i).cparams(6) := 5;
end;

for i := max_hlcon_no+1 to cmax do
conn_desc(i).ctyp := none;

i:=link('supervisor  ',supervisor);
if i <> 0 then
testout(z,"sup lnk nok ",i)
else
i:=create('supv        ',
supervisor( semvector, sem(1),r_lcp_id, ltrm,lrec,ldrv,ldrv2,conn_desc,
sem(10),sem(4),sem(5),nwu_del1,nwu_del2,nwb_del1,nwb_del2,ownadr),
sh_routsupv, 700);
if i <> 0 then
testout(z,"sup crt nok ", i)
else
start(sh_routsupv,stdpriority);

i:= link('pool_handler',pool_handler);
if i <> 0 then
testout(z,"trp lnk nok ", i)
else
i:=create('transit-pool',
pool_handler( semvector,sem(4).w^,sem(1).s^,r_transit_ph, pb(1)),
sh_poolh, 300);
if i <> 0 then
testout(z,"trp crt nok ",i)
else
start(sh_poolh, stdpriority);

i:= create('nnp pool    ',
pool_handler( semvector, sem(5).w^,sem(1).s^,r_nnp_ph,pb(2)),
sh_poolnnp, 300);
if i <> 0 then
testout(z,"nnp crt nok ", i)
else
start( sh_poolnnp, stdpriority);

end;

 6: (* ncth *)
init_proc(index,n6,
ncth(semvector,consoleprot,sem(2).w^,0,stdpriority,stdpriority),
500,stdpriority);


 7: (* tap1 *)
crtap(index,1,n7);



11: (*  tap2  *)
if nil(sh(7)) then outstring20(proc7ncr) else
crtap(index,2,n11);

12: (* tap3 *)
if nil(sh(7)) then outstring20(proc7ncr) else
crtap(index,3,n12);





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

readram( node_no, 10);
node_no := node_no mod 16;
ownadr(1) := node_no;

testout(z,"int-pax-node", node_no);
 
(* 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(11).s:= ref(evavector(px_urec1));
sem(11).w:= sem(11).s;
sem(12).s:= ref(evavector(px_utrm1));
sem(12).w:= sem(12).s;
sem(1).s:= ref(evavector(px_ncp));
sem(1).w:= sem(1).s;
sem(26).s := ref(evavector(al_lam1));
sem(26).w := sem(26).s;

init_rout_semp;

(* initialise buffers *)
alloc(opoutref,consprotpool,wsem);  (****** jli ****)
signal(opoutref,consoleprot);       (****** jli ******)
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:= "pax         ";
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:= "pax         ";
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;

 
(* 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;
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 <= messbufsize then
begin
lock cur as messbuf: messbuftype do
messbuf(i):= params(j);
i:= i + 1;
end;

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


"h": (* help *)
(* lispxpossible 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("g: start tap  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("q: stop tap   1     "); 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("^: push       0     "); writenl;
outstring20("-: pop        0     "); writenl;
outstring20(";: comment          ");
end;
\f


"i": (* initialise pointers *)
begin
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);
init_rout_semp;
end;
\f


"k": (* kill *)
(* removes incarnation of tested module(s) 
params are nos. of modules to be removed *)

if noofparams >= 1 then
for i:= 1 to noofparams do
begin
moduleno:= params(i);
if (1<=moduleno) and (moduleno<=noofmodules) then
if not nil(sh(moduleno)) then
remove (sh(moduleno))
else
begin
outdecimal (moduleno, 4);
outstring10(" not alive");
writenl;
end
else
begin
outdecimal (moduleno, 4);
outstring10(illegalno);
writenl;
end
end
else outstring10("no params ");
\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)<= messbufsize) then
firstword:= params(1);
 
if (noofparams>=2) and (params(2)<=messbufsize) then
lastword:= params(2);
if lastword>messbufsize
then lastword:= messbufsize;
 
if cur^.size<messbufsize then
outstring20("too small buffer    ") else
for i:= firstword to lastword do
begin
outdecimal(i,3);
outchar(":");
lock cur as messbuf: messbuftype do
if base= 2 then
outinteger(messbuf(i),17)
else
outinteger(messbuf(i),7);
writenl;
end;
end (* ok *);
end (* output *);
\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  ")
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;
init_rout_semp;
end
else outstring10(valparam)
else outstring10(valparam)
else outstring10(noparam)
end (* exchange pointer *);

"g": (* start tap
1st parameter is tap incno
2nd parameter is sem. no. to tap  *)
if (params(1)<1) or (params(1)>3) then outstring20(illegalparam) else
start_tap(params(2),params(1));

"q": (* stop tap *)
(* 1st parameter is tap incno *)
if (params(1)<1) or (params(1)>3) then outstring20(illegalparam) else
stop_tap(params(1));


"^": (* pop *)
(* pops from current buffer and saves the popped message in chhstack *)
if not nil(cur) then
begin
pop(chhref, cur);
push(chhref, chhstack);
end
else
outstring10("no buffer ");

"_": (* push *)
(* pushes the first message in chhstack onto current buffer *)
if not nil(chhstack) then
begin
pop(chhref, chhstack);
push(chhref, cur);
end
else
outstring10("not popped");



otherwise (* error *)
outstring20 ("illegal comm. type h");
end (* case *);

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



▶EOF◀