gcc/testsuite/gnat.dg/opt57.adb

   1 package body Opt57 is
   2
   3    type Phase_Enum is (None_Phase, FE_Init_Phase, FE_Phase);
   4
   5    type Message_State is (No_Messages, Some_Messages);
   6
   7    type Module_List_Array is array (Phase_Enum, Message_State) of List;
   8
   9    type Private_Module_Factory is limited record
  10       Module_Lists : Module_List_Array;
  11    end record;
  12
  13    type Element_Array is array (Positive range <>) of Module_Factory_Ptr;
  14
  15    type Hash_Table is array (Positive range <>) of aliased Module_Factory_Ptr;
  16
  17    type Heap_Data_Rec (Table_Last : Positive) is limited record
  18       Number_Of_Elements : Positive;
  19       Table              : Hash_Table (1 .. Table_Last);
  20    end record;
  21
  22    type Heap_Data_Ptr is access Heap_Data_Rec;
  23
  24    type Table is limited record
  25       Data : Heap_Data_Ptr;
  26    end record;
  27
  28    function All_Elements (M : Table) return Element_Array is
  29       Result : Element_Array (1 .. Natural (M.Data.Number_Of_Elements));
  30       Last   : Natural := 0;
  31    begin
  32       for H in M.Data.Table'Range loop
  33          Last := Last + 1;
  34          Result (Last) := M.Data.Table(H);
  35       end loop;
  36       return Result;
  37    end;
  38
  39    The_Factories : Table;
  40
  41    subtype Language_Array is Element_Array;
  42    type Language_Array_Ptr is access Language_Array;
  43    All_Languages : Language_Array_Ptr := null;
  44
  45    procedure Init is
  46    begin
  47       if All_Languages = null then
  48          All_Languages := new Language_Array'(All_Elements (The_Factories));
  49       end if;
  50    end;
  51
  52    function Is_Empty (L : List) return Boolean is
  53    begin
  54       return Link_Constant (L.Next) = L'Unchecked_Access;
  55    end;
  56
  57    function First (L : List) return Linkable_Ptr is
  58    begin
  59       return Links_Type (L.Next.all).Container.all'Access;
  60    end;
  61
  62    procedure Update is
  63       Check_New_Dependences : Boolean := False;
  64    begin
  65       loop
  66          for Lang_Index in All_Languages'Range loop
  67             for Has_Messages in Message_State loop
  68                declare
  69                   L : List renames
  70                     All_Languages (Lang_Index).Priv.Module_Lists
  71                       (FE_Init_Phase, Has_Messages);
  72                begin
  73                   while not Is_Empty (L) loop
  74                      declare
  75                         Module_In_Init_State : constant Module_Ptr :=
  76                           Module_Ptr (First (L));
  77                         Pin_Dependence : Pinned (Module_In_Init_State);
  78                      begin
  79                         Check_New_Dependences := True;
  80                      end;
  81                   end loop;
  82                end;
  83             end loop;
  84          end loop;
  85          exit when not Check_New_Dependences;
  86       end loop;
  87    end;
  88
  89 end Opt57;