From e280f98126fb6f0df2d7d980615b97bc4d540e5e Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 3 Aug 2011 12:45:20 +0200 Subject: [PATCH] [multiple changes] 2011-08-03 Emmanuel Briot * make.adb, makeutl.adb, makeutl.ads, clean.adb (Makeutl.Queue): new package. 2011-08-03 Yannick Moy * cstand.adb (Create_Standard): select Universal_Integer as an ALFA type * sem_ch3.adb (Array_Type_Declaration): detect array types in ALFA * sem_util.adb, sem_util.ads (Has_Static_Array_Bounds): new function to detect that an array has static bounds. From-SVN: r177264 --- gcc/ada/ChangeLog | 12 ++ gcc/ada/clean.adb | 109 +++------- gcc/ada/cstand.adb | 1 + gcc/ada/make.adb | 440 +++++---------------------------------- gcc/ada/makeutl.adb | 477 +++++++++++++++++++++++++++++++++++++------ gcc/ada/makeutl.ads | 91 +++++++-- gcc/ada/sem_ch3.adb | 22 ++ gcc/ada/sem_util.adb | 63 ++++++ gcc/ada/sem_util.ads | 3 + 9 files changed, 667 insertions(+), 551 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ce4039269c9..6f2e874c65b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,15 @@ +2011-08-03 Emmanuel Briot + + * make.adb, makeutl.adb, makeutl.ads, clean.adb (Makeutl.Queue): new + package. + +2011-08-03 Yannick Moy + + * cstand.adb (Create_Standard): select Universal_Integer as an ALFA type + * sem_ch3.adb (Array_Type_Declaration): detect array types in ALFA + * sem_util.adb, sem_util.ads (Has_Static_Array_Bounds): new function to + detect that an array has static bounds. + 2011-08-03 Thomas Quinot * exp_dist.adb: Minor reformatting. diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index e67b48eeae1..73e971aa6ba 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -141,34 +141,6 @@ package body Clean is -- Table to store all the source files of a library unit: spec, body and -- subunits, to detect .dg files and delete them. - ---------------------------- - -- Queue (Q) manipulation -- - ---------------------------- - - procedure Init_Q; - -- Must be called to initialize the Q - - procedure Insert_Q (Lib_File : File_Name_Type); - -- If Lib_File is not marked, inserts it at the end of Q and mark it - - function Empty_Q return Boolean; - -- Returns True if Q is empty - - procedure Extract_From_Q (Lib_File : out File_Name_Type); - -- Extracts the first element from the Q - - Q_Front : Natural; - -- Points to the first valid element in the Q - - package Q is new Table.Table ( - Table_Component_Type => File_Name_Type, - Table_Index_Type => Natural, - Table_Low_Bound => 0, - Table_Initial => 4000, - Table_Increment => 100, - Table_Name => "Clean.Q"); - -- This is the actual queue - ----------------------------- -- Other local subprograms -- ----------------------------- @@ -399,8 +371,11 @@ package body Clean is Text : Text_Buffer_Ptr; The_ALI : ALI_Id; + Found : Boolean; + Source : Queue.Source_Info; + begin - Init_Q; + Queue.Initialize (Queue_Per_Obj_Dir => False); -- It does not really matter if there is or not an object file -- corresponding to an ALI file: if there is one, it will be deleted. @@ -414,12 +389,23 @@ package body Clean is for N_File in 1 .. Osint.Number_Of_Files loop Main_Source_File := Next_Main_Source; Main_Lib_File := Osint.Lib_File_Name - (Main_Source_File, Current_File_Index); - Insert_Q (Main_Lib_File); + (Main_Source_File, Current_File_Index); - while not Empty_Q loop + if Main_Lib_File /= No_File then + Queue.Insert + ((Format => Format_Gnatmake, + File => Main_Lib_File, + Unit => No_Unit_Name, + Index => 0, + Project => No_Project)); + end if; + + while not Queue.Is_Empty loop Sources.Set_Last (0); - Extract_From_Q (Lib_File); + Queue.Extract (Found, Source); + pragma Assert (Found); + pragma Assert (Source.File /= No_File); + Lib_File := Source.File; Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File); -- If we have existing ALI file that is not read-only, process it @@ -448,7 +434,14 @@ package body Clean is for K in ALI.Units.Table (J).First_With .. ALI.Units.Table (J).Last_With loop - Insert_Q (Withs.Table (K).Afile); + if Withs.Table (K).Afile /= No_File then + Queue.Insert + ((Format => Format_Gnatmake, + File => Withs.Table (K).Afile, + Unit => No_Unit_Name, + Index => 0, + Project => No_Project)); + end if; end loop; end loop; @@ -1348,26 +1341,6 @@ package body Clean is end if; end Display_Copyright; - ------------- - -- Empty_Q -- - ------------- - - function Empty_Q return Boolean is - begin - return Q_Front >= Q.Last; - end Empty_Q; - - -------------------- - -- Extract_From_Q -- - -------------------- - - procedure Extract_From_Q (Lib_File : out File_Name_Type) is - Lib : constant File_Name_Type := Q.Table (Q_Front); - begin - Q_Front := Q_Front + 1; - Lib_File := Lib; - end Extract_From_Q; - --------------- -- Gnatclean -- --------------- @@ -1535,16 +1508,6 @@ package body Clean is return False; end In_Extension_Chain; - ------------ - -- Init_Q -- - ------------ - - procedure Init_Q is - begin - Q_Front := Q.First; - Q.Set_Last (Q.First); - end Init_Q; - ---------------- -- Initialize -- ---------------- @@ -1596,24 +1559,6 @@ package body Clean is All_Projects := False; end Initialize; - -------------- - -- Insert_Q -- - -------------- - - procedure Insert_Q (Lib_File : File_Name_Type) is - begin - -- Do not insert an empty name or an already marked source - - if Lib_File /= No_File and then not Makeutl.Is_Marked (Lib_File) then - Q.Table (Q.Last) := Lib_File; - Q.Increment_Last; - - -- Mark the source that has been just added to the Q - - Makeutl.Mark (Lib_File); - end if; - end Insert_Q; - ---------------------- -- Object_File_Name -- ---------------------- diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 64ec0436184..f025be93478 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -1334,6 +1334,7 @@ package body CStand is Set_Scope (Universal_Integer, Standard_Standard); Build_Signed_Integer_Type (Universal_Integer, Standard_Long_Long_Integer_Size); + Set_Is_In_ALFA (Universal_Integer); Universal_Real := New_Standard_Entity; Decl := New_Node (N_Full_Type_Declaration, Stloc); diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 1abc9d3fe31..a61728ec6bf 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -71,7 +71,6 @@ with Ada.Command_Line; use Ada.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; -with GNAT.HTable; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.OS_Lib; use GNAT.OS_Lib; @@ -172,56 +171,6 @@ package body Make is N_M_Switch : Natural := 0; -- Used to count -mxxx switches that can affect multilib - package Queue is - --------------------------------- - -- Queue Manipulation Routines -- - --------------------------------- - - procedure Initialize (Queue_Per_Obj_Dir : Boolean); - -- Initialize the queue - - function Is_Empty return Boolean; - -- Returns True if the queue is empty - - function Is_Virtually_Empty return Boolean; - -- Returns True if the queue is empty or if all object directories are - -- busy. - - procedure Insert - (Source_File_Name : File_Name_Type; - Project : Project_Id; - Source_Unit : Unit_Name_Type := No_Unit_Name; - Index : Int := 0); - -- Insert source in the queue - - procedure Extract - (Source_File_Name : out File_Name_Type; - Source_Unit : out Unit_Name_Type; - Source_Index : out Int); - -- Get the first source that can be compiled from the queue. If no - -- source may be compiled, return No_File/No_Source. - - function Size return Natural; - -- Return the total size of the queue, including the sources already - -- extracted. - - function Processed return Natural; - -- Return the number of source in the queue that have already been - -- processed. - - procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type); - -- Indicate that this object directory is busy, so that when - -- One_Compilation_Per_Obj_Dir is True no other compilation occurs in - -- this object directory. - - procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type); - -- Indicate that there is no compilation for this object directory - - function Element (Rank : Positive) return File_Name_Type; - -- Get the file name for element of index Rank in the queue - - end Queue; - -- The 3 following packages are used to store gcc, gnatbind and gnatlink -- switches found in the project files. @@ -2736,14 +2685,16 @@ package body Make is end if; if Add_It then - if Is_Marked (Sfile) then + if not Queue.Insert + ((Format => Format_Gnatmake, + File => Sfile, + Unit => No_Unit_Name, + Project => No_Project, + Index => 0)) + then if Is_In_Obsoleted (Sfile) then Executable_Obsolete := True; end if; - - else - Queue.Insert (Sfile, Project => No_Project, Index => 0); - Mark (Sfile, Index => 0); end if; end if; end; @@ -3168,21 +3119,18 @@ package body Make is else Source_Index := Unit_Index_Of (Withs.Table (K).Afile); - if Is_Marked (Sfile, Source_Index) then - Debug_Msg ("Skipping marked file:", Sfile); - - elsif not (Check_Readonly_Files or Must_Compile) + if not (Check_Readonly_Files or Must_Compile) and then Is_Internal_File_Name (Sfile, False) then Debug_Msg ("Skipping internal file:", Sfile); else Queue.Insert - (Sfile, - ALI_P.Project, - Withs.Table (K).Uname, - Source_Index); - Mark (Sfile, Source_Index); + ((Format => Format_Gnatmake, + File => Sfile, + Project => ALI_P.Project, + Unit => Withs.Table (K).Uname, + Index => Source_Index)); end if; end if; end loop; @@ -3306,15 +3254,11 @@ package body Make is Pid : Process_Id; Process_Created : Boolean; - Source_File : File_Name_Type; + Source : Queue.Source_Info; Full_Source_File : File_Name_Type; Source_File_Attr : aliased File_Attributes; -- The full name of the source file and its attributes (size, ...) - Source_Unit : Unit_Name_Type; - Source_Index : Int; - -- Index of the current unit in the current source file - Lib_File : File_Name_Type; Full_Lib_File : File_Name_Type; Lib_File_Attr : aliased File_Attributes; @@ -3326,18 +3270,20 @@ package body Make is Obj_Stamp : Time_Stamp_Type; -- The object file + Found : Boolean; + begin if not Queue.Is_Virtually_Empty and then Outstanding_Compiles < Max_Process then - Queue.Extract (Source_File, Source_Unit, Source_Index); + Queue.Extract (Found, Source); Osint.Full_Source_Name - (Source_File, + (Source.File, Full_File => Full_Source_File, Attr => Source_File_Attr'Access); - Lib_File := Osint.Lib_File_Name (Source_File, Source_Index); + Lib_File := Osint.Lib_File_Name (Source.File, Source.Index); -- ??? This call could be avoided when using projects, since we -- know where the ALI file is supposed to be. That would avoid @@ -3352,7 +3298,7 @@ package body Make is -- If source has already been compiled, executable is obsolete - if Is_In_Obsoleted (Source_File) then + if Is_In_Obsoleted (Source.File) then Executable_Obsolete := True; end if; @@ -3390,7 +3336,7 @@ package body Make is -- directory of a project being extended must not be skipped). elsif Read_Only - and then Is_In_Object_Directory (Source_File, Full_Lib_File) + and then Is_In_Object_Directory (Source.File, Full_Lib_File) then Verbose_Msg (Lib_File, @@ -3401,19 +3347,19 @@ package body Make is -- The source file that we are checking cannot be located elsif Full_Source_File = No_File then - Record_Failure (Source_File, Source_Unit, False); + Record_Failure (Source.File, Source.Unit, False); -- Source and library files can be located but are internal -- files. elsif not (Check_Readonly_Files or else Must_Compile) and then Full_Lib_File /= No_File - and then Is_Internal_File_Name (Source_File, False) + and then Is_Internal_File_Name (Source.File, False) then if Force_Compilations then Fail ("not allowed to compile """ & - Get_Name_String (Source_File) & + Get_Name_String (Source.File) & """; use -a switch, or compile file with " & """-gnatg"" switch"); end if; @@ -3428,7 +3374,7 @@ package body Make is else Collect_Arguments - (Source_File, Source_File = Main_Source, Args); + (Source.File, Source.File = Main_Source, Args); -- Do nothing if project of source is externally built @@ -3442,9 +3388,9 @@ package body Make is Need_To_Compile := Force_Compilations; if not Force_Compilations then - Check (Source_File => Source_File, - Source_Index => Source_Index, - Is_Main_Source => Source_File = Main_Source, + Check (Source_File => Source.File, + Source_Index => Source.Index, + Is_Main_Source => Source.File = Main_Source, The_Args => Args, Lib_File => Lib_File, Full_Lib_File => Full_Lib_File, @@ -3482,7 +3428,7 @@ package body Make is and then not External_Unit_Compilation_Allowed then Make_Failed ("external source (" - & Get_Name_String (Source_File) + & Get_Name_String (Source.File) & ") is not part of any project;" & " cannot be compiled without" & " gnatmake switch -x"); @@ -3514,7 +3460,7 @@ package body Make is Lib_File := Osint.Lib_File_Name - (Full_Source_File, Source_Index); + (Full_Source_File, Source.Index); Full_Lib_File := Lib_File; else @@ -3532,7 +3478,7 @@ package body Make is Collect_Arguments_And_Compile (Full_Source_File => Full_Source_File, Lib_File => Lib_File, - Source_Index => Source_Index, + Source_Index => Source.Index, Pid => Pid, Process_Created => Process_Created); @@ -3584,13 +3530,13 @@ package body Make is if Process_Created then if Pid = Invalid_Pid then - Record_Failure (Full_Source_File, Source_Unit); + Record_Failure (Full_Source_File, Source.Unit); else Add_Process (Pid => Pid, Sfile => Full_Source_File, Afile => Lib_File, - Uname => Source_Unit, + Uname => Source.Unit, Mfile => Mfile, Full_Lib_File => Full_Lib_File, Lib_File_Attr => Lib_File_Attr); @@ -3727,13 +3673,12 @@ package body Make is Check_Source_Files := True; All_Sources := False; - -- Only insert in the Q if it is not already done, to avoid simultaneous - -- compilations if -jnnn is used. - - if not Is_Marked (Main_Source, Main_Index) then - Queue.Insert (Main_Source, Main_Project, Index => Main_Index); - Mark (Main_Source, Main_Index); - end if; + Queue.Insert + ((Format => Format_Gnatmake, + File => Main_Source, + Project => Main_Project, + Unit => No_Unit_Name, + Index => Main_Index)); First_Compiled_File := No_File; Most_Recent_Obj_File := No_File; @@ -6497,10 +6442,7 @@ package body Make is end if; end if; - -- Remove all marks to be sure to check sources for all executables, - -- as the switches may be different and -s may be in use. - - Delete_All_Marks; + Queue.Remove_Marks; end loop Multiple_Main_Loop; if Do_Codepeer_Globalize_Step then @@ -7033,17 +6975,13 @@ package body Make is (Main_Project /= No_Project and then One_Compilation_Per_Obj_Dir); - -- And of course, only insert in the Q if the source is not marked - - if Sfile /= No_File and then not Is_Marked (Sfile, Index) then - if Verbose_Mode then - Write_Str ("Adding """); - Write_Str (Get_Name_String (Sfile)); - Write_Line (""" to the queue"); - end if; - - Queue.Insert (Sfile, Project, Index => Index); - Mark (Sfile, Index); + if Sfile /= No_File then + Queue.Insert + ((Format => Format_Gnatmake, + File => Sfile, + Project => Project, + Unit => No_Unit_Name, + Index => Index)); end if; if not Put_In_Q and then Sfile /= No_File then @@ -7477,290 +7415,6 @@ package body Make is Scan_Make_Arg (Env, "--RTS=" & Line (1 .. N_Read), And_Save => True); end Process_Multilib; - ----------- - -- Queue -- - ----------- - - package body Queue is - - type Q_Record is record - File : File_Name_Type; - Unit : Unit_Name_Type; - Index : Int; - Project : Project_Id; - Processed : Boolean; - end record; - -- File is the name of the file to compile. Unit is for gnatdist use in - -- order to easily get the unit name of a file to compile when its name - -- is krunched or declared in gnat.adc. Index, when not 0, is the index - -- of the unit in a multi-unit source. - - package Q is new Table.Table - (Table_Component_Type => Q_Record, - Table_Index_Type => Positive, - Table_Low_Bound => 1, - Table_Initial => 4000, - Table_Increment => 100, - Table_Name => "Make.Queue.Q"); - -- This is the actual Q - - package Busy_Obj_Dirs is new GNAT.HTable.Simple_HTable - (Header_Num => Prj.Header_Num, - Element => Boolean, - No_Element => False, - Key => Path_Name_Type, - Hash => Hash, - Equal => "="); - - Q_First : Natural := 1; - -- Points to the first valid element in the queue - - Q_Processed : Natural := 0; - One_Queue_Per_Obj_Dir : Boolean := False; - Q_Initialized : Boolean := False; - - ------------- - -- Element -- - ------------- - - function Element (Rank : Positive) return File_Name_Type is - begin - if Rank <= Q.Last then - return Q.Table (Rank).File; - else - return No_File; - end if; - end Element; - - ------------- - -- Extract -- - ------------- - - -- This body needs commenting ??? - - procedure Extract - (Source_File_Name : out File_Name_Type; - Source_Unit : out Unit_Name_Type; - Source_Index : out Int) - is - Found : Boolean := False; - - begin - if One_Queue_Per_Obj_Dir then - for J in Q_First .. Q.Last loop - if not Q.Table (J).Processed - and then (Q.Table (J).Project = No_Project - or else not - Busy_Obj_Dirs.Get - (Q.Table (J).Project.Object_Directory.Name)) - then - Found := True; - Source_File_Name := Q.Table (J).File; - Source_Unit := Q.Table (J).Unit; - Source_Index := Q.Table (J).Index; - Q.Table (J).Processed := True; - - if J = Q_First then - while Q_First <= Q.Last - and then Q.Table (Q_First).Processed - loop - Q_First := Q_First + 1; - end loop; - end if; - - exit; - end if; - end loop; - - elsif Q_First <= Q.Last then - Source_File_Name := Q.Table (Q_First).File; - Source_Unit := Q.Table (Q_First).Unit; - Source_Index := Q.Table (Q_First).Index; - Q.Table (Q_First).Processed := True; - Q_First := Q_First + 1; - Found := True; - end if; - - if Found then - Q_Processed := Q_Processed + 1; - else - Source_File_Name := No_File; - Source_Unit := No_Unit_Name; - Source_Index := 0; - end if; - - if Found and then Debug.Debug_Flag_Q then - Write_Str (" Q := Q - [ "); - Write_Name (Source_File_Name); - - if Source_Index /= 0 then - Write_Str (", "); - Write_Int (Source_Index); - end if; - - Write_Str (" ]"); - Write_Eol; - - Write_Str (" Q_First ="); - Write_Int (Int (Q_First)); - Write_Eol; - - Write_Str (" Q.Last ="); - Write_Int (Int (Q.Last)); - Write_Eol; - end if; - end Extract; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Queue_Per_Obj_Dir : Boolean) is - begin - if not Q_Initialized then - One_Queue_Per_Obj_Dir := Queue_Per_Obj_Dir; - Q.Init; - Q_Initialized := True; - Q_Processed := 0; - Q_First := 1; - end if; - end Initialize; - - ------------ - -- Insert -- - ------------ - - -- This body needs commenting ??? - - procedure Insert - (Source_File_Name : File_Name_Type; - Project : Project_Id; - Source_Unit : Unit_Name_Type := No_Unit_Name; - Index : Int := 0) - is - begin - Q.Append - ((File => Source_File_Name, - Project => Project, - Unit => Source_Unit, - Index => Index, - Processed => False)); - - if Debug.Debug_Flag_Q then - Write_Str (" Q := Q + [ "); - Write_Name (Source_File_Name); - - if Index /= 0 then - Write_Str (", "); - Write_Int (Index); - end if; - - Write_Str (" ] "); - Write_Eol; - - Write_Str (" Q_First ="); - Write_Int (Int (Q_First)); - Write_Eol; - - Write_Str (" Q.Last ="); - Write_Int (Int (Q.Last)); - Write_Eol; - end if; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty return Boolean is - begin - if Debug.Debug_Flag_P then - Write_Str (" Q := ["); - - for J in Q_First .. Q.Last loop - if not Q.Table (J).Processed then - Write_Str (" "); - Write_Name (Q.Table (J).File); - Write_Eol; - Write_Str (" "); - end if; - end loop; - - Write_Str ("]"); - Write_Eol; - end if; - - return Q_First > Q.Last; - end Is_Empty; - - ------------------------ - -- Is_Virtually_Empty -- - ------------------------ - - function Is_Virtually_Empty return Boolean is - begin - if One_Queue_Per_Obj_Dir then - for J in Q_First .. Q.Last loop - if not Q.Table (J).Processed - and then - (Q.Table (J).Project = No_Project - or else not - Busy_Obj_Dirs.Get - (Q.Table (J).Project.Object_Directory.Name)) - then - return False; - end if; - end loop; - - return True; - - else - return Is_Empty; - end if; - end Is_Virtually_Empty; - - --------------- - -- Processed -- - --------------- - - function Processed return Natural is - begin - return Q_Processed; - end Processed; - - ---------------------- - -- Set_Obj_Dir_Busy -- - ---------------------- - - procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type) is - begin - if One_Queue_Per_Obj_Dir then - Busy_Obj_Dirs.Set (Obj_Dir, True); - end if; - end Set_Obj_Dir_Busy; - - ---------------------- - -- Set_Obj_Dir_Free -- - ---------------------- - - procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type) is - begin - if One_Queue_Per_Obj_Dir then - Busy_Obj_Dirs.Set (Obj_Dir, False); - end if; - end Set_Obj_Dir_Free; - - ---------- - -- Size -- - ---------- - - function Size return Natural is - begin - return Q.Last; - end Size; - - end Queue; - ----------------------------- -- Recursive_Compute_Depth -- ----------------------------- diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 39a8c0d4fd9..871096c8379 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -44,30 +44,6 @@ with GNAT.HTable; package body Makeutl is - type Mark_Key is record - File : File_Name_Type; - Index : Int; - end record; - -- Identify either a mono-unit source (when Index = 0) or a specific unit - -- (index = 1's origin index of unit) in a multi-unit source. - - -- There follow many global undocumented declarations, comments needed ??? - - Max_Mask_Num : constant := 2048; - - subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1; - - function Hash (Key : Mark_Key) return Mark_Num; - - package Marks is new GNAT.HTable.Simple_HTable - (Header_Num => Mark_Num, - Element => Boolean, - No_Element => False, - Key => Mark_Key, - Hash => Hash, - Equal => "="); - -- A hash table to keep tracks of the marked units - type Linker_Options_Data is record Project : Project_Id; Options : String_List_Id; @@ -520,15 +496,6 @@ package body Makeutl is return Name_Find; end Create_Name; - ---------------------- - -- Delete_All_Marks -- - ---------------------- - - procedure Delete_All_Marks is - begin - Marks.Reset; - end Delete_All_Marks; - ---------------------------- -- Executable_Prefix_Path -- ---------------------------- @@ -817,15 +784,6 @@ package body Makeutl is end if; end Get_Switches; - ---------- - -- Hash -- - ---------- - - function Hash (Key : Mark_Key) return Mark_Num is - begin - return Union_Id (Key.File) mod Max_Mask_Num; - end Hash; - ------------ -- Inform -- ------------ @@ -893,18 +851,6 @@ package body Makeutl is Declaration => Argv (Start .. Finish)); end Is_External_Assignment; - --------------- - -- Is_Marked -- - --------------- - - function Is_Marked - (Source_File : File_Name_Type; - Index : Int := 0) return Boolean - is - begin - return Marks.Get (K => (File => Source_File, Index => Index)); - end Is_Marked; - ----------------------------- -- Linker_Options_Switches -- ----------------------------- @@ -1151,15 +1097,6 @@ package body Makeutl is end Update_Main; end Mains; - ---------- - -- Mark -- - ---------- - - procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is - begin - Marks.Set (K => (File => Source_File, Index => Index), E => True); - end Mark; - ----------------------- -- Path_Or_File_Name -- ----------------------- @@ -1363,6 +1300,10 @@ package body Makeutl is Write_Eol; end Verbose_Msg; + ----------------- + -- Verbose_Msg -- + ----------------- + procedure Verbose_Msg (N1 : File_Name_Type; S1 : String; @@ -1376,4 +1317,414 @@ package body Makeutl is (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity); end Verbose_Msg; + ----------- + -- Queue -- + ----------- + + package body Queue is + type Q_Record is record + Info : Source_Info; + Processed : Boolean; + end record; + + package Q is new Table.Table + (Table_Component_Type => Q_Record, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 100, + Table_Name => "Makeutl.Queue.Q"); + -- This is the actual Queue + + package Busy_Obj_Dirs is new GNAT.HTable.Simple_HTable + (Header_Num => Prj.Header_Num, + Element => Boolean, + No_Element => False, + Key => Path_Name_Type, + Hash => Hash, + Equal => "="); + + type Mark_Key is record + File : File_Name_Type; + Index : Int; + end record; + -- Identify either a mono-unit source (when Index = 0) or a specific + -- unit (index = 1's origin index of unit) in a multi-unit source. + + Max_Mask_Num : constant := 2048; + subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1; + + function Hash (Key : Mark_Key) return Mark_Num; + + package Marks is new GNAT.HTable.Simple_HTable + (Header_Num => Mark_Num, + Element => Boolean, + No_Element => False, + Key => Mark_Key, + Hash => Hash, + Equal => "="); + -- A hash table to keep tracks of the marked units. + -- These are the units that have already been processed, when using the + -- gnatmake format. When using the gprbuild format, we can directly + -- store in the source_id whether the file has already been processed. + + procedure Mark (Source_File : File_Name_Type; Index : Int := 0); + -- Mark a unit, identified by its source file and, when Index is not 0, + -- the index of the unit in the source file. Marking is used to signal + -- that the unit has already been inserted in the Q. + + function Is_Marked + (Source_File : File_Name_Type; + Index : Int := 0) return Boolean; + -- Returns True if the unit was previously marked + + Q_Processed : Natural := 0; + Q_Initialized : Boolean := False; + + Q_First : Natural := 1; + -- Points to the first valid element in the queue + + One_Queue_Per_Obj_Dir : Boolean := False; + -- See parameter to Initialize + + function Available_Obj_Dir (S : Source_Info) return Boolean; + -- Whether the object directory for S is available for a build + + procedure Debug_Display (S : Source_Info); + -- A debug display for S + + function Was_Processed (S : Source_Info) return Boolean; + -- Whether S has already been processed. This marks the source as + -- processed, if it hasn't already been processed. + + ------------------- + -- Was_Processed -- + ------------------- + + function Was_Processed (S : Source_Info) return Boolean is + begin + case S.Format is + when Format_Gprbuild => + if S.Id.In_The_Queue then + return True; + end if; + S.Id.In_The_Queue := True; + + when Format_Gnatmake => + if Is_Marked (S.File, S.Index) then + return True; + end if; + Mark (S.File, Index => S.Index); + end case; + + return False; + end Was_Processed; + + ----------------------- + -- Available_Obj_Dir -- + ----------------------- + + function Available_Obj_Dir (S : Source_Info) return Boolean is + begin + case S.Format is + when Format_Gprbuild => + return not Busy_Obj_Dirs.Get + (S.Id.Project.Object_Directory.Name); + + when Format_Gnatmake => + return S.Project = No_Project + or else + not Busy_Obj_Dirs.Get (S.Project.Object_Directory.Name); + end case; + end Available_Obj_Dir; + + ------------------- + -- Debug_Display -- + ------------------- + + procedure Debug_Display (S : Source_Info) is + begin + case S.Format is + when Format_Gprbuild => + Write_Name (S.Id.File); + + if S.Id.Index /= 0 then + Write_Str (", "); + Write_Int (S.Id.Index); + end if; + + when Format_Gnatmake => + Write_Name (S.File); + + if S.Index /= 0 then + Write_Str (", "); + Write_Int (S.Index); + end if; + end case; + end Debug_Display; + + ---------- + -- Hash -- + ---------- + + function Hash (Key : Mark_Key) return Mark_Num is + begin + return Union_Id (Key.File) mod Max_Mask_Num; + end Hash; + + --------------- + -- Is_Marked -- + --------------- + + function Is_Marked + (Source_File : File_Name_Type; + Index : Int := 0) return Boolean is + begin + return Marks.Get (K => (File => Source_File, Index => Index)); + end Is_Marked; + + ---------- + -- Mark -- + ---------- + + procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is + begin + Marks.Set (K => (File => Source_File, Index => Index), E => True); + end Mark; + + ------------- + -- Extract -- + ------------- + + procedure Extract + (Found : out Boolean; + Source : out Source_Info) is + begin + Found := False; + + if One_Queue_Per_Obj_Dir then + for J in Q_First .. Q.Last loop + if not Q.Table (J).Processed + and then Available_Obj_Dir (Q.Table (J).Info) + then + Found := True; + Source := Q.Table (J).Info; + Q.Table (J).Processed := True; + + if J = Q_First then + while Q_First <= Q.Last + and then Q.Table (Q_First).Processed + loop + Q_First := Q_First + 1; + end loop; + end if; + + exit; + end if; + end loop; + + elsif Q_First <= Q.Last then + Source := Q.Table (Q_First).Info; + Q.Table (Q_First).Processed := True; + Q_First := Q_First + 1; + Found := True; + end if; + + if Found then + Q_Processed := Q_Processed + 1; + end if; + + if Found and then Debug.Debug_Flag_Q then + Write_Str (" Q := Q - [ "); + Debug_Display (Source); + Write_Str (" ]"); + Write_Eol; + + Write_Str (" Q_First ="); + Write_Int (Int (Q_First)); + Write_Eol; + + Write_Str (" Q.Last ="); + Write_Int (Int (Q.Last)); + Write_Eol; + end if; + end Extract; + + --------------- + -- Processed -- + --------------- + + function Processed return Natural is + begin + return Q_Processed; + end Processed; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Queue_Per_Obj_Dir : Boolean; + Force : Boolean := False) is + begin + if Force or else not Q_Initialized then + Q_Initialized := True; + + for J in 1 .. Q.Last loop + case Q.Table (J).Info.Format is + when Format_Gprbuild => + Q.Table (J).Info.Id.In_The_Queue := False; + when Format_Gnatmake => + null; + end case; + end loop; + + Q.Init; + Q_Processed := 0; + Q_First := 1; + One_Queue_Per_Obj_Dir := Queue_Per_Obj_Dir; + end if; + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert (Source : Source_Info) return Boolean is + begin + -- Only insert in the Q if it is not already done, to avoid + -- simultaneous compilations if -jnnn is used. + + if Was_Processed (Source) then + return False; + end if; + + if Current_Verbosity = High then + Write_Str ("Adding """); + Debug_Display (Source); + Write_Line (" to the queue"); + end if; + + Q.Append (New_Val => (Info => Source, Processed => False)); + + if Debug.Debug_Flag_Q then + Write_Str (" Q := Q + [ "); + Debug_Display (Source); + Write_Str (" ] "); + Write_Eol; + + Write_Str (" Q_First ="); + Write_Int (Int (Q_First)); + Write_Eol; + + Write_Str (" Q.Last ="); + Write_Int (Int (Q.Last)); + Write_Eol; + end if; + + return True; + end Insert; + + ------------ + -- Insert -- + ------------ + + procedure Insert (Source : Source_Info) is + Tmp : Boolean; + pragma Unreferenced (Tmp); + begin + Tmp := Insert (Source); + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty return Boolean is + begin + return Q_Processed >= Q.Last; + end Is_Empty; + + ------------------------ + -- Is_Virtually_Empty -- + ------------------------ + + function Is_Virtually_Empty return Boolean is + begin + if One_Queue_Per_Obj_Dir then + for J in Q_First .. Q.Last loop + if not Q.Table (J).Processed + and then Available_Obj_Dir (Q.Table (J).Info) + then + return False; + end if; + end loop; + + return True; + + else + return Is_Empty; + end if; + end Is_Virtually_Empty; + + ---------------------- + -- Set_Obj_Dir_Busy -- + ---------------------- + + procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type) is + begin + if One_Queue_Per_Obj_Dir then + Busy_Obj_Dirs.Set (Obj_Dir, True); + end if; + end Set_Obj_Dir_Busy; + + ---------------------- + -- Set_Obj_Dir_Free -- + ---------------------- + + procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type) is + begin + if One_Queue_Per_Obj_Dir then + Busy_Obj_Dirs.Set (Obj_Dir, False); + end if; + end Set_Obj_Dir_Free; + + ---------- + -- Size -- + ---------- + + function Size return Natural is + begin + return Q.Last; + end Size; + + ------------- + -- Element -- + ------------- + + function Element (Rank : Positive) return File_Name_Type is + begin + if Rank <= Q.Last then + case Q.Table (Rank).Info.Format is + when Format_Gprbuild => + return Q.Table (Rank).Info.Id.File; + when Format_Gnatmake => + return Q.Table (Rank).Info.File; + end case; + else + return No_File; + end if; + end Element; + + ------------------ + -- Remove_Marks -- + ------------------ + + procedure Remove_Marks is + begin + Marks.Reset; + end Remove_Marks; + + end Queue; + end Makeutl; diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 6e23e567c7e..a59139563f8 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -250,21 +250,86 @@ package Makeutl is end Mains; - ---------------------- - -- Marking Routines -- - ---------------------- + ----------- + -- Queue -- + ----------- - procedure Mark (Source_File : File_Name_Type; Index : Int := 0); - -- Mark a unit, identified by its source file and, when Index is not 0, the - -- index of the unit in the source file. Marking is used to signal that the - -- unit has already been inserted in the Q. + type Source_Info_Format is (Format_Gprbuild, Format_Gnatmake); - function Is_Marked - (Source_File : File_Name_Type; - Index : Int := 0) return Boolean; - -- Returns True if the unit was previously marked + package Queue is + -- The queue of sources to be checked for compilation. + -- There can be a single such queue per application. - procedure Delete_All_Marks; - -- Remove all file/index couples marked + type Source_Info (Format : Source_Info_Format := Format_Gprbuild) is + record + case Format is + when Format_Gprbuild => + Id : Source_Id := null; + + when Format_Gnatmake => + File : File_Name_Type := No_File; + Unit : Unit_Name_Type := No_Unit_Name; + Index : Int := 0; + Project : Project_Id := No_Project; + end case; + end record; + -- Information about files stored in the queue. The exact information + -- depends on the builder, and in particular whether it only supports + -- project-based files (in which case we have a full Source_Id record). + + procedure Initialize + (Queue_Per_Obj_Dir : Boolean; + Force : Boolean := False); + -- Initialize the queue. + -- Queue_Per_Obj_Dir matches the --single-compile-per-obj-dir switch: + -- when True, there cannot be simultaneous compilations with the object + -- files in the same object directory when project files are used. + -- + -- Nothing is done if Force is False and the queue was already + -- initialized. + + procedure Remove_Marks; + -- Remove all marks set for the files. + -- This means that the files will be handed to the compiler if they are + -- added to the queue, and is mostly useful when recompiling several + -- executables in non-project mode, as the switches may be different + -- and -s may be in use. + + function Is_Empty return Boolean; + -- Returns True if the queue is empty + + function Is_Virtually_Empty return Boolean; + -- Returns True if the queue is empty or if all object directories are + -- busy. + + procedure Insert (Source : Source_Info); + function Insert (Source : Source_Info) return Boolean; + -- Insert source in the queue. + -- The second version returns False if the Source was already marked in + -- the queue. + + procedure Extract + (Found : out Boolean; + Source : out Source_Info); + -- Get the first source that can be compiled from the queue. If no + -- source may be compiled, sets Found to False. In this case, the value + -- for Source is undefined. + + function Size return Natural; + -- Return the total size of the queue, including the sources already + -- extracted. + + function Processed return Natural; + -- Return the number of source in the queue that have aready been + -- processed. + + procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type); + procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type); + -- Mark Obj_Dir as busy or free (see the parameter to Initialize) + + function Element (Rank : Positive) return File_Name_Type; + -- Get the file name for element of index Rank in the queue + + end Queue; end Makeutl; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index c37a086b517..8f2376d7bb4 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4639,6 +4639,7 @@ package body Sem_Ch3 is Nb_Index : Nat; P : constant Node_Id := Parent (Def); Priv : Entity_Id; + T_In_ALFA : Boolean := True; begin if Nkind (Def) = N_Constrained_Array_Definition then @@ -4665,6 +4666,12 @@ package body Sem_Ch3 is Check_SPARK_Restriction ("subtype mark required", Index); end if; + if Present (Etype (Index)) + and then not Is_In_ALFA (Etype (Index)) + then + T_In_ALFA := False; + end if; + -- Add a subtype declaration for each index of private array type -- declaration whose etype is also private. For example: @@ -4740,10 +4747,18 @@ package body Sem_Ch3 is Check_SPARK_Restriction ("subtype mark required", Component_Typ); end if; + if Present (Element_Type) + and then not Is_In_ALFA (Element_Type) + then + T_In_ALFA := False; + end if; + -- Ada 2005 (AI-230): Access Definition case else pragma Assert (Present (Access_Definition (Component_Def))); + T_In_ALFA := False; + -- Indicate that the anonymous access type is created by the -- array type declaration. @@ -4820,6 +4835,12 @@ package body Sem_Ch3 is (Implicit_Base, Finalize_Storage_Only (Element_Type)); + -- Final check for static bounds on array + + if not Has_Static_Array_Bounds (T) then + T_In_ALFA := False; + end if; + -- Unconstrained array case else @@ -4844,6 +4865,7 @@ package body Sem_Ch3 is Set_Component_Type (Base_Type (T), Element_Type); Set_Packed_Array_Type (T, Empty); + Set_Is_In_ALFA (T, T_In_ALFA); if Aliased_Present (Component_Definition (Def)) then Check_SPARK_Restriction diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 8d8980e194b..59d86593927 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5550,6 +5550,69 @@ package body Sem_Util is end if; end Has_Private_Component; + ----------------------------- + -- Has_Static_Array_Bounds -- + ----------------------------- + + function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is + Ndims : constant Nat := Number_Dimensions (Typ); + + Index : Node_Id; + Low : Node_Id; + High : Node_Id; + + begin + -- Unconstrained types do not have static bounds + + if not Is_Constrained (Typ) then + return False; + end if; + + -- First treat specially string literals, as the lower bound and length + -- of string literals are not stored like those of arrays. + + -- A string literal always has static bounds + + if Ekind (Typ) = E_String_Literal_Subtype then + return True; + end if; + + -- Treat all dimensions in turn + + Index := First_Index (Typ); + for Indx in 1 .. Ndims loop + + -- In case of an erroneous index which is not a discrete type, return + -- that the type is not static. + + if not Is_Discrete_Type (Etype (Index)) + or else Etype (Index) = Any_Type + then + return False; + end if; + + Get_Index_Bounds (Index, Low, High); + + if Error_Posted (Low) or else Error_Posted (High) then + return False; + end if; + + if Is_OK_Static_Expression (Low) + and then Is_OK_Static_Expression (High) + then + null; + else + return False; + end if; + + Next (Index); + end loop; + + -- If we fall through the loop, all indexes matched + + return True; + end Has_Static_Array_Bounds; + ---------------- -- Has_Stream -- ---------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 3d11069f476..ceba869804b 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -624,6 +624,9 @@ package Sem_Util is -- Check if a type has a (sub)component of a private type that has not -- yet received a full declaration. + function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean; + -- Return whether an array type has static bounds + function Has_Stream (T : Entity_Id) return Boolean; -- Tests if type T is derived from Ada.Streams.Root_Stream_Type, or in the -- case of a composite type, has a component for which this predicate is