+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.
-- 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 --
-----------------------------
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.
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);
+
+ 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 Empty_Q loop
+ 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
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;
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 --
---------------
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 --
----------------
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 --
----------------------
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);
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;
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.
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;
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;
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;
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
-- 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;
-- 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,
-- 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;
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
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,
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");
Lib_File :=
Osint.Lib_File_Name
- (Full_Source_File, Source_Index);
+ (Full_Source_File, Source.Index);
Full_Lib_File := Lib_File;
else
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);
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);
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;
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
(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
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 --
-----------------------------
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;
return Name_Find;
end Create_Name;
- ----------------------
- -- Delete_All_Marks --
- ----------------------
-
- procedure Delete_All_Marks is
- begin
- Marks.Reset;
- end Delete_All_Marks;
-
----------------------------
-- Executable_Prefix_Path --
----------------------------
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 --
------------
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 --
-----------------------------
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 --
-----------------------
Write_Eol;
end Verbose_Msg;
+ -----------------
+ -- Verbose_Msg --
+ -----------------
+
procedure Verbose_Msg
(N1 : File_Name_Type;
S1 : String;
(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;
end Mains;
- ----------------------
- -- Marking Routines --
- ----------------------
-
- 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
-
- procedure Delete_All_Marks;
- -- Remove all file/index couples marked
+ -----------
+ -- Queue --
+ -----------
+
+ type Source_Info_Format is (Format_Gprbuild, Format_Gnatmake);
+
+ package Queue is
+ -- The queue of sources to be checked for compilation.
+ -- There can be a single such queue per application.
+
+ 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;
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
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:
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.
(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
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
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 --
----------------
-- 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
projects / gcc.git / commitdiff