mpmtst:

mpmtst:
proc options(main);

dcl
mc entry;

/*
Direct MP/M Call Test Program
-----------------------------

The purpose of the MPMCALLS and MPMCALLC PLI programs
is to demonstrate direct MP/M calls from PLI. The following
instructions outline the steps to assemble, compile, link
and execute this test program.

1.) Compile the PLI programs as follows:
>pli mpmcalls $pl
>pli mpmcallc $pl

2.) Assemble the mpmdio.asm module:
>rmac mpmdio

3.) Link the mpmcalls and mpmdio modules:
>link mpmcalls,mpmcallc,mpmdio

4.) Gensys your MP/M system as follows:
Top .... = ff
Number of con.. = 1
Add system call ... ? n
Bank switched mem... ? n
:0
:a0
:ff

5.) Execute the mpmcalls program:
0A>mpmcalls

*/

/* external MP/M I/O entry points */
/* (note: each source line begins with tab chars) */

%replace
true by '1'b,
false by '0'b;

%include 'mpmdio.dcl';

dcl
vers entry returns (bit(16));

dcl
sysin file,
version bit(16),
oldpriority fixed(7),
v char(254) var,
i fixed;

dcl
pdadr ptr,
1 pd based (pdadr),
2 link ptr,
2 status fixed(7),
2 priority fixed(7),
2 stkptr ptr,
2 name char(8),
2 console fixed(7),
2 memseg fixed(7),
2 b fixed(15),
2 thread ptr,
2 dmadr ptr,
2 slct bit(8);
/* 2 dcnt fixed(15),
2 searchl fixed(7),
2 searcha ptr,
2 drvact bit(16),
2 registers (20) fixed(7),
2 scratch fixed(15);
*/

dcl
1 localpd static,
2 link ptr,
2 status fixed(7),
2 priority fixed(7),
2 stkptr ptr,
2 name char(8) initial ('LocalPD '),
2 console fixed(7),
2 memseg fixed(7),
2 b fixed(15),
2 thread ptr,
2 dmadr ptr,
2 slct fixed(7),
2 dcnt fixed(15),
2 searchl fixed(7),
2 searcha ptr,
2 drvact bit(16),
2 registers (20) fixed(7),
2 scratch fixed(15);

dcl
localstk (0:255) entry (fixed) variable;

dcl
sysdatpgadr ptr,
1 sysdatpg based (sysdatpgadr),
2 memtop bit(8),
2 nmbcns fixed(7),
2 brkptrst fixed (7),
2 syscallstks bit(8),
2 bankswitched bit(8);
/* 2 z80cpu bit(8),
2 bankedbdos bit(8),
2 basebankedbdos ptr;
*/

dcl
upper char(27) static initial
('ABCDEFGHIJKLMNOPQRSTUVWXYZ '),
lower char(27) static initial
('abcdefghijklmnopqrstuvwxyz ');

/**********************************
* *
* Local procedures used during *
* testing. *
* *
**********************************/

flagtest:
proc;
dcl
boolean bit(1);

call attcon();
boolean = flgwt (30);
put skip list ('-> flagtest wait on #30 complete.');
call detcon();
boolean = flgset (31);
call term ('ffff'b4);
end flagtest;

queuetest:
proc;
dcl
1 qcbB static,
2 link fixed(15),
2 name char(8) initial ('QueueB '),
2 msglen fixed(15) initial (10),
2 nmbmsgs fixed(15) initial (2),
2 dqph ptr,
2 nqph ptr,
2 msgin ptr,
2 msgout ptr,
2 msgcnt fixed(15),
2 buffer (2),
3 lnk ptr,
3 char(10);
dcl
1 uqcbA static,
2 pointer ptr,
2 msgadr ptr,
2 name char(8) initial ('QueueA ');
dcl
1 uqcbB,
2 pointer ptr,
2 msgadr ptr;
dcl
msgA char(10),
msgB char(10);

uqcbA.msgadr = addr (msgA);
uqcbB.pointer = addr (qcbB);
uqcbB.msgadr = addr (msgB);
call makque (addr (qcbB));
do while (~opnque (addr (uqcbA)));
call delay (1); /* until qcbA created */
end;
do while (true);
call rdque (addr (uqcbA));
msgB = translate (msgA,upper,lower);
call wrque (addr (uqcbB));
end;
end queuetest;

