1. -- 
  2. with Generic_Priority_Controller; 
  3. with Test_Data; 
  4.  
  5. with System; 
  6. with Ada.Text_IO; 
  7.  
  8. procedure Test_Priority_Controller is 
  9.    use Ada; 
  10.    package Td renames Test_Data; 
  11.  
  12.    type Message_Priority_Type is (Urgend, Normal, Drop); 
  13.    -- 
  14.    --  From high to low! 
  15.  
  16.    procedure Send_With_Priority (D : Td.Root_Message_Type'Class; With_P : Message_Priority_Type) is 
  17.    begin 
  18.  
  19.       if With_P /= Drop then 
  20.          Text_IO.Put_Line ("## Sending " & Message_Priority_Type'Image (With_P)); 
  21.          Td.Send (D); 
  22.  
  23.       else 
  24.          Text_IO.Put_Line ("## NOT Sending " & Message_Priority_Type'Image (With_P)); 
  25.       end if; 
  26.  
  27.    end Send_With_Priority; 
  28.  
  29.    -- -- -- 
  30.  
  31.    package Pctr is new Generic_Priority_Controller 
  32.      (Data_Priority_Type => Message_Priority_Type, 
  33.       Data_Type          => Td.Root_Message_Type, 
  34.       Handler            => Send_With_Priority); 
  35.  
  36.    --  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
  37.  
  38.    D1 : Td.Message_Type_1; 
  39.    D2 : Td.Message_Type_2; 
  40.  
  41.    --  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
  42.  
  43.    type Send_Procedure_Access_Type is access procedure; 
  44.    -- 
  45.    -- Access type to a parameterless procedure 
  46.  
  47.    task type Sender_Task_Type (Task_Priority : System.Priority) is 
  48.       entry Start (Task_Id : Character; Send_Procedure : Send_Procedure_Access_Type); 
  49.  
  50.       pragma Priority (Task_Priority); 
  51.    end Sender_Task_Type; 
  52.  
  53.    -- -- -- 
  54.  
  55.    task body Sender_Task_Type is 
  56.       My_Id        : Character; 
  57.       My_Procedure : Send_Procedure_Access_Type; 
  58.  
  59.    begin 
  60.       accept Start (Task_Id : Character; Send_Procedure : Send_Procedure_Access_Type) do 
  61.          My_Id        := Task_Id; 
  62.          My_Procedure := Send_Procedure; 
  63.       end Start; 
  64.  
  65.       Text_IO.Put_Line ("## Sender starting " & My_Id); 
  66.  
  67.       My_Procedure.all; 
  68.  
  69.       Text_IO.Put_Line ("## Sender finished " & My_Id); 
  70.  
  71.    end Sender_Task_Type; 
  72.  
  73.    -- -- -- 
  74.  
  75.    procedure Send1_Procedure is 
  76.    begin 
  77.  
  78.       Pctr.Get (D1, Normal); 
  79.       Pctr.Get (D1, Urgend); 
  80.       Pctr.Get (D2, Urgend); 
  81.       Pctr.Get (D2, Normal); 
  82.       Pctr.Get (D1, Drop); 
  83.       Pctr.Get (D1, Urgend); 
  84.       Pctr.Get (D2, Urgend); 
  85.       Pctr.Get (D2, Normal); 
  86.       Pctr.Get (D2, Normal); 
  87.       Pctr.Get (D1, Drop); 
  88.       Pctr.Get (D2, Urgend); 
  89.       Pctr.Get (D2, Drop); 
  90.       Pctr.Get (D1, Normal); 
  91.  
  92.    end Send1_Procedure; 
  93.  
  94.    procedure Send2_Procedure is 
  95.    begin 
  96.  
  97.       Pctr.Get (D1, Urgend); 
  98.       Pctr.Get (D1, Urgend); 
  99.       Pctr.Get (D2, Normal); 
  100.       Pctr.Get (D2, Urgend); 
  101.       Pctr.Get (D1, Drop); 
  102.       Pctr.Get (D1, Normal); 
  103.       Pctr.Get (D2, Normal); 
  104.       Pctr.Get (D2, Urgend); 
  105.       Pctr.Get (D2, Urgend); 
  106.       Pctr.Get (D1, Drop); 
  107.       Pctr.Get (D2, Urgend); 
  108.       Pctr.Get (D2, Normal); 
  109.       Pctr.Get (D1, Drop); 
  110.  
  111.    end Send2_Procedure; 
  112.  
  113.    procedure Send3_Procedure is 
  114.    begin 
  115.  
  116.       Pctr.Get (D1, Urgend); 
  117.       Pctr.Get (D1, Urgend); 
  118.       Pctr.Get (D2, Normal); 
  119.       Pctr.Get (D2, Urgend); 
  120.       Pctr.Get (D1, Drop); 
  121.       Pctr.Get (D1, Urgend); 
  122.       Pctr.Get (D2, Normal); 
  123.       Pctr.Get (D2, Urgend); 
  124.       Pctr.Get (D2, Urgend); 
  125.       Pctr.Get (D1, Drop); 
  126.       Pctr.Get (D2, Urgend); 
  127.       Pctr.Get (D2, Normal); 
  128.       Pctr.Get (D1, Drop); 
  129.  
  130.    end Send3_Procedure; 
  131.  
  132.    -- -- -- 
  133.  
  134.    Sender_Task_Priority : constant System.Priority := System.Default_Priority - 1; 
  135.  
  136.    Max_Task_Nb : constant Positive := 3; 
  137.  
  138.    type Task_Index_Type is new Positive range 1 .. Max_Task_Nb; 
  139.  
  140.    Send_Procedure_Access_Array : array (Task_Index_Type) of Send_Procedure_Access_Type := 
  141.      (1 => Send1_Procedure'Access, 2 => Send2_Procedure'Access, 3 => Send3_Procedure'Access); 
  142.  
  143.    Sender_Task_Array : array (Task_Index_Type) of Sender_Task_Type (Task_Priority => Sender_Task_Priority); 
  144.  
  145.    Sender_Task_Id_Array : array (Task_Index_Type) of Character := (1 => 'A', 2 => 'B', 3 => 'C'); 
  146.  
  147. --  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
  148.  
  149. begin 
  150.    Text_IO.Put_Line ("## Test_Priority_Controller ..."); 
  151.  
  152.    Pctr.Start; 
  153.  
  154.    for Ix in Task_Index_Type loop 
  155.       Sender_Task_Array (Ix).Start 
  156.         (Task_Id        => Sender_Task_Id_Array (Ix), 
  157.          Send_Procedure => Send_Procedure_Access_Array (Ix)); 
  158.    end loop; 
  159.  
  160.    Text_IO.Put_Line ("## Waiting for CR ..."); 
  161.    Text_IO.Skip_Line; 
  162.  
  163.    Text_IO.Put_Line ("## Test_Priority_Controller."); 
  164.  
  165. end Test_Priority_Controller;