home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol079 / mpmcalls.pli < prev    next >
Encoding:
Text File  |  1984-04-29  |  12.8 KB  |  503 lines
  1. mpmtst:
  2.     proc options(main);
  3.  
  4.     dcl
  5.         mc entry;
  6.  
  7.     /*
  8.         Direct MP/M Call Test Program
  9.         -----------------------------
  10.  
  11.         The purpose of the MPMCALLS and MPMCALLC PLI programs
  12.     is to demonstrate direct MP/M calls from PLI.  The following
  13.     instructions outline the steps to assemble, compile, link
  14.     and execute this test program.
  15.  
  16.         1.)  Compile the PLI programs as follows:
  17.             >pli mpmcalls $pl
  18.             >pli mpmcallc $pl
  19.  
  20.         2.)  Assemble the mpmdio.asm module:
  21.             >rmac mpmdio
  22.  
  23.         3.)  Link the mpmcalls and mpmdio modules:
  24.             >link mpmcalls,mpmcallc,mpmdio
  25.  
  26.         4.)  Gensys your MP/M system as follows:
  27.             Top .... = ff
  28.             Number of con..  = 1
  29.             Add system call ...  ? n
  30.             Bank switched mem... ? n
  31.              :0
  32.              :a0
  33.              :ff
  34.  
  35.         5.)  Execute the mpmcalls program:
  36.             0A>mpmcalls
  37.  
  38. */
  39.  
  40.     /* external MP/M I/O entry points */
  41.     /* (note: each source line begins with tab chars) */
  42.  
  43.     %replace
  44.     true   by '1'b,
  45.     false  by '0'b;
  46.  
  47. %include 'mpmdio.dcl';
  48.  
  49.     dcl
  50.         vers   entry         returns (bit(16));
  51.  
  52.     dcl
  53.         sysin file,
  54.         version bit(16),
  55.         oldpriority fixed(7),
  56.         v char(254) var,
  57.         i fixed;
  58.  
  59.     dcl
  60.         pdadr ptr,
  61.         1 pd based (pdadr),
  62.           2 link ptr,
  63.           2 status fixed(7),
  64.           2 priority fixed(7),
  65.           2 stkptr ptr,
  66.           2 name char(8),
  67.           2 console fixed(7),
  68.           2 memseg fixed(7),
  69.           2 b fixed(15),
  70.           2 thread ptr,
  71.           2 dmadr ptr,
  72.           2 slct bit(8);
  73.     /*      2 dcnt fixed(15),
  74.           2 searchl fixed(7),
  75.           2 searcha ptr,
  76.           2 drvact bit(16),
  77.           2 registers (20) fixed(7),
  78.           2 scratch fixed(15);
  79.     */
  80.  
  81.     dcl
  82.         1 localpd static,
  83.           2 link ptr,
  84.           2 status fixed(7),
  85.           2 priority fixed(7),
  86.           2 stkptr ptr,
  87.           2 name char(8) initial ('LocalPD '),
  88.           2 console fixed(7),
  89.           2 memseg fixed(7),
  90.           2 b fixed(15),
  91.           2 thread ptr,
  92.           2 dmadr ptr,
  93.           2 slct fixed(7),
  94.           2 dcnt fixed(15),
  95.           2 searchl fixed(7),
  96.           2 searcha ptr,
  97.           2 drvact bit(16),
  98.           2 registers (20) fixed(7),
  99.           2 scratch fixed(15);
  100.  
  101.     dcl
  102.         localstk (0:255) entry (fixed) variable;
  103.  
  104.     dcl
  105.         sysdatpgadr ptr,
  106.         1 sysdatpg based (sysdatpgadr),
  107.           2 memtop bit(8),
  108.           2 nmbcns fixed(7),
  109.           2 brkptrst fixed (7),
  110.           2 syscallstks bit(8),
  111.           2 bankswitched bit(8);
  112.     /*      2 z80cpu bit(8),
  113.           2 bankedbdos bit(8),
  114.           2 basebankedbdos ptr;
  115.     */
  116.  
  117.     dcl
  118.         upper char(27) static initial
  119.             ('ABCDEFGHIJKLMNOPQRSTUVWXYZ '),
  120.         lower char(27) static initial
  121.             ('abcdefghijklmnopqrstuvwxyz ');
  122.  
  123.  
  124.     /**********************************
  125.     *                                 *
  126.     * Local procedures used during    *
  127.     *  testing.                       *
  128.     *                                 *
  129.     **********************************/
  130.  
  131.     flagtest:
  132.         proc;
  133.         dcl
  134.             boolean bit(1);
  135.  
  136.         call attcon();
  137.         boolean = flgwt (30);
  138.         put skip list ('-> flagtest wait on #30 complete.');
  139.         call detcon();
  140.         boolean = flgset (31);
  141.         call term ('ffff'b4);
  142.         end flagtest;
  143.  
  144.     queuetest:
  145.         proc;
  146.         dcl
  147.             1 qcbB static,
  148.               2 link fixed(15),
  149.               2 name char(8) initial ('QueueB  '),
  150.               2 msglen fixed(15) initial (10),
  151.               2 nmbmsgs fixed(15) initial (2),
  152.               2 dqph ptr,
  153.               2 nqph ptr,
  154.               2 msgin ptr,
  155.               2 msgout ptr,
  156.               2 msgcnt fixed(15),
  157.               2 buffer (2),
  158.                 3 lnk ptr,
  159.                 3 char(10);
  160.         dcl
  161.             1 uqcbA static,
  162.               2 pointer ptr,
  163.               2 msgadr ptr,
  164.               2 name char(8) initial ('QueueA  ');
  165.         dcl
  166.             1 uqcbB,
  167.               2 pointer ptr,
  168.               2 msgadr ptr;
  169.         dcl
  170.             msgA char(10),
  171.             msgB char(10);
  172.  
  173.         uqcbA.msgadr = addr (msgA);
  174.         uqcbB.pointer = addr (qcbB);
  175.         uqcbB.msgadr = addr (msgB);
  176.         call makque (addr (qcbB));
  177.         do while (~opnque (addr (uqcbA)));
  178.             call delay (1); /* until qcbA created */
  179.         end;
  180.         do while (true);
  181.             call rdque (addr (uqcbA));
  182.             msgB = translate (msgA,upper,lower);
  183.             call wrque (addr (uqcbB));
  184.         end;
  185.         end queuetest;
  186.  
  187.  
  188. /**************************************************
  189. ***************************************************
  190. ********                                   ********
  191. ********      M a i n   P r o g r a m      ********
  192. ********                                   ********
  193. ***************************************************
  194. **************************************************/
  195.  
  196.  
  197.     /**********************************
  198.     *                                 *
  199.     * Verify Operation Under MP/M     *
  200.     *   Without Banked Memory.        *
  201.     *                                 *
  202.     **********************************/
  203.  
  204.     version = vers();
  205.     if substr (version,1,8) = '00'b4 then
  206.     do;
  207.         put skip list ('Tests cannot run under CP/M.');
  208.         call term('0000'b4);
  209.     end;
  210.     sysdatpgadr = sysdat ();
  211.     if sysdatpg.bankswitched = 'FF'b4 then
  212.     do;
  213.         put skip list ('Tests cannot run under MP/M');
  214.         put list ('with bank switched memory.');
  215.         call term('0000'b4);
  216.     end;
  217.     if sysdatpg.syscallstks = 'FF'b4 then
  218.     do;
  219.         put skip list ('Tests cannot run under MP/M');
  220.         put list ('with system call user stacks.');
  221.         call term('0000'b4);
  222.     end;
  223.     pdadr = rpdadr();   /* get current running pd adr */
  224.     oldpriority = pd.priority;
  225.  
  226.     /**********************************
  227.     *                                 *
  228.     * Memory Management Tests:        *
  229.     *       AMEMRQ, RMEMRQ, MEMFR     *
  230.     *                                 *
  231.     **********************************/
  232.     dcl
  233.         1 memdscr,
  234.           2 base fixed (7),     /* base page */
  235.           2 size fixed (7),     /* # of pages */
  236.           2 attrib fixed (7),   /* attributes */
  237.           2 bank fixed (7);     /* bank byte */
  238.  
  239.     on endfile (sysin)
  240.         go to rmemrqtst;
  241.     put skip list ('Memory Management Tests:');
  242.     do while (true);
  243.         put skip(2) list ('    Absolute Request');
  244.         put skip list ('        Base (xx in hex) = ');
  245.         i = pd.memseg;  /* save old memseg index */
  246.         get edit (unspec (memdscr.base)) (b4(2));
  247.         if amemrq (addr (memdscr)) then
  248.         do;
  249.             put skip list ('    Absolute Request satisfied.');
  250.             put edit ('      Base = ',unspec (memdscr.base),'H')
  251.                      (skip,a,b4,a);
  252.             put edit ('      Size = ',unspec (memdscr.size),'H')
  253.                      (skip,a,b4,a);
  254.             put edit ('      Attr = ',unspec (memdscr.attrib),'H')
  255.                      (skip,a,b4,a);
  256.             put edit ('      Bank = ',unspec (memdscr.bank),'H')
  257.                      (skip,a,b4,a);
  258.             call memfr (addr (memdscr));
  259.             pd.memseg = i;  /* restore former memseg index */
  260.         end;
  261.         else
  262.         do;
  263.             put skip list ('    Absolute Request failed.');
  264.         end;
  265.     end;
  266.  
  267.     rmemrqtst:
  268.         get edit (v) (a);  /* clear input buffer */
  269.  
  270.     on endfile (sysin)
  271.         go to polltst;
  272.     do while (true);
  273.         put skip(2) list ('    Relocatable Request');
  274.         put skip list ('        Size (xxh) = ');
  275.         i = pd.memseg;  /* save old memseg index */
  276.         get edit (unspec (memdscr.size)) (b4(2));
  277.         if rmemrq (addr (memdscr)) then
  278.         do;
  279.             put skip list ('    Relocatable Request satisfied.');
  280.             put edit ('      Base = ',unspec (memdscr.base),'H')
  281.                      (skip,a,b4,a);
  282.             put edit ('      Size = ',unspec (memdscr.size),'H')
  283.                      (skip,a,b4,a);
  284.             put edit ('      Attr = ',unspec (memdscr.attrib),'H')
  285.                      (skip,a,b4,a);
  286.             put edit ('      Bank = ',unspec (memdscr.bank),'H')
  287.                      (skip,a,b4,a);
  288.             call memfr (addr (memdscr));
  289.             pd.memseg = i;  /* restore former memseg index */
  290.         end;
  291.         else
  292.         do;
  293.             put skip list ('    Relocatable Request failed.');
  294.         end;
  295.     end;
  296.  
  297.     /**********************************
  298.     *                                 *
  299.     * Poll Tests:                     *
  300.     *  The poll call cannot be tested *
  301.     *  unless the poll device table   *
  302.     *  in the XIOS is known.          *
  303.     *                                 *
  304.     **********************************/
  305.  
  306.     polltst:
  307.         get edit (v) (a);  /* clear input buffer */
  308.  
  309. /*  The following code is "commented out"
  310.  
  311.     call poll (devicenumber);
  312.     put edit ('Device ',devicenumber,'is ready.')
  313.                  (skip,a,f,a);
  314.  
  315.     End of "commented out" code  */
  316.  
  317.     put skip(2) list ('Poll call not tested.');
  318.  
  319.     /**********************************
  320.     *                                 *
  321.     * Flag Tests:                     *
  322.     *       FLGWT, FLGSET             *
  323.     *                                 *
  324.     *    Note: this test assumes that *
  325.     *    flags 30 & 31 are unused.    *
  326.     *                                 *
  327.     **********************************/
  328.     dcl
  329.         flagover bit(1),
  330.         flagunder bit(1);
  331.  
  332.     unspec (localpd.link) = '0000'b4;
  333.     localpd.priority = 100;
  334.     localpd.stkptr = addr (localstk(255));
  335.     localpd.console = pd.console;
  336.     localpd.memseg = pd.memseg;
  337.     localstk(255) = flagtest;
  338.     call crproc (addr (localpd));
  339.     put skip(2) list ('Flag Tests:');
  340.     call setpri (101);
  341.     call detcon();
  342.     flagover = ~flgset (30);
  343.     call attcon();
  344.     call setpri (oldpriority);
  345.     flagunder = ~flgwt (31);
  346.     if flagover then
  347.         put skip list ('-> flag over-run.');
  348.     if flagunder then
  349.         put skip list ('-> flag under-run.');
  350.     put skip list ('-> flag tests successful.');
  351.  
  352.     /**********************************
  353.     *                                 *
  354.     * Queue Management Tests:         *
  355.     *    MAKQUE,OPNQUE,DELQUE         *
  356.     *    RDQUE,CRDQUE,WRQUE,CWRQUE    *
  357.     *                                 *
  358.     **********************************/
  359.     dcl
  360.         1 qcbA static,
  361.           2 link fixed(15),
  362.           2 name char(8) initial ('QueueA  '),
  363.           2 msglen fixed(15) initial (10),
  364.           2 nmbmsgs fixed(15) initial (2),
  365.           2 dqph ptr,
  366.           2 nqph ptr,
  367.           2 msgin ptr,
  368.           2 msgout ptr,
  369.           2 msgcnt fixed(15),
  370.           2 buffer (2),
  371.             3 lnk ptr,
  372.             3 char(10);
  373.     dcl
  374.         1 uqcbA,
  375.           2 pointer ptr,
  376.           2 msgadr ptr;
  377.     dcl
  378.         1 uqcbB static,
  379.           2 pointer ptr,
  380.           2 msgadr ptr,
  381.           2 name char(8) initial ('QueueB  ');
  382.     dcl
  383.         msgA char(10),
  384.         msgB char(10);
  385.  
  386.     put skip(2) list ('Queue Tests:');
  387.     on endfile (sysin)
  388.         go to abtsprtest;
  389.     uqcbA.pointer = addr (qcbA);
  390.     uqcbA.msgadr = addr (msgA);
  391.     uqcbB.msgadr = addr (msgB);
  392.     call makque (addr (qcbA));
  393.  
  394.     put skip(2) list ('  Testing Conditional Write Queue');
  395.     do i = 1 to 10 while (cwrque (addr (uqcbA)));
  396.         put edit ('    Message #',i)
  397.                  (skip,a,f(2));
  398.     end;
  399.     put skip list ('  Queue is full.');
  400.  
  401.     put skip(2) list ('  Testing Conditional Read Queue');
  402.     do i = 1 to 10 while (crdque (addr (uqcbA)));
  403.         put edit ('    Message #',i)
  404.                  (skip,a,f(2));
  405.     end;
  406.     put skip list ('  Queue is empty.');
  407.  
  408.     unspec (localpd.link) = '0000'b4;
  409.     localpd.priority = 100;
  410.     localpd.stkptr = addr (localstk(255));
  411.     localpd.console = pd.console;
  412.     localpd.memseg = pd.memseg;
  413.     localstk(255) = queuetest;
  414.     call crproc (addr (localpd));
  415.  
  416.     do while (~opnque (addr (uqcbB)));
  417.         call delay (1); /* until qcbB created */
  418.     end;
  419.     put skip list ('  Enter char(10) message:');
  420.     do while (true);
  421.         put skip list ('->');
  422.         get edit (msgA) (a);
  423.         call wrque (addr (uqcbA));
  424.         call rdque (addr (uqcbB));
  425.         put edit ('<-',msgB)
  426.                  (skip,a,a(10));
  427.     end;
  428.  
  429.     /**********************************
  430.     *                                 *
  431.     * Abort Specified Process Test:   *
  432.     *                                 *
  433.     **********************************/
  434.     dcl
  435.         1 abtpb static,
  436.           2 pda bit(16) initial ('0000'b4),
  437.           2 termcode bit(16) initial ('ffff'b4),
  438.           2 name char(8) initial ('LocalPD '),
  439.           2 console fixed(7);
  440.  
  441.     abtsprtest:
  442.         get edit (v) (a);  /* clear input buffer */
  443.  
  444.     put skip(2) list ('Abort Specified Process Test:');
  445.     put skip list ('  Aborting LocalPD.');
  446.     abtpb.console = pd.console;
  447.     if abtspr (addr (abtpb)) then
  448.     do;
  449.         put skip list ('->Abort successful');
  450.     end;
  451.     else
  452.     do;
  453.         put skip list ('->Abort Failed');
  454.         go to error;
  455.     end;
  456.     if ~delque (addr (qcbA)) then
  457.     do;
  458.         put skip list ('*** Unable to delete QueueA ***');
  459.         call term('0000'b4);
  460.     end;
  461.     if ~delque (uqcbB.pointer) then
  462.     do;
  463.         put skip list ('*** Unable to delete QueueB ***');
  464.         call term('0000'b4);
  465.     end;
  466.  
  467.  
  468.     /**********************************
  469.     ***********************************
  470.     ****                           ****
  471.     ****    Call pli procedure     ****
  472.     ****    "mc" for other tests   ****
  473.     ****                           ****
  474.     ***********************************
  475.     **********************************/
  476.  
  477.     call mc();
  478.  
  479.  
  480.     /**********************************
  481.     *                                 *
  482.     * Termination Test:               *
  483.     *                                 *
  484.     **********************************/
  485.  
  486.     put skip(2) list ('Termination Test:');
  487.     call term ('0000'b4);
  488.  
  489.     /**********************************
  490.     *                                 *
  491.     * Unrecoverable Error:            *
  492.     *                                 *
  493.     **********************************/
  494.  
  495.     error:
  496.  
  497.     put skip list ('*** Unrecoverable Error ***');
  498.     call disabl();
  499.     do while (true);
  500.     end;
  501.  
  502.     end mpmtst;
  503.