/**************************************************
***************************************************
******** ********
******** M a i n P r o g r a m ********
******** ********
***************************************************
**************************************************/

/**********************************
* *
* Verify Operation Under MP/M *
* Without Banked Memory. *
* *
**********************************/

version = vers();
if substr (version,1,8) = '00'b4 then
do;
put skip list ('Tests cannot run under CP/M.');
call term('0000'b4);
end;
sysdatpgadr = sysdat ();
if sysdatpg.bankswitched = 'FF'b4 then
do;
put skip list ('Tests cannot run under MP/M');
put list ('with bank switched memory.');
call term('0000'b4);
end;
if sysdatpg.syscallstks = 'FF'b4 then
do;
put skip list ('Tests cannot run under MP/M');
put list ('with system call user stacks.');
call term('0000'b4);
end;
pdadr = rpdadr(); /* get current running pd adr */
oldpriority = pd.priority;

/**********************************
* *
* Memory Management Tests: *
* AMEMRQ, RMEMRQ, MEMFR *
* *
**********************************/
dcl
1 memdscr,
2 base fixed (7), /* base page */
2 size fixed (7), /* # of pages */
2 attrib fixed (7), /* attributes */
2 bank fixed (7); /* bank byte */

on endfile (sysin)
go to rmemrqtst;
put skip list ('Memory Management Tests:');
do while (true);
put skip(2) list (' Absolute Request');
put skip list (' Base (xx in hex) = ');
i = pd.memseg; /* save old memseg index */
get edit (unspec (memdscr.base)) (b4(2));
if amemrq (addr (memdscr)) then
do;
put skip list (' Absolute Request satisfied.');
put edit (' Base = ',unspec (memdscr.base),'H')
(skip,a,b4,a);
put edit (' Size = ',unspec (memdscr.size),'H')
(skip,a,b4,a);
put edit (' Attr = ',unspec (memdscr.attrib),'H')
(skip,a,b4,a);
put edit (' Bank = ',unspec (memdscr.bank),'H')
(skip,a,b4,a);
call memfr (addr (memdscr));
pd.memseg = i; /* restore former memseg index */
end;
else
do;
put skip list (' Absolute Request failed.');
end;
end;

rmemrqtst:
get edit (v) (a); /* clear input buffer */

on endfile (sysin)
go to polltst;
do while (true);
put skip(2) list (' Relocatable Request');
put skip list (' Size (xxh) = ');
i = pd.memseg; /* save old memseg index */
get edit (unspec (memdscr.size)) (b4(2));
if rmemrq (addr (memdscr)) then
do;
put skip list (' Relocatable Request satisfied.');
put edit (' Base = ',unspec (memdscr.base),'H')
(skip,a,b4,a);
put edit (' Size = ',unspec (memdscr.size),'H')
(skip,a,b4,a);
put edit (' Attr = ',unspec (memdscr.attrib),'H')
(skip,a,b4,a);
put edit (' Bank = ',unspec (memdscr.bank),'H')
(skip,a,b4,a);
call memfr (addr (memdscr));
pd.memseg = i; /* restore former memseg index */
end;
else
do;
put skip list (' Relocatable Request failed.');
end;
end;

/**********************************
* *
* Poll Tests: *
* The poll call cannot be tested *
* unless the poll device table *
* in the XIOS is known. *
* *
**********************************/

polltst:
get edit (v) (a); /* clear input buffer */

/* The following code is "commented out"

call poll (devicenumber);
put edit ('Device ',devicenumber,'is ready.')
(skip,a,f,a);

End of "commented out" code */

put skip(2) list ('Poll call not tested.');

/**********************************
* *
* Flag Tests: *
* FLGWT, FLGSET *
* *
* Note: this test assumes that *
* flags 30 & 31 are unused. *
* *
**********************************/
dcl
flagover bit(1),
flagunder bit(1);

