proc;

mc:
proc;

/*
Direct MP/M Call Test Program (Cont'd)
--------------------------------------

Refer to the comment at the beginning of the
MPMCALLS PLI program.
*/

/* 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
sysin file,
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);
*/

pdadr = rpdadr(); /* get current running pd adr */
oldpriority = pd.priority;

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

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

clresptest:
proc (stringadr) returns (ptr);
dcl
stringadr ptr,
string based (stringadr) char(27);

put edit ('->STRING proc passed: ',string)
(skip,a,a(27));
return (addr (lower));
end clresptest;

/**********************************
* *
* Delay Test: *
* *
**********************************/

put skip(2) list ('Delay Test:');
put skip list ('->a dot will be printed each second');
put list ('for ten seconds ');
do i = 1 to 10;
call delay (60);
put edit ('.') (a);
end;

/**********************************
* *
* Disptach Test: *
* *
**********************************/

put skip(2) list ('Dispatch Test:');
call dsptch();
put skip list ('->dispatch successful.');

/**********************************
* *
* Console Tests: *
* ATTCON, DETCON already tested *
* SETCON not tested *
* ASNCON tested in send CLI cmd *
* GETCON *
* *
**********************************/

put skip(2) list ('Console Test:');
put edit ('->current console is #',getcon())
(skip,a,f(2));

/**********************************
* *
* Send CLI Command Test: *
* This example shows how to run *
* a program in another memory *
* segment and then get the con- *
* sole back to the main program.*
* E.G. as in a menu driven *
* application. *
* *
**********************************/
dcl
1 clicmd,
2 dslct bit(8), /* default disk / user code */
2 console fixed(7), /* console number */
2 line char(128);
dcl
1 apb static,
2 console fixed(7),
2 name char(8) initial ('cli '),
2 match bit(8) initial ('00'b4);

put skip(2) list ('Send CLI Command Test:');
on endfile (sysin)
go to clresptst;
pdadr = rpdadr(); /* get current running pd adr */
oldpriority = pd.priority;
clicmd.dslct = pd.slct;
clicmd.console = pd.console;
apb.console = pd.console;
do while (true);
put skip list (' Enter CLI Command: ');
get edit (clicmd.line) (a);
if ~asncon (addr (apb)) then
do;
put skip list ('*** Failed to assign Cli the console ***');
end;
else
do;
call setpri (197);
call sclicd (addr (clicmd));
call attcon();
call setpri (oldpriority);
end;
end;

/**********************************
* *
* Call Resident System Proc Test: *
* *
**********************************/
dcl
1 cpb,
2 nameadr ptr,
2 paramadr ptr;
dcl
aparam ptr;
dcl
procname char(8) static initial ('STRING ');
dcl
1 stringqcb static,
2 link fixed(15),
2 name char(8) initial ('STRING '),
2 msglen fixed(15) initial (2),
2 nmbmsgs fixed(15) initial (1),
2 dqph ptr,
2 nqph ptr,
2 msgin ptr,
2 msgout ptr,
2 msgcnt fixed(15),
2 buffer ptr;
dcl
1 stringuqcb,
2 pointer ptr,
2 msgadr ptr;
dcl
stringprocadr entry (fixed) variable returns(ptr);
dcl
rtnstringadr ptr,
rtnstring based (rtnstringadr) char(27);

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

put skip(2) list ('Call Resident System Process Test:');
call makque (addr (stringqcb));
stringuqcb.pointer = addr (stringqcb);
stringuqcb.msgadr = addr (stringprocadr);
stringprocadr = clresptest;
call wrque (addr (stringuqcb));
cpb.nameadr = addr (procname);
cpb.paramadr = addr (aparam);
aparam = addr (upper);

unspec (rtnstringadr) = clresp (addr (cpb));

put edit ('->STRING proc returned:',rtnstring)
(skip,a,a(27));

if ~delque (addr (stringqcb)) then
do;
put skip list ('*** Unable to delete stringqcb ***');
call term ('0000'b4);
end;
put skip list ('->Call clresp test complete.');

/**********************************
* *
* Parse Filename Test: *
* *
**********************************/
dcl
done bit(1);
dcl
line char(80);
dcl
1 pfcb,
2 flname ptr,
2 fcb ptr;
dcl
delimptr ptr,
delim based (delimptr) char(1);
dcl
oldptr ptr,
old based (oldptr) char(10);
dcl
1 afcb,
2 name,
3 drive fixed(7),
3 fname char(8),
3 ftype char(3);

put skip(2) list ('Parse Filename Test:');
on endfile (sysin)
go to gettodtest;
put skip list (' Enter string of filenames to be parsed,');
put list ('separated by commas:');
do while (true);
put skip list ('->');
get edit (line) (a);
line = substr (line,1,index (line,' ')-1) || ascii (13);
pfcb.flname = addr (line);
pfcb.fcb = addr (afcb);
oldptr = addr (line);
done = false;
pfcb.flname = parse (addr (pfcb));
do while (~done & (unspec (pfcb.flname) ~= 'ffff'b4));
oldptr = pfcb.flname;
put edit (' ',ascii (afcb.drive+64),': ',
afcb.fname,' ',afcb.ftype)
(skip,a,a,a,a(8),a,a(3));
if unspec (pfcb.flname) = '0000'b4 then
do;
done = true;
end;
else
do;
delimptr = pfcb.flname;
if delim = ',' then
do;
unspec (i) = unspec (pfcb.flname);
i = i + 1;
unspec (pfcb.flname) = unspec (i);
end;
pfcb.flname = parse (addr (pfcb));
end;
end;
if ~done then
do;
put skip list (' *** Bad Entry *** ->');
put edit (old) (a(10));
end;
end;

/**********************************
* *
* Time and Date Test: *
* *
**********************************/
dcl
1 tod,
2 date fixed(15),
2 time,
3 hour bit(8),
3 min bit(8),
3 sec bit(8);

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

put skip(2) list ('Time and Date Test:');
call gettod (addr (tod));
put edit ('-> ',tod.date,' ',tod.hour,':',tod.min,':',tod.sec)
(skip,a,f(5),a,b4(2),a,b4(2),a,b4(2));

end mc;