+2011-08-03 Yannick Moy <moy@adacore.com>
+
+ * sem_ch4.adb (Analyze_Conditional_Expression): only allow boolean
+ conditional expression in ALFA.
+ * sem_res.adb (Resolve_Conditional_Expression): mark non-boolean
+ expressions as not in ALFA.
+
+2011-08-03 Robert Dewar <dewar@adacore.com>
+
+ * a-cofove.adb: Minor reformatting.
+
+2011-08-03 Emmanuel Briot <briot@adacore.com>
+
+ * make.adb, prj.adb, prj.ads, makeutl.adb, makeutl.ads
+ (Insert_Project_Sources, Insert_withed_Sources_For): moved from the
+ gprbuild sources.
+ These packages are more logically placed in the Queue package, since
+ they manipulate the queue. It is also likely that they can be adapted
+ for gnatmake, thus sharing more code.
+ (Finish_Program, Fail_Program): moved from the gprbuild sources, so
+ that we could move the above.
+
+2011-08-03 Emmanuel Briot <briot@adacore.com>
+
+ * errutil.adb (Finalize): clean up the list of error messages on exit.
+ Calling this subprogram multiple times will no longer show duplicate
+ error messages on stderr.
+
+2011-08-03 Emmanuel Briot <briot@adacore.com>
+
+ * g-comlin.adb, g-comlin.ads (Set_Command_Line): ignore the parameter
+ Getopt_Switches when we have already define a command line
+ configuration.
+
2011-08-03 Yannick Moy <moy@adacore.com>
* sem_ch11.adb (Analyze_Raise_xxx_Error): do not mark such nodes as not
function "&" (Left, Right : Vector) return Vector is
LN : constant Count_Type := Length (Left);
RN : constant Count_Type := Length (Right);
- begin
+ begin
if LN = 0 then
if RN = 0 then
return Empty_Vector;
declare
E : constant Elements_Array (1 .. Length (Right)) :=
- Right.Elements (1 .. RN);
+ Right.Elements (1 .. RN);
begin
- return (Length (Right), E,
- Last => Right.Last, others => <>);
+ return (Length (Right), E, Last => Right.Last, others => <>);
end;
end if;
if RN = 0 then
declare
E : constant Elements_Array (1 .. Length (Left)) :=
- Left.Elements (1 .. LN);
+ Left.Elements (1 .. LN);
begin
- return (Length (Left), E,
- Last => Left.Last, others => <>);
+ return (Length (Left), E, Last => Left.Last, others => <>);
end;
-
end if;
declare
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
- LE : constant Elements_Array (1 .. LN) :=
- Left.Elements (1 .. LN);
-
+ LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN);
RE : Elements_Array renames Right.Elements (1 .. RN);
Capacity : constant Count_Type := Length (Left) + Length (Right);
begin
- return (Capacity, LE & RE,
- Last => Last, others => <>);
+ return (Capacity, LE & RE, Last => Last, others => <>);
end;
end;
end "&";
begin
if LN = 0 then
- return (1, (1 .. 1 => Right),
- Index_Type'First, others => <>);
+ return (1, (1 .. 1 => Right), Index_Type'First, others => <>);
end if;
if Int (Index_Type'First) > Int'Last - Int (LN) then
declare
Last : constant Index_Type := Index_Type (Last_As_Int);
-
- LE : constant Elements_Array (1 .. LN) :=
- Left.Elements (1 .. LN);
+ LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN);
Capacity : constant Count_Type := Length (Left) + 1;
begin
- return (Capacity, LE & Right,
- Last => Last, others => <>);
+ return (Capacity, LE & Right, Last => Last, others => <>);
end;
-
end "&";
function "&" (Left : Element_Type; Right : Vector) return Vector is
end if;
declare
- Last : constant Index_Type := Index_Type (Last_As_Int);
-
- RE : Elements_Array renames Right.Elements (1 .. RN);
-
+ Last : constant Index_Type := Index_Type (Last_As_Int);
+ RE : Elements_Array renames Right.Elements (1 .. RN);
Capacity : constant Count_Type := 1 + Length (Right);
-
begin
- return (Capacity, Left & RE,
- Last => Last, others => <>);
+ return (Capacity, Left & RE, Last => Last, others => <>);
end;
end "&";
declare
Last : constant Index_Type := Index_Type'First + 1;
-
begin
- return (2, (Left, Right),
- Last => Last, others => <>);
+ return (2, (Left, Right), Last => Last, others => <>);
end;
end "&";
procedure Append (Container : in out Vector; New_Item : Vector) is
begin
-
if Is_Empty (New_Item) then
return;
end if;
raise Constraint_Error with "vector is already at its maximum length";
end if;
- Insert
- (Container,
- Container.Last + 1,
- New_Item);
+ Insert (Container, Container.Last + 1, New_Item);
end Append;
procedure Append
Count : Count_Type := 1)
is
begin
-
if Count = 0 then
return;
end if;
-- TODO: should check whether length > max capacity (cnt_t'last) ???
- Insert
- (Container,
- Container.Last + 1,
- New_Item,
- Count);
+ Insert (Container, Container.Last + 1, New_Item, Count);
end Append;
------------
procedure Assign (Target : in out Vector; Source : Vector) is
LS : constant Count_Type := Length (Source);
- begin
+ begin
if Target'Address = Source'Address then
return;
end if;
Target.Clear;
- Target.Elements (1 .. LS) :=
- Source.Elements (1 .. LS);
- Target.Last := Source.Last;
-
+ Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
+ Target.Last := Source.Last;
end Assign;
--------------
procedure Clear (Container : in out Vector) is
begin
-
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
begin
if Capacity = 0 then
C := LS;
-
elsif Capacity >= LS then
C := Capacity;
-
else
raise Constraint_Error;
end if;
- return Target : Vector (C) do
- Target.Elements (1 .. LS) :=
- Source.Elements (1 .. LS);
+ return Target : Vector (C) do
+ Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
Target.Last := Source.Last;
-
end return;
end Copy;
Count : Count_Type := 1)
is
begin
-
if Index < Index_Type'First then
raise Constraint_Error with "Index is out of range (too small)";
end if;
declare
I_As_Int : constant Int := Int (Index);
- Old_Last_As_Int : constant Int :=
- Index_Type'Pos (Container.Last);
+ Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
Count1 : constant Int'Base := Count_Type'Pos (Count);
Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
Count : Count_Type := 1)
is
begin
-
if not Position.Valid then
raise Constraint_Error with "Position cursor has no element";
end if;
Count : Count_Type := 1)
is
begin
-
if Count = 0 then
return;
end if;
Index : Int'Base;
begin
-
if Count = 0 then
return;
end if;
declare
II : constant Int'Base := Int (Index) - Int (No_Index);
I : constant Count_Type := Count_Type (II);
-
begin
-
return Get_Element (Container, I);
end;
end Element;
Position : Cursor) return Element_Type
is
Lst : constant Index_Type := Last_Index (Container);
+
begin
if not Position.Valid then
raise Constraint_Error with "Position cursor has no element";
declare
II : constant Int'Base := Int (Position.Index) - Int (No_Index);
I : constant Count_Type := Count_Type (II);
-
begin
-
return Get_Element (Container, I);
end;
end Element;
Last : constant Index_Type := Last_Index (Container);
begin
-
if Position.Valid then
if Position.Index > Last_Index (Container) then
raise Program_Error with "Position index is out of range";
if Get_Element (Container, K) = Item then
return Cursor'(Index => J, others => <>);
end if;
+
K := K + 1;
end loop;
return No_Element;
-
end Find;
----------------
if Get_Element (Container, K) = Item then
return Indx;
end if;
+
K := K + 1;
end loop;
function Is_Sorted (Container : Vector) return Boolean is
Last : constant Index_Type := Last_Index (Container);
- begin
+ begin
if Container.Last <= Last then
return True;
end if;
declare
L : constant Capacity_Subtype := Length (Container);
begin
-
for J in Count_Type range 1 .. L - 1 loop
- if Get_Element (Container, J + 1)
- < Get_Element (Container, J) then
+ if Get_Element (Container, J + 1) <
+ Get_Element (Container, J)
+ then
return False;
end if;
end loop;
end if;
-- I think we're missing this check in a-convec.adb... ???
+
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
return;
end if;
- pragma Assert (I <= 1
- or else not (TA (I) < TA (I - 1)));
+ pragma Assert (I <= 1 or else not (TA (I) < TA (I - 1)));
if SA (Length (Source)) < TA (I) then
TA (J) := TA (I);
Element_Type => Element_Type,
Array_Type => Elements_Array,
"<" => "<");
- begin
+ begin
if Container.Last <= Index_Type'First then
return;
end if;
function Get_Element
(Container : Vector;
- Position : Count_Type) return Element_Type is
+ Position : Count_Type) return Element_Type
+ is
begin
-
return Container.Elements (Position);
-
end Get_Element;
-----------------
function Has_Element
(Container : Vector;
- Position : Cursor) return Boolean is
+ Position : Cursor) return Boolean
+ is
begin
if not Position.Valid then
return False;
+ else
+ return Position.Index <= Last_Index (Container);
end if;
-
- return Position.Index <= Last_Index (Container);
end Has_Element;
------------
Max_Length : constant UInt := UInt (Container.Capacity);
begin
-
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
declare
II : constant Int'Base := BB + N;
I : constant Count_Type := Count_Type (II);
-
begin
EA (I .. L) := EA (B .. Length (Container));
EA (B .. I - 1) := (others => New_Item);
N : constant Count_Type := Length (New_Item);
begin
-
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
B : constant Count_Type := Count_Type (BB);
begin
-
if Container'Address /= New_Item'Address then
- Container.Elements (B .. Dst_Last) :=
- New_Item.Elements (1 .. N);
-
+ Container.Elements (B .. Dst_Last) := New_Item.Elements (1 .. N);
return;
end if;
declare
Src : Elements_Array renames
- Container.Elements
- (Dst_Last + 1 .. Length (Container));
+ Container.Elements (Dst_Last + 1 .. Length (Container));
Index_As_Int : constant Int'Base :=
Dst_Last_As_Int - Src'Length + 1;
Index : Index_Type'Base;
begin
-
if Is_Empty (New_Item) then
return;
end if;
Index : Index_Type'Base;
begin
-
if Is_Empty (New_Item) then
if not Before.Valid
or else Before.Index > Container.Last
Index : Index_Type'Base;
begin
-
if Count = 0 then
return;
end if;
Index : Index_Type'Base;
begin
-
if Count = 0 then
if not Before.Valid
or else Before.Index > Container.Last
is
New_Item : Element_Type; -- Default-initialized value
pragma Warnings (Off, New_Item);
-
begin
Insert (Container, Before, New_Item, Position, Count);
end Insert;
Max_Length : constant UInt := UInt (Count_Type'Last);
begin
-
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
declare
II : constant Int'Base := BB + N;
I : constant Count_Type := Count_Type (II);
-
begin
EA (I .. L) := EA (B .. Length (Container));
end;
Index : Index_Type'Base;
begin
-
if Count = 0 then
if not Before.Valid
or else Before.Index > Container.Last
----------
function Left (Container : Vector; Position : Cursor) return Vector is
- C : Vector (Container.Capacity) :=
- Copy (Container, Container.Capacity);
+ C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
+
begin
if Position = No_Element then
return C;
end if;
+
if not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
declare
II : constant Int'Base := Int (Position.Index) - Int (No_Index);
I : constant Count_Type := Count_Type (II);
-
begin
Container.Elements (I) := New_Item;
end;
Capacity : Capacity_Subtype)
is
begin
-
if Capacity > Container.Capacity then
raise Constraint_Error; -- ???
end if;
procedure Reverse_Elements (Container : in out Vector) is
begin
-
if Length (Container) <= 1 then
return;
end if;
while I < J loop
declare
EI : constant Element_Type := E (I);
-
begin
E (I) := E (J);
E (J) := EI;
K : Count_Type;
begin
-
if not Position.Valid
or else Position.Index > Last_Index (Container)
then
if Get_Element (Container, K) = Item then
return (True, Indx);
end if;
+
K := K - 1;
end loop;
if Get_Element (Container, K) = Item then
return Indx;
end if;
+
K := K - 1;
end loop;
procedure Reverse_Iterate
(Container : Vector;
- Process :
- not null access procedure (Container : Vector; Position : Cursor))
+ Process : not null access procedure (Container : Vector;
+ Position : Cursor))
is
V : Vector renames Container'Unrestricted_Access.all;
B : Natural renames V.Busy;
-----------
function Right (Container : Vector; Position : Cursor) return Vector is
- C : Vector (Container.Capacity) :=
- Copy (Container, Container.Capacity);
+ C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
+
begin
if Position = No_Element then
Clear (C);
return C;
end if;
+
if not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
while C.Last /= Container.Last - Position.Index + 1 loop
Delete_First (C);
end loop;
+
return C;
end Right;
Length : Capacity_Subtype)
is
begin
-
if Length = Formal_Vectors.Length (Container) then
return;
end if;
procedure Swap (Container : in out Vector; I, J : Index_Type) is
begin
-
if I > Container.Last then
raise Constraint_Error with "I index is out of range";
end if;
procedure Swap (Container : in out Vector; I, J : Cursor) is
begin
-
if not I.Valid then
raise Constraint_Error with "I cursor has no element";
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
Warnings_Detected := 0;
end if;
+
+ -- Prevent displaying the same messages again in the future
+
+ First_Error_Msg := No_Error_Msg;
end Finalize;
----------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
+-- In particular, you can freely distribute your programs built with the --
+-- GNAT Pro compiler, including any required library run-time units, using --
+-- any licensing terms of your choosing. See the AdaCore Software License --
+-- for full details. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
(Config : Command_Line_Configuration;
Section : String);
-- Iterate over all switches defined in Config, for a specific section.
- -- Index is set to the index in Config.Switches
+ -- Index is set to the index in Config.Switches.
+ -- Stop iterating when Callback returns False.
--------------
-- Argument --
Unchecked_Free (Tmp);
end if;
+ if Switch.Switch /= null and then Switch.Switch.all = "*" then
+ Config.Star_Switch := True;
+ end if;
+
Config.Switches (Config.Switches'Last) := Switch;
end Add;
loop
begin
- S := Getopt (Switches => "* " & Getopt_Description,
- Concatenate => False,
- Parser => Parser);
+ if Cmd.Config /= null then
+ -- Do not use Getopt_Description in this case. Otherwise,
+ -- if we have defined a prefix -gnaty, and two switches
+ -- -gnatya and -gnatyL!, we would have a different behavior
+ -- depending on the order of switches:
+ -- -gnatyL1a => -gnatyL with argument "1a"
+ -- -gnatyaL1 => -gnatya and -gnatyL with argument "1"
+ -- This is because the call to Getopt below knows nothing
+ -- about prefixes, and in the first case finds a valid
+ -- switch with arguments, so returns it without analyzing
+ -- the argument. In the second case, the switch matches "*",
+ -- and is then decomposed below.
+
+ S := Getopt (Switches => "*",
+ Concatenate => False,
+ Parser => Parser);
+ else
+ S := Getopt (Switches => "* " & Getopt_Description,
+ Concatenate => False,
+ Parser => Parser);
+ end if;
+
exit when S = ASCII.NUL;
declare
function Analyze_Simple_Switch
(Switch : String; Index : Integer) return Boolean;
+ -- "Switches" is one of the switch definitions passed to the
+ -- configuration, not one of the switches found on the command line.
---------------------------
-- Analyze_Simple_Switch --
pragma Unreferenced (Index);
Full : constant String := Prefix & Group (Idx .. Group'Last);
+
Sw : constant String := Actual_Switch (Switch);
+ -- Switches definition minus argument definition
+
Last : Natural;
Param : Natural;
begin
- if Sw'Length >= Prefix'Length
-
- -- Verify that sw starts with Prefix
-
- and then Looking_At (Sw, Sw'First, Prefix)
-
- -- Verify that the group starts with sw
+ if
+ -- Verify that sw starts with Prefix
+ Looking_At (Sw, Sw'First, Prefix)
+ -- Verify that the group starts with sw
and then Looking_At (Full, Full'First, Sw)
+
then
Last := Idx + Sw'Length - Prefix'Length - 1;
Param := Last + 1;
if Can_Have_Parameter (Switch) then
-
-- Include potential parameter to the recursive call.
-- Only numbers are allowed.
-- First determine if the switch corresponds to one belonging to the
-- configuration. If so, run callback and exit.
- Foreach_In_Config (Config, Section);
+ -- ??? Is this necessary. On simple tests, we seem to have the same
+ -- results with or without this call.
+ Foreach_In_Config (Config, Section);
if Found_In_Config then
return;
end if;
Param : String;
Index : Integer)
is
- pragma Unreferenced (Index);
Sep : Character;
begin
+ if Index = -1
+ and then Cmd.Config /= null
+ and then not Cmd.Config.Star_Switch
+ then
+ raise Invalid_Switch
+ with "Invalid switch " & Simple;
+ end if;
+
if Separator = "" then
Sep := ASCII.NUL;
else
if Iter.List = null then
Iter.Current := Integer'Last;
else
- Iter.Current := Iter.List'First;
-
- while Iter.Current <= Iter.List'Last
- and then Iter.List (Iter.Current) = null
- loop
- Iter.Current := Iter.Current + 1;
- end loop;
+ Iter.Current := Iter.List'First - 1;
+ Next (Iter);
end if;
end Start;
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2010, AdaCore --
+-- Copyright (C) 1999-2011, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- assumed that the remainder of the switch ("uv") is a set of characters
-- whose order is irrelevant. In fact, this package will sort them
-- alphabetically.
+ -- When grouping switches that accept arguments (for instance "-gnatyL!"
+ -- as the definition, and "-gnatyaL12b" as the command line), only
+ -- numerical arguments are accepted. The above is equivalent to
+ -- "-gnatya -gnatyL12 -gnatyb".
procedure Define_Switch
(Config : in out Command_Line_Configuration;
Config : Command_Line_Configuration);
function Get_Configuration
(Cmd : Command_Line) return Command_Line_Configuration;
- -- Set or retrieve the configuration used for that command line
+ -- Set or retrieve the configuration used for that command line.
+ -- The Config must have been initialized first, by calling one of the
+ -- Define_Switches subprograms.
procedure Set_Command_Line
(Cmd : in out Command_Line;
-- The parsing of Switches is done through calls to Getopt, by passing
-- Getopt_Description as an argument. (A "*" is automatically prepended so
-- that all switches and command line arguments are accepted).
+ -- If a config was defined via Set_Configuration, the Getopt_Description
+ -- parameter will be ignored.
--
-- To properly handle switches that take parameters, you should document
-- them in Getopt_Description. Otherwise, the switch and its parameter will
-- should be listed in the Sections parameter (as "-bargs -cargs").
--
-- This function can be used to reset Cmd by passing an empty string.
+ --
+ -- If an invalid switch is found on the command line (ie wasn't defined in
+ -- the configuration via Define_Switch), and the configuration wasn't set
+ -- to accept all switches (by defining "*" as a valid switch), then an
+ -- exception Invalid_Switch is raised. The exception message indicates the
+ -- invalid switch.
procedure Add_Switch
(Cmd : in out Command_Line;
Sections : GNAT.OS_Lib.Argument_List_Access;
-- The list of sections
+ Star_Switch : Boolean := False;
+ -- Whether switches not described in this configuration should be
+ -- returned to the user (True). If False, an exception Invalid_Switch
+ -- is raised.
+
Aliases : Alias_Definitions_List;
Usage : GNAT.OS_Lib.String_Access;
Help : GNAT.OS_Lib.String_Access;
-- Delete all temp files created by Gnatmake and call Osint.Fail, with the
-- parameter S (see osint.ads). This is called from the Prj hierarchy and
-- the MLib hierarchy.
+ -- This subprogram also prints current error messages on stdout (ie
+ -- finalizes errout)
--------------------------
-- Obsolete Executables --
-- mappings, when using project file(s). The out parameter File_Index is
-- the index to the name of the file in the array The_Mapping_File_Names.
- procedure Delete_Temp_Config_Files;
- -- Delete all temporary config files. Must not be called if Debug_Flag_N
- -- is False.
-
- procedure Delete_All_Temp_Files;
- -- Delete all temp files (config files, mapping files, path files), unless
- -- Debug_Flag_N is True (in which case all temp files are left for user
- -- examination).
-
-------------------------------------------------
-- Subprogram declarations moved from the spec --
-------------------------------------------------
""" is not a gnatmake switch. Consider moving " &
"it to Global_Compilation_Switches.",
Element.Location);
- Errutil.Finalize;
Make_Failed ("*** illegal switch """ & Argv & """");
end if;
end;
-- Delete any temporary configuration pragma file
if not Debug.Debug_Flag_N then
- Delete_Temp_Config_Files;
+ Delete_Temp_Config_Files (Project_Tree);
end if;
end Compile_Sources;
Debug_Msg (S, Name_Id (N));
end Debug_Msg;
- ---------------------------
- -- Delete_All_Temp_Files --
- ---------------------------
-
- procedure Delete_All_Temp_Files is
- begin
- if not Debug.Debug_Flag_N then
- Delete_Temp_Config_Files;
- Prj.Delete_All_Temp_Files (Project_Tree.Shared);
- end if;
- end Delete_All_Temp_Files;
-
- ------------------------------
- -- Delete_Temp_Config_Files --
- ------------------------------
-
- procedure Delete_Temp_Config_Files is
- Success : Boolean;
- Proj : Project_List;
- pragma Warnings (Off, Success);
-
- begin
- -- The caller is responsible for ensuring that Debug_Flag_N is False
-
- pragma Assert (not Debug.Debug_Flag_N);
-
- if Main_Project /= No_Project then
- Proj := Project_Tree.Projects;
- while Proj /= null loop
- if Proj.Project.Config_File_Temp then
- Delete_Temporary_File
- (Project_Tree.Shared, Proj.Project.Config_File_Name);
-
- -- Make sure that we don't have a config file for this project,
- -- in case there are several mains. In this case, we will
- -- recreate another config file: we cannot reuse the one that
- -- we just deleted!
-
- Proj.Project.Config_Checked := False;
- Proj.Project.Config_File_Name := No_Path;
- Proj.Project.Config_File_Temp := False;
- end if;
- Proj := Proj.Next;
- end loop;
- end if;
- end Delete_Temp_Config_Files;
-
-------------
-- Display --
-------------
Write_Line (": no sources to compile");
end if;
- Delete_All_Temp_Files;
- Exit_Program (E_Success);
+ Finish_Program (Project_Tree, E_Success);
end if;
end if;
Bind => Bind_Only,
Link => Link_Only);
- Delete_All_Temp_Files;
- Exit_Program (E_Success);
+ Finish_Program (Project_Tree, E_Success);
else
-- Call Get_Target_Parameters to ensure that VM_Target and
-- Output usage information if no files to compile
Usage;
- Exit_Program (E_Fatal);
+ Finish_Program (Project_Tree, E_Success);
end if;
end if;
"Global_Compilation_Switches. Use Switches instead.",
Project_Tree.Shared.Arrays.Table
(Default_Switches_Array).Location);
- Errutil.Finalize;
Make_Failed
("*** illegal combination of Builder attributes");
end if;
Report_Compilation_Failed;
end if;
- -- Delete the temporary mapping file that was created if we are
- -- using project files.
-
- Delete_All_Temp_Files;
-
- -- Output Namet statistics
-
- Namet.Finalize;
+ Finish_Program (Project_Tree, E_Success);
exception
when X : others =>
procedure Make_Failed (S : String) is
begin
- Delete_All_Temp_Files;
- Osint.Fail (S);
+ Fail_Program (Project_Tree, S);
end Make_Failed;
--------------------
procedure Report_Compilation_Failed is
begin
- Delete_All_Temp_Files;
- Exit_Program (E_Fatal);
+ Fail_Program (Project_Tree, "");
end Report_Compilation_Failed;
------------------------
Kill (Running_Compile (J).Pid, SIGINT, 1);
end loop;
- Delete_All_Temp_Files;
- OS_Exit (1);
- -- ??? OS_Exit (1) is equivalent to Exit_Program (E_No_Compile),
- -- shouldn't that be Exit_Program (E_Abort) instead?
+ Finish_Program (Project_Tree, E_No_Compile);
end Sigint_Intercepted;
-------------------
with ALI; use ALI;
with Debug;
+with Err_Vars; use Err_Vars;
+with Errutil;
with Fname;
with Hostparm;
with Osint; use Osint;
with Opt; use Opt;
with Prj.Ext;
with Prj.Util;
+with Sinput.P;
with Snames; use Snames;
with Table;
with Tempdir;
end;
end Executable_Prefix_Path;
+ ------------------
+ -- Fail_Program --
+ ------------------
+
+ procedure Fail_Program
+ (Project_Tree : Project_Tree_Ref;
+ S : String;
+ Flush_Messages : Boolean := True)
+ is
+ begin
+ if Flush_Messages then
+ if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then
+ Errutil.Finalize;
+ end if;
+ end if;
+
+ Finish_Program (Project_Tree, E_Fatal, S => S);
+ end Fail_Program;
+
+ --------------------
+ -- Finish_Program --
+ --------------------
+
+ procedure Finish_Program
+ (Project_Tree : Project_Tree_Ref;
+ Exit_Code : Osint.Exit_Code_Type := Osint.E_Success;
+ S : String := "")
+ is
+ begin
+ if not Debug.Debug_Flag_N then
+ Delete_Temp_Config_Files (Project_Tree);
+
+ if Project_Tree /= null then
+ Delete_All_Temp_Files (Project_Tree.Shared);
+ end if;
+ end if;
+
+ if S'Length > 0 then
+ if Exit_Code /= E_Success then
+ Osint.Fail (S);
+ else
+ Write_Str (S);
+ end if;
+ end if;
+
+ -- Output Namet statistics
+
+ Namet.Finalize;
+
+ Exit_Program (Exit_Code);
+ end Finish_Program;
+
--------------------------
-- File_Not_A_Source_Of --
--------------------------
Write_Eol;
end Inform;
+ ------------------------------
+ -- Initialize_Source_Record --
+ ------------------------------
+
+ procedure Initialize_Source_Record (Source : Prj.Source_Id) is
+ procedure Set_Object_Project
+ (Obj_Dir : String; Obj_Proj : Project_Id; Obj_Path : Path_Name_Type;
+ Stamp : Time_Stamp_Type);
+ -- Update information about object file, switches file,...
+
+ ------------------------
+ -- Set_Object_Project --
+ ------------------------
+
+ procedure Set_Object_Project
+ (Obj_Dir : String; Obj_Proj : Project_Id; Obj_Path : Path_Name_Type;
+ Stamp : Time_Stamp_Type) is
+ begin
+ Source.Object_Project := Obj_Proj;
+ Source.Object_Path := Obj_Path;
+ Source.Object_TS := Stamp;
+
+ if Source.Language.Config.Dependency_Kind /= None then
+ declare
+ Dep_Path : constant String :=
+ Normalize_Pathname
+ (Name => Get_Name_String (Source.Dep_Name),
+ Resolve_Links => Opt.Follow_Links_For_Files,
+ Directory => Obj_Dir);
+ begin
+ Source.Dep_Path := Create_Name (Dep_Path);
+ Source.Dep_TS := Osint.Unknown_Attributes;
+ end;
+ end if;
+
+ -- Get the path of the switches file, even if Opt.Check_Switches is
+ -- not set, as switch -s may be in the Builder switches that have not
+ -- been scanned yet.
+
+ declare
+ Switches_Path : constant String :=
+ Normalize_Pathname
+ (Name => Get_Name_String (Source.Switches),
+ Resolve_Links => Opt.Follow_Links_For_Files,
+ Directory => Obj_Dir);
+ begin
+ Source.Switches_Path := Create_Name (Switches_Path);
+
+ if Stamp /= Empty_Time_Stamp then
+ Source.Switches_TS := File_Stamp (Source.Switches_Path);
+ end if;
+ end;
+ end Set_Object_Project;
+
+ Obj_Proj : Project_Id;
+
+ begin
+ -- Nothing to do if source record has already been fully initialized
+
+ if Source.Initialized then
+ return;
+ end if;
+
+ -- Systematically recompute the time stamp
+
+ Source.Source_TS := File_Stamp (Source.Path.Display_Name);
+
+ -- Parse the source file to check whether we have a subunit
+
+ if Source.Language.Config.Kind = Unit_Based
+ and then Source.Kind = Impl
+ and then Is_Subunit (Source)
+ then
+ Source.Kind := Sep;
+ end if;
+
+ if Source.Language.Config.Object_Generated
+ and then Is_Compilable (Source)
+ then
+ -- First, get the correct object file name and dependency file name
+ -- if the source is in a multi-unit file.
+
+ if Source.Index /= 0 then
+ Source.Object :=
+ Object_Name
+ (Source_File_Name => Source.File,
+ Source_Index => Source.Index,
+ Index_Separator =>
+ Source.Language.Config.Multi_Unit_Object_Separator,
+ Object_File_Suffix =>
+ Source.Language.Config.Object_File_Suffix);
+
+ Source.Dep_Name :=
+ Dependency_Name
+ (Source.Object, Source.Language.Config.Dependency_Kind);
+ end if;
+
+ -- Find the object file for that source. It could be either in
+ -- the current project or in an extended project (it might actually
+ -- not exist yet in the ultimate extending project, but if not found
+ -- elsewhere that's where we'll expect to find it).
+
+ Obj_Proj := Source.Project;
+ while Obj_Proj /= No_Project loop
+ declare
+ Dir : constant String := Get_Name_String
+ (Obj_Proj.Object_Directory.Display_Name);
+
+ Object_Path : constant String :=
+ Normalize_Pathname
+ (Name =>
+ Get_Name_String (Source.Object),
+ Resolve_Links =>
+ Opt.Follow_Links_For_Files,
+ Directory => Dir);
+
+ Obj_Path : constant Path_Name_Type := Create_Name (Object_Path);
+ Stamp : Time_Stamp_Type := Empty_Time_Stamp;
+
+ begin
+ -- For specs, we do not check object files if there is a body.
+ -- This saves a system call. On the other hand, we do need to
+ -- know the object_path, in case the user has passed the .ads
+ -- on the command line to compile the spec only
+
+ if Source.Kind /= Spec
+ or else Source.Unit = No_Unit_Index
+ or else Source.Unit.File_Names (Impl) = No_Source
+ then
+ Stamp := File_Stamp (Obj_Path);
+ end if;
+
+ if Stamp /= Empty_Time_Stamp
+ or else (Obj_Proj.Extended_By = No_Project
+ and then Source.Object_Project = No_Project)
+ then
+ Set_Object_Project (Dir, Obj_Proj, Obj_Path, Stamp);
+ end if;
+
+ Obj_Proj := Obj_Proj.Extended_By;
+ end;
+ end loop;
+
+ elsif Source.Language.Config.Dependency_Kind = Makefile then
+ declare
+ Object_Dir : constant String :=
+ Get_Name_String
+ (Source.Project.Object_Directory.Display_Name);
+ Dep_Path : constant String :=
+ Normalize_Pathname
+ (Name => Get_Name_String (Source.Dep_Name),
+ Resolve_Links =>
+ Opt.Follow_Links_For_Files,
+ Directory => Object_Dir);
+ begin
+ Source.Dep_Path := Create_Name (Dep_Path);
+ Source.Dep_TS := Osint.Unknown_Attributes;
+ end;
+ end if;
+
+ Source.Initialized := True;
+ end Initialize_Source_Record;
+
----------------------------
-- Is_External_Assignment --
----------------------------
Declaration => Argv (Start .. Finish));
end Is_External_Assignment;
+ ----------------
+ -- Is_Subunit --
+ ----------------
+
+ function Is_Subunit (Source : Prj.Source_Id) return Boolean is
+ Src_Ind : Source_File_Index;
+ begin
+ if Source.Kind = Sep then
+ return True;
+
+ -- A Spec, a file based language source or a body with a spec cannot be
+ -- a subunit.
+
+ elsif Source.Kind = Spec or else
+ Source.Unit = No_Unit_Index or else
+ Other_Part (Source) /= No_Source
+ then
+ return False;
+ end if;
+
+ -- Here, we are assuming that the language is Ada, as it is the only
+ -- unit based language that we know.
+
+ Src_Ind :=
+ Sinput.P.Load_Project_File
+ (Get_Name_String (Source.Path.Display_Name));
+
+ return Sinput.P.Source_File_Is_Subunit (Src_Ind);
+ end Is_Subunit;
+
-----------------------------
-- Linker_Options_Switches --
-----------------------------
package body Mains is
- type File_And_Loc is record
- File_Name : File_Name_Type;
- Index : Int := 0;
- Location : Source_Ptr := No_Location;
- end record;
-
package Names is new Table.Table
- (Table_Component_Type => File_And_Loc,
+ (Table_Component_Type => Main_Info,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 10,
-- Add_Main --
--------------
- procedure Add_Main (Name : String) is
+ procedure Add_Main
+ (Name : String;
+ Index : Int := 0;
+ Location : Source_Ptr := No_Location)
+ is
begin
Name_Len := 0;
Add_Str_To_Name_Buffer (Name);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+
Names.Increment_Last;
- Names.Table (Names.Last) := (Name_Find, 0, No_Location);
+ Names.Table (Names.Last) := (Name_Find, Index, Location, No_Source);
end Add_Main;
+ --------------------------
+ -- Set_Multi_Unit_Index --
+ --------------------------
+
+ procedure Set_Multi_Unit_Index
+ (Project_Tree : Project_Tree_Ref := null;
+ Index : Int := 0) is
+ begin
+ if Index /= 0 then
+ if Names.Last = 0 then
+ Fail_Program
+ (Project_Tree,
+ "cannot specify a multi-unit index but no main " &
+ "on the command line");
+
+ elsif Names.Last > 1 then
+ Fail_Program
+ (Project_Tree,
+ "cannot specify several mains with a multi-unit index");
+
+ else
+ Names.Table (Names.Last).Index := Index;
+ end if;
+ end if;
+ end Set_Multi_Unit_Index;
+
------------
-- Delete --
------------
Mains.Reset;
end Delete;
- ---------------
- -- Get_Index --
- ---------------
+ -----------------------
+ -- FIll_From_Project --
+ -----------------------
- function Get_Index return Int is
+ procedure Fill_From_Project
+ (Root_Project : Project_Id;
+ Project_Tree : Project_Tree_Ref) is
begin
- if Current in Names.First .. Names.Last then
- return Names.Table (Current).Index;
- else
- return 0;
+ if Number_Of_Mains = 0 then
+ declare
+ List : String_List_Id := Root_Project.Mains;
+ Element : String_Element;
+
+ begin
+ if List /= Prj.Nil_String then
+ -- The attribute Main is not an empty list.
+ -- Get the mains in the list
+
+ while List /= Prj.Nil_String loop
+ Element :=
+ Project_Tree.Shared.String_Elements.Table (List);
+
+ Add_Main (Name => Get_Name_String (Element.Value),
+ Index => Element.Index,
+ Location => Element.Location);
+ List := Element.Next;
+ end loop;
+ end if;
+ end;
end if;
- end Get_Index;
- ------------------
- -- Get_Location --
- ------------------
+ -- If there are mains, check that they are sources of the main
+ -- project
+
+ if Mains.Number_Of_Mains > 0 then
+ for J in Names.First .. Names.Last loop
+ declare
+ File : constant Main_Info := Names.Table (J);
+ Main_Id : File_Name_Type := File.File;
+ Main : constant String := Get_Name_String (Main_Id);
+ Project : Project_Id;
+ Source : Prj.Source_Id := No_Source;
+ Suffix : File_Name_Type;
+ Iter : Source_Iterator;
+
+ begin
+ if Base_Name (Main) /= Main then
+ if Is_Absolute_Path (Main) then
+ Main_Id := Create_Name (Base_Name (Main));
- function Get_Location return Source_Ptr is
+ else
+ Fail_Program
+ (Project_Tree,
+ "mains cannot include directory information (""" &
+ Main & """)");
+ end if;
+ end if;
+
+ -- First, look for the main as specified.
+
+ Source := Find_Source
+ (In_Tree => Project_Tree,
+ Project => Project,
+ Base_Name => File.File,
+ Index => File.Index);
+
+ if Source = No_Source then
+ -- Now look for the main with a body suffix
+
+ declare
+ -- Main already has a canonical casing
+ Main : constant String := Get_Name_String (Main_Id);
+ begin
+ Project := Root_Project;
+ while Source = No_Source
+ and then Project /= No_Project
+ loop
+ Iter := For_Each_Source (Project_Tree, Project);
+ loop
+ Source := Prj.Element (Iter);
+ exit when Source = No_Source;
+
+ -- Only consider bodies
+
+ if Source.Kind = Impl then
+ Get_Name_String (Source.File);
+
+ if Name_Len > Main'Length
+ and then
+ Name_Buffer (1 .. Main'Length) = Main
+ then
+ Suffix :=
+ Source.Language
+ .Config.Naming_Data.Body_Suffix;
+
+ exit when Suffix /= No_File and then
+ Name_Buffer (Main'Length + 1 .. Name_Len)
+ = Get_Name_String (Suffix);
+ end if;
+ end if;
+
+ Next (Iter);
+ end loop;
+
+ Project := Project.Extends;
+ end loop;
+ end;
+ end if;
+
+ if Source /= No_Source then
+ Names.Table (J).File := Source.File;
+ Names.Table (J).Source := Source;
+
+ elsif File.Location /= No_Location then
+ -- If the main is declared in package Builder of the
+ -- main project, report an error. If the main is on
+ -- the command line, it may be a main from another
+ -- project, so do nothing: if the main does not exist
+ -- in another project, an error will be reported
+ -- later.
+
+ Error_Msg_File_1 := Main_Id;
+ Error_Msg_Name_1 := Root_Project.Name;
+ Errutil.Error_Msg ("{ is not a source of project %%",
+ File.Location);
+ end if;
+ end;
+ end loop;
+ end if;
+
+ if Total_Errors_Detected > 0 then
+ Fail_Program (Project_Tree, "problems with main sources");
+ end if;
+ end Fill_From_Project;
+
+ ---------------
+ -- Next_Main --
+ ---------------
+
+ function Next_Main return String is
+ Info : Main_Info;
begin
- if Current in Names.First .. Names.Last then
- return Names.Table (Current).Location;
+ Info := Next_Main;
+ if Info = No_Main_Info then
+ return "";
else
- return No_Location;
+ return Get_Name_String (Info.File);
end if;
- end Get_Location;
+ end Next_Main;
---------------
-- Next_Main --
---------------
- function Next_Main return String is
+ function Next_Main return Main_Info is
begin
if Current >= Names.Last then
- return "";
+ return No_Main_Info;
else
Current := Current + 1;
- return Get_Name_String (Names.Table (Current).File_Name);
+ return Names.Table (Current);
end if;
end Next_Main;
begin
Current := 0;
end Reset;
-
- ---------------
- -- Set_Index --
- ---------------
-
- procedure Set_Index (Index : Int) is
- begin
- if Names.Last > 0 then
- Names.Table (Names.Last).Index := Index;
- end if;
- end Set_Index;
-
- ------------------
- -- Set_Location --
- ------------------
-
- procedure Set_Location (Location : Source_Ptr) is
- begin
- if Names.Last > 0 then
- Names.Table (Names.Last).Location := Location;
- end if;
- end Set_Location;
-
- -----------------
- -- Update_Main --
- -----------------
-
- procedure Update_Main (Name : String) is
- begin
- if Current in Names.First .. Names.Last then
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Name);
- Names.Table (Current).File_Name := Name_Find;
- end if;
- end Update_Main;
end Mains;
-----------------------
Marks.Reset;
end Remove_Marks;
+ ----------------------------
+ -- Insert_Project_Sources --
+ ----------------------------
+
+ procedure Insert_Project_Sources
+ (Project : Project_Id;
+ Project_Tree : Project_Tree_Ref;
+ All_Projects : Boolean;
+ Unit_Based : Boolean)
+ is
+ Iter : Source_Iterator;
+ Source : Prj.Source_Id;
+ begin
+ Iter := For_Each_Source (Project_Tree);
+ loop
+ Source := Prj.Element (Iter);
+ exit when Source = No_Source;
+
+ if Is_Compilable (Source)
+ and then
+ (All_Projects
+ or else Is_Extending (Project, Source.Project))
+ and then not Source.Locally_Removed
+ and then Source.Replaced_By = No_Source
+ and then
+ (not Source.Project.Externally_Built
+ or else
+ (Is_Extending (Project, Source.Project)
+ and then not Project.Externally_Built))
+ and then Source.Kind /= Sep
+ and then Source.Path /= No_Path_Information
+ then
+ if Source.Kind = Impl
+ or else (Source.Unit /= No_Unit_Index
+ and then Source.Kind = Spec
+ and then (Other_Part (Source) = No_Source
+ or else
+ Other_Part (Source).Locally_Removed))
+ then
+ if (Unit_Based
+ or else Source.Unit = No_Unit_Index
+ or else Source.Project.Library)
+ and then not Is_Subunit (Source)
+ then
+ Queue.Insert
+ (Source => (Format => Format_Gprbuild,
+ Id => Source));
+ end if;
+ end if;
+ end if;
+
+ Next (Iter);
+ end loop;
+ end Insert_Project_Sources;
+
+ -------------------------------
+ -- Insert_Withed_Sources_For --
+ -------------------------------
+
+ procedure Insert_Withed_Sources_For
+ (The_ALI : ALI.ALI_Id;
+ Project_Tree : Project_Tree_Ref;
+ Excluding_Shared_SALs : Boolean := False)
+ is
+ Sfile : File_Name_Type;
+ Afile : File_Name_Type;
+ Src_Id : Prj.Source_Id;
+
+ begin
+ -- Insert in the queue the unmarked source files (i.e. those which
+ -- have never been inserted in the queue and hence never considered).
+
+ for J in ALI.ALIs.Table (The_ALI).First_Unit ..
+ ALI.ALIs.Table (The_ALI).Last_Unit
+ loop
+ for K in ALI.Units.Table (J).First_With ..
+ ALI.Units.Table (J).Last_With
+ loop
+ Sfile := ALI.Withs.Table (K).Sfile;
+
+ -- Skip generics
+
+ if Sfile /= No_File then
+ Afile := ALI.Withs.Table (K).Afile;
+ Src_Id := Source_Files_Htable.Get
+ (Project_Tree.Source_Files_HT, Sfile);
+
+ while Src_Id /= No_Source loop
+ Initialize_Source_Record (Src_Id);
+
+ if Is_Compilable (Src_Id)
+ and then Src_Id.Dep_Name = Afile
+ then
+ case Src_Id.Kind is
+ when Spec =>
+ declare
+ Bdy : constant Prj.Source_Id :=
+ Other_Part (Src_Id);
+ begin
+ if Bdy /= No_Source
+ and then not Bdy.Locally_Removed
+ then
+ Src_Id := Other_Part (Src_Id);
+ end if;
+ end;
+
+ when Impl =>
+ if Is_Subunit (Src_Id) then
+ Src_Id := No_Source;
+ end if;
+
+ when Sep =>
+ Src_Id := No_Source;
+ end case;
+
+ exit;
+ end if;
+
+ Src_Id := Src_Id.Next_With_File_Name;
+ end loop;
+
+ -- If Excluding_Shared_SALs is True, do not insert in the
+ -- queue the sources of a shared Stand-Alone Library.
+
+ if Src_Id /= No_Source and then
+ (not Excluding_Shared_SALs or else
+ not Src_Id.Project.Standalone_Library or else
+ Src_Id.Project.Library_Kind = Static)
+ then
+ Queue.Insert
+ (Source => (Format => Format_Gprbuild,
+ Id => Src_Id));
+ end if;
+ end if;
+ end loop;
+ end loop;
+ end Insert_Withed_Sources_For;
+
end Queue;
end Makeutl;
with ALI;
with Namet; use Namet;
with Opt;
-with Prj; use Prj;
+with Osint;
+with Prj; use Prj;
with Prj.Tree;
with Types; use Types;
-- source files are still associated with the same units). Return True
-- if everything is still valid.
+ function Is_Subunit (Source : Source_Id) return Boolean;
+ -- Return True if source is a subunit
+
+ procedure Initialize_Source_Record (Source : Source_Id);
+ -- Get information either about the source file, the object and
+ -- dependency file, as well as their timestamps. This includes timestamps.
+
function Is_External_Assignment
(Env : Prj.Tree.Environment;
Argv : String) return Boolean;
function Path_Or_File_Name (Path : Path_Name_Type) return String;
-- Returns a file name if -df is used, otherwise return a path name
+ -------------------------
+ -- Program termination --
+ -------------------------
+
+ procedure Fail_Program
+ (Project_Tree : Project_Tree_Ref;
+ S : String;
+ Flush_Messages : Boolean := True);
+ -- Terminate program with a message and a fatal status code
+
+ procedure Finish_Program
+ (Project_Tree : Project_Tree_Ref;
+ Exit_Code : Osint.Exit_Code_Type := Osint.E_Success;
+ S : String := "");
+ -- Terminate program, with or without a message, setting the status code
+ -- according to Fatal.
+ -- This properly removes all temporary files
+
-----------
-- Mains --
-----------
-- Mains are stored in a table. An index is used to retrieve the mains
-- from the table.
- package Mains is
-
- procedure Add_Main (Name : String);
- -- Add one main to the table
+ type Main_Info is record
+ File : File_Name_Type; -- Always canonical casing
+ Index : Int := 0;
+ Location : Source_Ptr := No_Location;
+ Source : Prj.Source_Id := No_Source;
+ end record;
+ No_Main_Info : constant Main_Info := (No_File, 0, No_Location, No_Source);
- procedure Set_Index (Index : Int);
-
- procedure Set_Location (Location : Source_Ptr);
- -- Set the location of the last main added. By default, the location is
- -- No_Location.
+ package Mains is
+ procedure Add_Main
+ (Name : String;
+ Index : Int := 0;
+ Location : Source_Ptr := No_Location);
+ -- Add one main to the table.
+ -- This is in general used to add the main files specified on the
+ -- command line.
+ -- Index is used for multi-unit source files, and indicates which unit
+ -- within the source is concerned.
+ -- Location is the location within the project file (if a project file
+ -- is used).
procedure Delete;
-- Empty the table
procedure Reset;
- -- Reset the index to the beginning of the table
-
- function Next_Main return String;
- -- Increase the index and return the next main. If table is exhausted,
- -- return an empty string.
+ -- Reset the cursor to the beginning of the table
- function Get_Index return Int;
+ procedure Set_Multi_Unit_Index
+ (Project_Tree : Project_Tree_Ref := null;
+ Index : Int := 0);
+ -- If a single main file was defined, this subprogram indicates which
+ -- unit inside it is the main (case of a multi-unit source files).
+ -- Errors are raised if zero or more than one main file was defined,
+ -- and Index is not 0.
+ -- This subprogram is used for the handling of the command line switch.
- function Get_Location return Source_Ptr;
- -- Get the location of the current main
-
- procedure Update_Main (Name : String);
- -- Update the file name of the current main
+ function Next_Main return String;
+ function Next_Main return Main_Info;
+ -- Moves the cursor forward and returns the new current entry.
+ -- Returns No_File_And_Loc if there are no more mains in the table.
function Number_Of_Mains return Natural;
- -- Returns the number of mains added with Add_Main since the last call
- -- to Delete.
+ -- Returns the number of mains in the table.
+
+ procedure Fill_From_Project
+ (Root_Project : Project_Id;
+ Project_Tree : Project_Tree_Ref);
+ -- If no main was already added (presumably from the command line), add
+ -- the main units from root_project (or in the case of an aggregate
+ -- project from all the
+ -- aggregated projects).
+ --
+ -- If some main units were already added from the command line, check
+ -- that they all belong to the root project, and that they are full
+ -- full paths rather than (partial) base names (e.g. no body suffix was
+ -- specified).
end Mains;
-- The second version returns False if the Source was already marked in
-- the queue.
+ procedure Insert_Project_Sources
+ (Project : Project_Id;
+ Project_Tree : Project_Tree_Ref;
+ All_Projects : Boolean;
+ Unit_Based : Boolean);
+ -- Insert all the compilable sources of the project in the queue. If
+ -- All_Project is true, then all sources from imported projects are also
+ -- inserted.
+ -- When Unit_Based is True, put in the queue all compilable sources
+ -- including the unit based (Ada) one. When Unit_Based is False, put the
+ -- Ada sources only when they are in a library project.
+
+ procedure Insert_Withed_Sources_For
+ (The_ALI : ALI.ALI_Id;
+ Project_Tree : Project_Tree_Ref;
+ Excluding_Shared_SALs : Boolean := False);
+ -- Insert in the queue those sources withed by The_ALI, if there are not
+ -- already in the queue and Only_Interfaces is False or they are part of
+ -- the interfaces of their project.
+
procedure Extract
(Found : out Boolean;
Source : out Source_Info);
end if;
end Delete_Temporary_File;
+ ------------------------------
+ -- Delete_Temp_Config_Files --
+ ------------------------------
+
+ procedure Delete_Temp_Config_Files (Project_Tree : Project_Tree_Ref) is
+ Success : Boolean;
+ Proj : Project_List;
+ pragma Warnings (Off, Success);
+
+ begin
+ if not Debug.Debug_Flag_N then
+ if Project_Tree /= null then
+ Proj := Project_Tree.Projects;
+ while Proj /= null loop
+ if Proj.Project.Config_File_Temp then
+ Delete_Temporary_File
+ (Project_Tree.Shared, Proj.Project.Config_File_Name);
+
+ -- Make sure that we don't have a config file for this
+ -- project, in case there are several mains. In this case,
+ -- we will recreate another config file: we cannot reuse the
+ -- one that we just deleted!
+
+ Proj.Project.Config_Checked := False;
+ Proj.Project.Config_File_Name := No_Path;
+ Proj.Project.Config_File_Temp := False;
+ end if;
+ Proj := Proj.Next;
+ end loop;
+ end if;
+ end if;
+ end Delete_Temp_Config_Files;
+
---------------------------
-- Delete_All_Temp_Files --
---------------------------
Project : Project_Id;
In_Imported_Only : Boolean := False;
In_Extended_Only : Boolean := False;
- Base_Name : File_Name_Type) return Source_Id
+ Base_Name : File_Name_Type;
+ Index : Int := 0) return Source_Id
is
Result : Source_Id := No_Source;
begin
Iterator := For_Each_Source (In_Tree => Tree, Project => Proj);
while Element (Iterator) /= No_Source loop
- if Element (Iterator).File = Base_Name then
+ if Element (Iterator).File = Base_Name
+ and then (Index = 0 or else Element (Iterator).Index = Index)
+ then
Src := Element (Iterator);
return;
end if;
Project : Project_Id;
In_Imported_Only : Boolean := False;
In_Extended_Only : Boolean := False;
- Base_Name : File_Name_Type) return Source_Id;
+ Base_Name : File_Name_Type;
+ Index : Int := 0) return Source_Id;
-- Find the first source file with the given name either in the whole tree
-- (if In_Imported_Only is False) or in the projects imported or extended
-- by Project otherwise. In_Extended_Only implies In_Imported_Only, and
- -- will only look in Project and the projects it extends
+ -- will only look in Project and the projects it extends.
+ -- If Index is specified, this only search for a source with that index.
-----------------------
-- Project_Tree_Data --
-- Delete all recorded temporary files.
-- Does nothing if Debug.Debug_Flag_N is set
+ procedure Delete_Temp_Config_Files (Project_Tree : Project_Tree_Ref);
+ -- Delete all temporary config files.
+ -- Does nothing if Debug.Debug_Flag_N is set or if Project_Tree is null.
+ -- This initially came from gnatmake
+ -- ??? Should this be combined with Delete_All_Temp_Files above
+
procedure Delete_Temporary_File
(Shared : Shared_Project_Tree_Data_Access := null;
Path : Path_Name_Type);
Else_Expr := Next (Then_Expr);
- -- In ALFA, conditional expressions are allowed:
+ -- In ALFA, boolean conditional expressions are allowed:
-- * if they have no ELSE part, in which case the expression is
-- equivalent to
+
-- NOT Condition OR ELSE Then_Expr
+
-- * in pre- and postconditions, where the Condition cannot have side-
-- effects (in ALFA) and thus the expression is equivalent to
+
-- (Condition AND THEN Then_Expr)
-- and (NOT Condition AND THEN Then_Expr)
+ -- Non-boolean conditional expressions are marked as not in ALFA during
+ -- resolution.
+
if Present (Else_Expr) and then not In_Pre_Post_Expression then
Mark_Non_ALFA_Subprogram;
end if;
Append_To (Expressions (N), Error);
end if;
+ if Root_Type (Typ) /= Standard_Boolean then
+ Mark_Non_ALFA_Subprogram;
+ end if;
+
Set_Etype (N, Typ);
Eval_Conditional_Expression (N);
end Resolve_Conditional_Expression;
projects / gcc.git / commitdiff