unspec (localpd.link) = '0000'b4;
localpd.priority = 100;
localpd.stkptr = addr (localstk(255));
localpd.console = pd.console;
localpd.memseg = pd.memseg;
localstk(255) = flagtest;
call crproc (addr (localpd));
put skip(2) list ('Flag Tests:');
call setpri (101);
call detcon();
flagover = ~flgset (30);
call attcon();
call setpri (oldpriority);
flagunder = ~flgwt (31);
if flagover then
put skip list ('-> flag over-run.');
if flagunder then
put skip list ('-> flag under-run.');
put skip list ('-> flag tests successful.');

/**********************************
* *
* Queue Management Tests: *
* MAKQUE,OPNQUE,DELQUE *
* RDQUE,CRDQUE,WRQUE,CWRQUE *
* *
**********************************/
dcl
1 qcbA static,
2 link fixed(15),
2 name char(8) initial ('QueueA '),
2 msglen fixed(15) initial (10),
2 nmbmsgs fixed(15) initial (2),
2 dqph ptr,
2 nqph ptr,
2 msgin ptr,
2 msgout ptr,
2 msgcnt fixed(15),
2 buffer (2),
3 lnk ptr,
3 char(10);
dcl
1 uqcbA,
2 pointer ptr,
2 msgadr ptr;
dcl
1 uqcbB static,
2 pointer ptr,
2 msgadr ptr,
2 name char(8) initial ('QueueB ');
dcl
msgA char(10),
msgB char(10);

put skip(2) list ('Queue Tests:');
on endfile (sysin)
go to abtsprtest;
uqcbA.pointer = addr (qcbA);
uqcbA.msgadr = addr (msgA);
uqcbB.msgadr = addr (msgB);
call makque (addr (qcbA));

put skip(2) list (' Testing Conditional Write Queue');
do i = 1 to 10 while (cwrque (addr (uqcbA)));
put edit (' Message #',i)
(skip,a,f(2));
end;
put skip list (' Queue is full.');

put skip(2) list (' Testing Conditional Read Queue');
do i = 1 to 10 while (crdque (addr (uqcbA)));
put edit (' Message #',i)
(skip,a,f(2));
end;
put skip list (' Queue is empty.');

unspec (localpd.link) = '0000'b4;
localpd.priority = 100;
localpd.stkptr = addr (localstk(255));
localpd.console = pd.console;
localpd.memseg = pd.memseg;
localstk(255) = queuetest;
call crproc (addr (localpd));

do while (~opnque (addr (uqcbB)));
call delay (1); /* until qcbB created */
end;
put skip list (' Enter char(10) message:');
do while (true);
put skip list ('->');
get edit (msgA) (a);
call wrque (addr (uqcbA));
call rdque (addr (uqcbB));
put edit ('<-',msgB)
(skip,a,a(10));
end;

/**********************************
* *
* Abort Specified Process Test: *
* *
**********************************/
dcl
1 abtpb static,
2 pda bit(16) initial ('0000'b4),
2 termcode bit(16) initial ('ffff'b4),
2 name char(8) initial ('LocalPD '),
2 console fixed(7);

abtsprtest:
get edit (v) (a); /* clear input buffer */

put skip(2) list ('Abort Specified Process Test:');
put skip list (' Aborting LocalPD.');
abtpb.console = pd.console;
if abtspr (addr (abtpb)) then
do;
put skip list ('->Abort successful');
end;
else
do;
put skip list ('->Abort Failed');
go to error;
end;
if ~delque (addr (qcbA)) then
do;
put skip list ('*** Unable to delete QueueA ***');
call term('0000'b4);
end;
if ~delque (uqcbB.pointer) then
do;
put skip list ('*** Unable to delete QueueB ***');
call term('0000'b4);
end;

/**********************************
***********************************
**** ****
**** Call pli procedure ****
**** "mc" for other tests ****
**** ****
***********************************
**********************************/

call mc();

/**********************************
* *
* Termination Test: *
* *
**********************************/

put skip(2) list ('Termination Test:');
call term ('0000'b4);

/**********************************
* *
* Unrecoverable Error: *
* *
**********************************/

error:

put skip list ('*** Unrecoverable Error ***');
call disabl();
do while (true);
end;

end mpmtst;