OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2011-08-03  Emmanuel Briot  <briot@adacore.com>

	* make.adb, makeutl.adb, makeutl.ads, clean.adb (Makeutl.Queue): new
	package.

2011-08-03  Yannick Moy  <moy@adacore.com>

	* 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
This commit is contained in:
Arnaud Charlet 2011-08-03 12:45:20 +02:00
parent 98c99a5a37
commit e280f98126
9 changed files with 667 additions and 551 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/ada/ChangeLog
View File

@ -1,3 +1,15 @@
2011-08-03 Emmanuel Briot <briot@adacore.com>
* make.adb, makeutl.adb, makeutl.ads, clean.adb (Makeutl.Queue): new
package.
2011-08-03 Yannick Moy <moy@adacore.com>
* 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 <quinot@adacore.com>
* exp_dist.adb: Minor reformatting.

109
gcc/ada/clean.adb
View File

@ -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 --
----------------------

1
gcc/ada/cstand.adb
View File

@ -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);

440
gcc/ada/make.adb
View File

@ -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 --
-----------------------------

477
gcc/ada/makeutl.adb
View File

@ -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;

91
gcc/ada/makeutl.ads
View File

@ -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;

22
gcc/ada/sem_ch3.adb
View File

@ -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

63
gcc/ada/sem_util.adb
View File

@ -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 --
----------------

3
gcc/ada/sem_util.ads
View File

@ -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