[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:
parent
98c99a5a37
commit
e280f98126
|
@ -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.
|
||||
|
|
|
@ -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 --
|
||||
----------------------
|
||||
|
|
|
@ -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
440
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 --
|
||||
-----------------------------
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 --
|
||||
----------------
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue