home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol079 / mpmcallc.pli < prev    next >
Text File  |  1984-04-29  |  8KB  |  313 lines
  1. mc:
  2.     proc;
  3.  
  4.     /*
  5.         Direct MP/M Call Test Program (Cont'd)
  6.         --------------------------------------
  7.  
  8.         Refer to the comment at the beginning of the
  9.     MPMCALLS PLI program.
  10. */
  11.  
  12.     /* external MP/M I/O entry points */
  13.     /* (note: each source line begins with tab chars) */
  14.  
  15.     %replace
  16.     true   by '1'b,
  17.     false  by '0'b;
  18.  
  19. %include 'mpmdio.dcl';
  20.  
  21.     dcl
  22.         sysin file,
  23.         oldpriority fixed(7),
  24.         v char(254) var,
  25.         i fixed;
  26.  
  27.     dcl
  28.         pdadr ptr,
  29.         1 pd based (pdadr),
  30.           2 link ptr,
  31.           2 status fixed(7),
  32.           2 priority fixed(7),
  33.           2 stkptr ptr,
  34.           2 name char(8),
  35.           2 console fixed(7),
  36.           2 memseg fixed(7),
  37.           2 b fixed(15),
  38.           2 thread ptr,
  39.           2 dmadr ptr,
  40.           2 slct bit(8);
  41.     /*      2 dcnt fixed(15),
  42.           2 searchl fixed(7),
  43.           2 searcha ptr,
  44.           2 drvact bit(16),
  45.           2 registers (20) fixed(7),
  46.           2 scratch fixed(15);
  47.     */
  48.  
  49.     pdadr = rpdadr();   /* get current running pd adr */
  50.     oldpriority = pd.priority;
  51.  
  52.     dcl
  53.         upper char(27) static initial
  54.             ('ABCDEFGHIJKLMNOPQRSTUVWXYZ '),
  55.         lower char(27) static initial
  56.             ('abcdefghijklmnopqrstuvwxyz ');
  57.  
  58.  
  59.     /**********************************
  60.     *                                 *
  61.     * Local procedures used during    *
  62.     *  testing.                       *
  63.     *                                 *
  64.     **********************************/
  65.  
  66.     clresptest:
  67.         proc (stringadr) returns (ptr);
  68.         dcl
  69.             stringadr ptr,
  70.             string based (stringadr) char(27);
  71.  
  72.         put edit ('->STRING proc passed: ',string)
  73.                          (skip,a,a(27));
  74.         return (addr (lower));
  75.         end clresptest;
  76.  
  77.  
  78.     /**********************************
  79.     *                                 *
  80.     * Delay Test:                     *
  81.     *                                 *
  82.     **********************************/
  83.  
  84.     put skip(2) list ('Delay Test:');
  85.     put skip list ('->a dot will be printed each second');
  86.     put list ('for ten seconds ');
  87.     do i = 1 to 10;
  88.         call delay (60);
  89.         put edit ('.') (a);
  90.     end;
  91.  
  92.     /**********************************
  93.     *                                 *
  94.     * Disptach Test:                  *
  95.     *                                 *
  96.     **********************************/
  97.  
  98.     put skip(2) list ('Dispatch Test:');
  99.     call dsptch();
  100.     put skip list ('->dispatch successful.');
  101.  
  102.     /**********************************
  103.     *                                 *
  104.     * Console Tests:                  *
  105.     *   ATTCON, DETCON already tested *
  106.     *   SETCON not tested             *
  107.     *   ASNCON tested in send CLI cmd *
  108.     *   GETCON                        *
  109.     *                                 *
  110.     **********************************/
  111.  
  112.     put skip(2) list ('Console Test:');
  113.     put edit ('->current console is #',getcon())
  114.              (skip,a,f(2));
  115.  
  116.     /**********************************
  117.     *                                 *
  118.     * Send CLI Command Test:          *
  119.     *   This example shows how to run *
  120.     *   a program in another memory   *
  121.     *   segment and then get the con- *
  122.     *   sole back to the main program.*
  123.     *   E.G. as in a menu driven      *
  124.     *   application.                  *
  125.     *                                 *
  126.     **********************************/
  127.     dcl
  128.         1 clicmd,
  129.           2 dslct bit(8),  /* default disk / user code */
  130.           2 console fixed(7),  /* console number */
  131.           2 line char(128);
  132.     dcl
  133.         1 apb static,
  134.           2 console fixed(7),
  135.           2 name char(8) initial ('cli     '),
  136.           2 match bit(8) initial ('00'b4);
  137.  
  138.     put skip(2) list ('Send CLI Command Test:');
  139.     on endfile (sysin)
  140.         go to clresptst;
  141.     pdadr = rpdadr();   /* get current running pd adr */
  142.     oldpriority = pd.priority;
  143.     clicmd.dslct = pd.slct;
  144.     clicmd.console = pd.console;
  145.     apb.console = pd.console;
  146.     do while (true);
  147.         put skip list ('  Enter CLI Command: ');
  148.         get edit (clicmd.line) (a);
  149.         if ~asncon (addr (apb)) then
  150.         do;
  151.             put skip list ('*** Failed to assign Cli the console ***');
  152.         end;
  153.         else
  154.         do;
  155.             call setpri (197);
  156.             call sclicd (addr (clicmd));
  157.             call attcon();
  158.             call setpri (oldpriority);
  159.         end;
  160.     end;
  161.  
  162.     /**********************************
  163.     *                                 *
  164.     * Call Resident System Proc Test: *
  165.     *                                 *
  166.     **********************************/
  167.     dcl
  168.         1 cpb,
  169.           2 nameadr ptr,
  170.           2 paramadr ptr;
  171.     dcl
  172.         aparam ptr;
  173.     dcl
  174.         procname char(8) static initial ('STRING  ');
  175.     dcl
  176.         1 stringqcb static,
  177.           2 link fixed(15),
  178.           2 name char(8) initial ('STRING  '),
  179.           2 msglen fixed(15) initial (2),
  180.           2 nmbmsgs fixed(15) initial (1),
  181.           2 dqph ptr,
  182.           2 nqph ptr,
  183.           2 msgin ptr,
  184.           2 msgout ptr,
  185.           2 msgcnt fixed(15),
  186.           2 buffer ptr;
  187.     dcl
  188.         1 stringuqcb,
  189.           2 pointer ptr,
  190.           2 msgadr ptr;
  191.     dcl
  192.         stringprocadr entry (fixed) variable returns(ptr);
  193.     dcl
  194.         rtnstringadr ptr,
  195.         rtnstring based (rtnstringadr) char(27);
  196.  
  197.     clresptst:
  198.         get edit (v) (a);  /* clear input buffer */
  199.  
  200.     put skip(2) list ('Call Resident System Process Test:');
  201.     call makque (addr (stringqcb));
  202.     stringuqcb.pointer = addr (stringqcb);
  203.     stringuqcb.msgadr = addr (stringprocadr);
  204.     stringprocadr = clresptest;
  205.     call wrque (addr (stringuqcb));
  206.     cpb.nameadr = addr (procname);
  207.     cpb.paramadr = addr (aparam);
  208.     aparam = addr (upper);
  209.  
  210.     unspec (rtnstringadr) = clresp (addr (cpb));
  211.  
  212.     put edit ('->STRING proc returned:',rtnstring)
  213.              (skip,a,a(27));
  214.  
  215.     if ~delque (addr (stringqcb)) then
  216.     do;
  217.         put skip list ('*** Unable to delete stringqcb ***');
  218.         call term ('0000'b4);
  219.     end;
  220.     put skip list ('->Call clresp test complete.');
  221.  
  222.     /**********************************
  223.     *                                 *
  224.     * Parse Filename Test:            *
  225.     *                                 *
  226.     **********************************/
  227.     dcl
  228.         done bit(1);
  229.     dcl
  230.         line char(80);
  231.     dcl
  232.         1 pfcb,
  233.           2 flname ptr,
  234.           2 fcb ptr;
  235.     dcl
  236.         delimptr ptr,
  237.         delim based (delimptr) char(1);
  238.     dcl
  239.         oldptr ptr,
  240.         old based (oldptr) char(10);
  241.     dcl
  242.         1 afcb,
  243.           2 name,
  244.             3 drive fixed(7),
  245.             3 fname char(8),
  246.             3 ftype char(3);
  247.  
  248.     put skip(2) list ('Parse Filename Test:');
  249.     on endfile (sysin)
  250.         go to gettodtest;
  251.     put skip list ('  Enter string of filenames to be parsed,');
  252.     put list ('separated by commas:');
  253.     do while (true);
  254.         put skip list ('->');
  255.         get edit (line) (a);
  256.         line = substr (line,1,index (line,' ')-1) || ascii (13);
  257.         pfcb.flname = addr (line);
  258.         pfcb.fcb = addr (afcb);
  259.         oldptr = addr (line);
  260.         done = false;
  261.         pfcb.flname = parse (addr (pfcb));
  262.         do while (~done & (unspec (pfcb.flname) ~= 'ffff'b4));
  263.             oldptr = pfcb.flname;
  264.             put edit ('  ',ascii (afcb.drive+64),': ',
  265.                       afcb.fname,' ',afcb.ftype)
  266.                      (skip,a,a,a,a(8),a,a(3));
  267.             if unspec (pfcb.flname) = '0000'b4 then
  268.             do;
  269.                 done = true;
  270.             end;
  271.             else
  272.             do;
  273.                 delimptr = pfcb.flname;
  274.                 if delim = ',' then
  275.                 do;
  276.                     unspec (i) = unspec (pfcb.flname);
  277.                     i = i + 1;
  278.                     unspec (pfcb.flname) = unspec (i);
  279.                 end;
  280.                 pfcb.flname = parse (addr (pfcb));
  281.             end;
  282.         end;
  283.         if ~done then
  284.         do;
  285.             put skip list ('  *** Bad Entry ***  ->');
  286.             put edit (old) (a(10));
  287.         end;
  288.     end;
  289.  
  290.     /**********************************
  291.     *                                 *
  292.     * Time and Date Test:             *
  293.     *                                 *
  294.     **********************************/
  295.     dcl
  296.         1 tod,
  297.           2 date fixed(15),
  298.           2 time,
  299.             3 hour bit(8),
  300.             3 min bit(8),
  301.             3 sec bit(8);
  302.  
  303.     gettodtest:
  304.         get edit (v) (a);  /* clear input buffer */
  305.  
  306.     put skip(2) list ('Time and Date Test:');
  307.     call gettod (addr (tod));
  308.     put edit ('-> ',tod.date,'  ',tod.hour,':',tod.min,':',tod.sec)
  309.              (skip,a,f(5),a,b4(2),a,b4(2),a,b4(2));
  310.  
  311.  
  312.     end mc;
  313.