Skip to content

R
riscv-gcc-1
Commit 35e7063a by Arnaud Charlet
Options

[multiple changes] 

2014-11-20  Thomas Quinot  <quinot@adacore.com>

	* freeze.adb, sem_ch13.adb: Minor editing.

2014-11-20  Vincent Celier  <celier@adacore.com>

	* gnatcmd.adb: Remove any special processing for the ASIS tools
	(gnatpp, gnatmetric, gnatcheck, gnatelim and gnatstup) and simply
	invoke the tool with the provided switches and arguments.

2014-11-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Analyze_Expression_Function): Reject declaration
	of expression function with identical profile as previous
	expression function.

From-SVN: r217846
parent 8b64ed4c
Showing with 50 additions and 629 deletions
gcc/ada/ChangeLog
2014-11-20 Thomas Quinot <quinot@adacore.com> 2014-11-20 Thomas Quinot <quinot@adacore.com>
* freeze.adb, sem_ch13.adb: Minor editing.
2014-11-20 Vincent Celier <celier@adacore.com>
* gnatcmd.adb: Remove any special processing for the ASIS tools
(gnatpp, gnatmetric, gnatcheck, gnatelim and gnatstup) and simply
invoke the tool with the provided switches and arguments.
2014-11-20 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Expression_Function): Reject declaration
of expression function with identical profile as previous
expression function.
2014-11-20 Thomas Quinot <quinot@adacore.com>
* sem_ch13.adb: Complete previous change. * sem_ch13.adb: Complete previous change.
* exp_dist.adb, exp_dist.ads: Rework PolyORB/DSA arguments processing * exp_dist.adb, exp_dist.ads: Rework PolyORB/DSA arguments processing
circuitry to correctly handle the case of non-private limited circuitry to correctly handle the case of non-private limited
......
gcc/ada/gnatcmd.adb
...@@ -123,9 +123,6 @@ procedure GNATCmd is ...@@ -123,9 +123,6 @@ procedure GNATCmd is
-- The name of the temporary text file to put a list of source/object -- The name of the temporary text file to put a list of source/object
-- files to pass to a tool. -- files to pass to a tool.
ASIS_Main : String_Access := null;
-- Main for commands Check, Metric and Pretty, when -U is used
package First_Switches is new Table.Table package First_Switches is new Table.Table
(Table_Component_Type => String_Access, (Table_Component_Type => String_Access,
Table_Index_Type => Integer, Table_Index_Type => Integer,
...@@ -177,33 +174,20 @@ procedure GNATCmd is ...@@ -177,33 +174,20 @@ procedure GNATCmd is
Naming_String : constant SA := new String'("naming"); Naming_String : constant SA := new String'("naming");
Binder_String : constant SA := new String'("binder"); Binder_String : constant SA := new String'("binder");
Builder_String : constant SA := new String'("builder");
Compiler_String : constant SA := new String'("compiler"); Compiler_String : constant SA := new String'("compiler");
Check_String : constant SA := new String'("check");
Synchronize_String : constant SA := new String'("synchronize"); Synchronize_String : constant SA := new String'("synchronize");
Eliminate_String : constant SA := new String'("eliminate");
Finder_String : constant SA := new String'("finder"); Finder_String : constant SA := new String'("finder");
Linker_String : constant SA := new String'("linker"); Linker_String : constant SA := new String'("linker");
Gnatls_String : constant SA := new String'("gnatls"); Gnatls_String : constant SA := new String'("gnatls");
Pretty_String : constant SA := new String'("pretty_printer");
Stack_String : constant SA := new String'("stack"); Stack_String : constant SA := new String'("stack");
Gnatstub_String : constant SA := new String'("gnatstub");
Metric_String : constant SA := new String'("metrics");
Xref_String : constant SA := new String'("cross_reference"); Xref_String : constant SA := new String'("cross_reference");
Packages_To_Check_By_Binder : constant String_List_Access := Packages_To_Check_By_Binder : constant String_List_Access :=
new String_List'((Naming_String, Binder_String)); new String_List'((Naming_String, Binder_String));
Packages_To_Check_By_Check : constant String_List_Access :=
new String_List'
((Naming_String, Builder_String, Check_String, Compiler_String));
Packages_To_Check_By_Sync : constant String_List_Access := Packages_To_Check_By_Sync : constant String_List_Access :=
new String_List'((Naming_String, Synchronize_String, Compiler_String)); new String_List'((Naming_String, Synchronize_String, Compiler_String));
Packages_To_Check_By_Eliminate : constant String_List_Access :=
new String_List'((Naming_String, Eliminate_String, Compiler_String));
Packages_To_Check_By_Finder : constant String_List_Access := Packages_To_Check_By_Finder : constant String_List_Access :=
new String_List'((Naming_String, Finder_String)); new String_List'((Naming_String, Finder_String));
...@@ -213,18 +197,9 @@ procedure GNATCmd is ...@@ -213,18 +197,9 @@ procedure GNATCmd is
Packages_To_Check_By_Gnatls : constant String_List_Access := Packages_To_Check_By_Gnatls : constant String_List_Access :=
new String_List'((Naming_String, Gnatls_String)); new String_List'((Naming_String, Gnatls_String));
Packages_To_Check_By_Pretty : constant String_List_Access :=
new String_List'((Naming_String, Pretty_String, Compiler_String));
Packages_To_Check_By_Stack : constant String_List_Access := Packages_To_Check_By_Stack : constant String_List_Access :=
new String_List'((Naming_String, Stack_String)); new String_List'((Naming_String, Stack_String));
Packages_To_Check_By_Gnatstub : constant String_List_Access :=
new String_List'((Naming_String, Gnatstub_String, Compiler_String));
Packages_To_Check_By_Metric : constant String_List_Access :=
new String_List'((Naming_String, Metric_String, Compiler_String));
Packages_To_Check_By_Xref : constant String_List_Access := Packages_To_Check_By_Xref : constant String_List_Access :=
new String_List'((Naming_String, Xref_String)); new String_List'((Naming_String, Xref_String));
...@@ -374,10 +349,6 @@ procedure GNATCmd is ...@@ -374,10 +349,6 @@ procedure GNATCmd is
-- Add a switch to the Carg_Switches table. If it is the first one, put the -- Add a switch to the Carg_Switches table. If it is the first one, put the
-- switch "-cargs" at the beginning of the table. -- switch "-cargs" at the beginning of the table.
procedure Add_To_Rules_Switches (Switch : String_Access);
-- Add a switch to the Rules_Switches table. If it is the first one, put
-- the switch "-crules" at the beginning of the table.
procedure Check_Files; procedure Check_Files;
-- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a -- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a
-- project file is specified, without any file arguments and without a -- project file is specified, without any file arguments and without a
...@@ -414,10 +385,6 @@ procedure GNATCmd is ...@@ -414,10 +385,6 @@ procedure GNATCmd is
-- includes directory information, prepend the path with Parent. This -- includes directory information, prepend the path with Parent. This
-- subprogram is only called when using project files. -- subprogram is only called when using project files.
procedure Get_Closure;
-- Get the sources in the closure of the ASIS_Main and add them to the
-- list of arguments.
function Mapping_File return Path_Name_Type; function Mapping_File return Path_Name_Type;
-- Create and return the path name of a mapping file. Used for gnatstub -- Create and return the path name of a mapping file. Used for gnatstub
-- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric
...@@ -460,23 +427,6 @@ procedure GNATCmd is ...@@ -460,23 +427,6 @@ procedure GNATCmd is
Carg_Switches.Table (Carg_Switches.Last) := Switch; Carg_Switches.Table (Carg_Switches.Last) := Switch;
end Add_To_Carg_Switches; end Add_To_Carg_Switches;
---------------------------
-- Add_To_Rules_Switches --
---------------------------
procedure Add_To_Rules_Switches (Switch : String_Access) is
begin
-- If the Rules_Switches table is empty, put "-rules" at the beginning
if Rules_Switches.Last = 0 then
Rules_Switches.Increment_Last;
Rules_Switches.Table (Rules_Switches.Last) := new String'("-rules");
end if;
Rules_Switches.Increment_Last;
Rules_Switches.Table (Rules_Switches.Last) := Switch;
end Add_To_Rules_Switches;
----------------- -----------------
-- Check_Files -- -- Check_Files --
----------------- -----------------
...@@ -538,37 +488,14 @@ procedure GNATCmd is ...@@ -538,37 +488,14 @@ procedure GNATCmd is
-- there is a -files= switch. -- there is a -files= switch.
for Index in 1 .. Last_Switches.Last loop for Index in 1 .. Last_Switches.Last loop
if Last_Switches.Table (Index).all'Length > 7 if Last_Switches.Table (Index) (1) /= '-'
and then Last_Switches.Table (Index) (1 .. 7) = "-files="
then
Add_Sources := False;
exit;
elsif Last_Switches.Table (Index) (1) /= '-' then
if Index = 1
or else
(The_Command = Check
and then Last_Switches.Table (Index - 1).all /= "-o")
or else or else
(The_Command = Pretty (Last_Switches.Table (Index).all'Length > 7
and then Last_Switches.Table (Index - 1).all /= "-o" and then Last_Switches.Table (Index) (1 .. 7) = "-files=")
and then Last_Switches.Table (Index - 1).all /= "-of")
or else
(The_Command = Metric
and then
Last_Switches.Table (Index - 1).all /= "-o" and then
Last_Switches.Table (Index - 1).all /= "-og" and then
Last_Switches.Table (Index - 1).all /= "-ox" and then
Last_Switches.Table (Index - 1).all /= "-d")
or else
(The_Command /= Check and then
The_Command /= Pretty and then
The_Command /= Metric)
then then
Add_Sources := False; Add_Sources := False;
exit; exit;
end if; end if;
end if;
end loop; end loop;
-- If all arguments are switches and there is no switch -files=, add the -- If all arguments are switches and there is no switch -files=, add the
...@@ -580,10 +507,7 @@ procedure GNATCmd is ...@@ -580,10 +507,7 @@ procedure GNATCmd is
-- put the list of sources in it. For gnatstack create a temporary -- put the list of sources in it. For gnatstack create a temporary
-- file with the list of .ci files. -- file with the list of .ci files.
if The_Command = Check or else if The_Command = List or else
The_Command = Pretty or else
The_Command = Metric or else
The_Command = List or else
The_Command = Stack The_Command = Stack
then then
Tempdir.Create_Temp_File (FD, Temp_File_Name); Tempdir.Create_Temp_File (FD, Temp_File_Name);
...@@ -805,26 +729,6 @@ procedure GNATCmd is ...@@ -805,26 +729,6 @@ procedure GNATCmd is
"ci")); "ci"));
end if; end if;
end if; end if;
else
-- For gnatcheck, gnatsync, gnatpp and gnatmetric, put all
-- sources of the project, or of all projects if -U was
-- specified.
for Kind in Spec_Or_Body loop
if Unit.File_Names (Kind) /= null
and then Check_Project
(Unit.File_Names (Kind).Project, Project)
and then not Unit.File_Names (Kind).Locally_Removed
then
Add_To_Response_File
("""" &
Get_Name_String
(Unit.File_Names (Kind).Path.Display_Name) &
"""",
Check_File => False);
end if;
end loop;
end if; end if;
Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
...@@ -849,24 +753,12 @@ procedure GNATCmd is ...@@ -849,24 +753,12 @@ procedure GNATCmd is
(Project : Project_Id; (Project : Project_Id;
Root_Project : Project_Id) return Boolean Root_Project : Project_Id) return Boolean
is is
Proj : Project_Id;
begin begin
if Project = No_Project then if Project = No_Project then
return False; return False;
elsif All_Projects or else Project = Root_Project then elsif All_Projects or else Project = Root_Project then
return True; return True;
elsif The_Command = Metric then
Proj := Root_Project;
while Proj.Extends /= No_Project loop
if Project = Proj.Extends then
return True;
end if;
Proj := Proj.Extends;
end loop;
end if; end if;
return False; return False;
...@@ -964,175 +856,6 @@ procedure GNATCmd is ...@@ -964,175 +856,6 @@ procedure GNATCmd is
Including_RTS => True); Including_RTS => True);
end Ensure_Absolute_Path; end Ensure_Absolute_Path;
-----------------
-- Get_Closure --
-----------------
procedure Get_Closure is
Args : constant Argument_List :=
(1 => new String'("-q"),
2 => new String'("-b"),
3 => new String'("-P"),
4 => Project_File,
5 => ASIS_Main,
6 => new String'("-bargs"),
7 => new String'("-R"),
8 => new String'("-Z"));
-- Arguments for the invocation of gnatmake which are added to the
-- Last_Arguments list by this procedure.
FD : File_Descriptor;
-- File descriptor for the temp file that will get the output of the
-- invocation of gnatmake.
Name : Path_Name_Type;
-- Path of the file FD
GN_Name : constant String := Program_Name ("gnatmake", "gnat").all;
-- Name for gnatmake
GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name);
-- Path of gnatmake
Return_Code : Integer;
Unused : Boolean;
pragma Warnings (Off, Unused);
File : Ada.Text_IO.File_Type;
Line : String (1 .. 250);
Last : Natural;
-- Used to read file if there is an error, it is good enough to display
-- just 250 characters if the first line of the file is very long.
Unit : Unit_Index;
Path : Path_Name_Type;
Files_File : Ada.Text_IO.File_Type;
Temp_File_Name : Path_Name_Type;
begin
if GN_Path = null then
Put_Line (Standard_Error, "could not locate " & GN_Name);
raise Error_Exit;
end if;
-- Create the temp file
Prj.Env.Create_Temp_File (Project_Tree.Shared, FD, Name, "files");
-- And close it
Close (FD);
-- Spawn "gnatmake -q -b -P <project> <main> -bargs -R -Z"
Spawn
(Program_Name => GN_Path.all,
Args => Args,
Output_File => Get_Name_String (Name),
Success => Unused,
Return_Code => Return_Code,
Err_To_Out => True);
-- Read the output of the invocation of gnatmake
Open (File, In_File, Get_Name_String (Name));
-- If it was unsuccessful, display the first line in the file and exit
-- with error.
if Return_Code /= 0 then
Get_Line (File, Line, Last);
begin
if not Keep_Temporary_Files then
Delete (File);
else
Close (File);
end if;
-- Don't crash if it is not possible to delete or close the file,
-- just ignore the situation.
exception
when others =>
null;
end;
Put_Line (Standard_Error, Line (1 .. Last));
Put_Line
(Standard_Error, "could not get closure of " & ASIS_Main.all);
raise Error_Exit;
else
-- Create a temporary file to put the list of files in the closure
Tempdir.Create_Temp_File (FD, Temp_File_Name);
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-files=" & Get_Name_String (Temp_File_Name));
Close (FD);
Open (Files_File, Out_File, Get_Name_String (Temp_File_Name));
-- Get each file name in the file, find its path and add it the list
-- of arguments.
while not End_Of_File (File) loop
Get_Line (File, Line, Last);
Path := No_Path;
Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
while Unit /= No_Unit_Index loop
if Unit.File_Names (Spec) /= null
and then
Get_Name_String (Unit.File_Names (Spec).File) =
Line (1 .. Last)
then
Path := Unit.File_Names (Spec).Path.Name;
exit;
elsif Unit.File_Names (Impl) /= null
and then
Get_Name_String (Unit.File_Names (Impl).File) =
Line (1 .. Last)
then
Path := Unit.File_Names (Impl).Path.Name;
exit;
end if;
Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
end loop;
if Path /= No_Path then
Put_Line (Files_File, Get_Name_String (Path));
else
Put_Line (Files_File, Line (1 .. Last));
end if;
end loop;
Close (Files_File);
begin
if not Keep_Temporary_Files then
Delete (File);
else
Close (File);
end if;
-- Don't crash if it is not possible to delete or close the file,
-- just ignore the situation.
exception
when others =>
null;
end;
end if;
end Get_Closure;
------------------ ------------------
-- Mapping_File -- -- Mapping_File --
------------------ ------------------
...@@ -1216,7 +939,8 @@ procedure GNATCmd is ...@@ -1216,7 +939,8 @@ procedure GNATCmd is
New_Line; New_Line;
Put_Line ("All commands except chop, krunch and preprocess " & Put_Line ("All commands except chop, krunch and preprocess " &
"accept project file switches -vPx, -Pprj and -Xnam=val"); "accept project file switches -vPx, -Pprj, -Xnam=val," &
"--subdirs= and -eL");
New_Line; New_Line;
end Usage; end Usage;
...@@ -1792,12 +1516,6 @@ begin ...@@ -1792,12 +1516,6 @@ begin
when Bind => when Bind =>
Tool_Package_Name := Name_Binder; Tool_Package_Name := Name_Binder;
Packages_To_Check := Packages_To_Check_By_Binder; Packages_To_Check := Packages_To_Check_By_Binder;
when Check =>
Tool_Package_Name := Name_Check;
Packages_To_Check := Packages_To_Check_By_Check;
when Elim =>
Tool_Package_Name := Name_Eliminate;
Packages_To_Check := Packages_To_Check_By_Eliminate;
when Find => when Find =>
Tool_Package_Name := Name_Finder; Tool_Package_Name := Name_Finder;
Packages_To_Check := Packages_To_Check_By_Finder; Packages_To_Check := Packages_To_Check_By_Finder;
...@@ -1807,18 +1525,9 @@ begin ...@@ -1807,18 +1525,9 @@ begin
when List => when List =>
Tool_Package_Name := Name_Gnatls; Tool_Package_Name := Name_Gnatls;
Packages_To_Check := Packages_To_Check_By_Gnatls; Packages_To_Check := Packages_To_Check_By_Gnatls;
when Metric =>
Tool_Package_Name := Name_Metrics;
Packages_To_Check := Packages_To_Check_By_Metric;
when Pretty =>
Tool_Package_Name := Name_Pretty_Printer;
Packages_To_Check := Packages_To_Check_By_Pretty;
when Stack => when Stack =>
Tool_Package_Name := Name_Stack; Tool_Package_Name := Name_Stack;
Packages_To_Check := Packages_To_Check_By_Stack; Packages_To_Check := Packages_To_Check_By_Stack;
when Stub =>
Tool_Package_Name := Name_Gnatstub;
Packages_To_Check := Packages_To_Check_By_Gnatstub;
when Sync => when Sync =>
Tool_Package_Name := Name_Synchronize; Tool_Package_Name := Name_Synchronize;
Packages_To_Check := Packages_To_Check_By_Sync; Packages_To_Check := Packages_To_Check_By_Sync;
...@@ -2013,10 +1722,7 @@ begin ...@@ -2013,10 +1722,7 @@ begin
Remove_Switch (Arg_Num); Remove_Switch (Arg_Num);
elsif elsif
(The_Command = Check or else (The_Command = Sync or else
The_Command = Sync or else
The_Command = Pretty or else
The_Command = Metric or else
The_Command = Stack or else The_Command = Stack or else
The_Command = List) The_Command = List)
and then Argv'Length = 2 and then Argv'Length = 2
...@@ -2029,20 +1735,6 @@ begin ...@@ -2029,20 +1735,6 @@ begin
Arg_Num := Arg_Num + 1; Arg_Num := Arg_Num + 1;
end if; end if;
elsif ((The_Command = Check and then Argv (Argv'First) /= '+')
or else The_Command = Sync
or else The_Command = Metric
or else The_Command = Pretty)
and then Project_File /= null
and then All_Projects
then
if ASIS_Main /= null then
Fail ("cannot specify more than one main after -U");
else
ASIS_Main := Argv;
Remove_Switch (Arg_Num);
end if;
else else
Arg_Num := Arg_Num + 1; Arg_Num := Arg_Num + 1;
end if; end if;
...@@ -2121,10 +1813,8 @@ begin ...@@ -2121,10 +1813,8 @@ begin
-- Packages Binder (for gnatbind), Cross_Reference (for -- Packages Binder (for gnatbind), Cross_Reference (for
-- gnatxref), Linker (for gnatlink), Finder (for gnatfind), -- gnatxref), Linker (for gnatlink), Finder (for gnatfind),
-- Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check -- have an attributed Switches, an associative array, indexed
-- (for gnatcheck), and Metric (for gnatmetric) have an -- by the name of the file.
-- attributed Switches, an associative array, indexed by the
-- name of the file.
-- They also have an attribute Default_Switches, indexed by the -- They also have an attribute Default_Switches, indexed by the
-- name of the programming language. -- name of the programming language.
...@@ -2229,10 +1919,7 @@ begin ...@@ -2229,10 +1919,7 @@ begin
end if; end if;
end; end;
if The_Command = Bind or else if The_Command = Bind or else The_Command = Link then
The_Command = Link or else
The_Command = Elim
then
if Project.Object_Directory.Name = No_Path then if Project.Object_Directory.Name = No_Path then
Fail ("project " & Get_Name_String (Project.Display_Name) Fail ("project " & Get_Name_String (Project.Display_Name)
& " has no object directory"); & " has no object directory");
...@@ -2249,13 +1936,7 @@ begin ...@@ -2249,13 +1936,7 @@ begin
-- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create
-- a configuration pragmas file, if necessary. -- a configuration pragmas file, if necessary.
if The_Command = Pretty if The_Command = Sync then
or else The_Command = Metric
or else The_Command = Stub
or else The_Command = Elim
or else The_Command = Check
or else The_Command = Sync
then
-- If there are switches in package Compiler, put them in the -- If there are switches in package Compiler, put them in the
-- Carg_Switches table. -- Carg_Switches table.
...@@ -2384,11 +2065,7 @@ begin ...@@ -2384,11 +2065,7 @@ begin
-- command is CHECK. -- command is CHECK.
K := J + 1; K := J + 1;
while K <= First_Switches.Last while K <= First_Switches.Last loop
and then
(The_Command /= Check
or else First_Switches.Table (K).all /= "-rules")
loop
Add_To_Carg_Switches (First_Switches.Table (K)); Add_To_Carg_Switches (First_Switches.Table (K));
K := K + 1; K := K + 1;
end loop; end loop;
...@@ -2415,40 +2092,11 @@ begin ...@@ -2415,40 +2092,11 @@ begin
for J in 1 .. Last_Switches.Last loop for J in 1 .. Last_Switches.Last loop
if Last_Switches.Table (J).all = "-cargs" then if Last_Switches.Table (J).all = "-cargs" then
declare for K in J + 1 .. Last_Switches.Last loop
K : Positive;
Last : Natural;
begin
-- Move the switches that are before -rules when the
-- command is CHECK.
K := J + 1;
while K <= Last_Switches.Last
and then
(The_Command /= Check
or else Last_Switches.Table (K).all /= "-rules")
loop
Add_To_Carg_Switches (Last_Switches.Table (K)); Add_To_Carg_Switches (Last_Switches.Table (K));
K := K + 1;
end loop; end loop;
if K > Last_Switches.Last then
Last_Switches.Set_Last (J - 1); Last_Switches.Set_Last (J - 1);
else
Last := J - 1;
while K <= Last_Switches.Last loop
Last := Last + 1;
Last_Switches.Table (Last) :=
Last_Switches.Table (K);
K := K + 1;
end loop;
Last_Switches.Set_Last (Last);
end if;
end;
exit; exit;
end if; end if;
end loop; end loop;
...@@ -2459,122 +2107,14 @@ begin ...@@ -2459,122 +2107,14 @@ begin
begin begin
if CP_File /= No_Path then if CP_File /= No_Path then
if The_Command = Elim then
First_Switches.Increment_Last;
First_Switches.Table (First_Switches.Last) :=
new String'("-C" & Get_Name_String (CP_File));
else
Add_To_Carg_Switches Add_To_Carg_Switches
(new String'("-gnatec=" & Get_Name_String (CP_File))); (new String'("-gnatec=" & Get_Name_String (CP_File)));
end if; end if;
end if;
if M_File /= No_Path then if M_File /= No_Path then
Add_To_Carg_Switches Add_To_Carg_Switches
(new String'("-gnatem=" & Get_Name_String (M_File))); (new String'("-gnatem=" & Get_Name_String (M_File)));
end if; end if;
-- For gnatcheck, gnatpp, gnatstub and gnatmetric, also
-- indicate a global configuration pragmas file and, if -U
-- is not used, a local one.
if The_Command = Check or else
The_Command = Pretty or else
The_Command = Stub or else
The_Command = Metric
then
declare
Pkg : constant Prj.Package_Id :=
Prj.Util.Value_Of
(Name => Name_Builder,
In_Packages => Project.Decl.Packages,
Shared => Project_Tree.Shared);
Variable : Variable_Value :=
Prj.Util.Value_Of
(Name => No_Name,
Attribute_Or_Array_Name =>
Name_Global_Configuration_Pragmas,
In_Package => Pkg,
Shared => Project_Tree.Shared);
begin
if (Variable = Nil_Variable_Value
or else Length_Of_Name (Variable.Value) = 0)
and then Pkg /= No_Package
then
Variable :=
Prj.Util.Value_Of
(Name => Name_Ada,
Attribute_Or_Array_Name =>
Name_Global_Config_File,
In_Package => Pkg,
Shared => Project_Tree.Shared);
end if;
if Variable /= Nil_Variable_Value
and then Length_Of_Name (Variable.Value) /= 0
then
declare
Path : constant String :=
Absolute_Path
(Path_Name_Type (Variable.Value),
Variable.Project);
begin
Add_To_Carg_Switches
(new String'("-gnatec=" & Path));
end;
end if;
end;
if not All_Projects then
declare
Pkg : constant Prj.Package_Id :=
Prj.Util.Value_Of
(Name => Name_Compiler,
In_Packages => Project.Decl.Packages,
Shared => Project_Tree.Shared);
Variable : Variable_Value :=
Prj.Util.Value_Of
(Name => No_Name,
Attribute_Or_Array_Name =>
Name_Local_Configuration_Pragmas,
In_Package => Pkg,
Shared => Project_Tree.Shared);
begin
if (Variable = Nil_Variable_Value
or else Length_Of_Name (Variable.Value) = 0)
and then Pkg /= No_Package
then
Variable :=
Prj.Util.Value_Of
(Name => Name_Ada,
Attribute_Or_Array_Name =>
Name_Local_Config_File,
In_Package => Pkg,
Shared =>
Project_Tree.Shared);
end if;
if Variable /= Nil_Variable_Value
and then Length_Of_Name (Variable.Value) /= 0
then
declare
Path : constant String :=
Absolute_Path
(Path_Name_Type (Variable.Value),
Variable.Project);
begin
Add_To_Carg_Switches
(new String'("-gnatec=" & Path));
end;
end if;
end;
end if;
end if;
end; end;
end if; end if;
...@@ -2606,164 +2146,16 @@ begin ...@@ -2606,164 +2146,16 @@ begin
(First_Switches.Table (J), Project_Dir); (First_Switches.Table (J), Project_Dir);
end loop; end loop;
end; end;
elsif The_Command = Stub then
declare
File_Index : Integer := 0;
Dir_Index : Integer := 0;
Last : constant Integer := Last_Switches.Last;
Lang : constant Language_Ptr :=
Get_Language_From_Name (Project, "ada");
begin
for Index in 1 .. Last loop
if Last_Switches.Table (Index)
(Last_Switches.Table (Index)'First) /= '-'
then
File_Index := Index;
exit;
end if; end if;
end loop;
-- If the project file naming scheme is not standard, and if
-- the file name ends with the spec suffix, then indicate to
-- gnatstub the name of the body file with a -o switch.
if Lang /= No_Language_Index -- For gnat sync with -U + a main, get the list of sources from the
and then not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) -- closure and add them to the arguments.
then
if File_Index /= 0 then
declare
Spec : constant String :=
Base_Name
(Last_Switches.Table (File_Index).all);
Last : Natural := Spec'Last;
begin -- For gnat sync, gnat list, and gnat stack, if no file has been put
Get_Name_String (Lang.Config.Naming_Data.Spec_Suffix); -- on the command line, call tool with all the sources of the main
-- project.
if Spec'Length > Name_Len
and then Spec (Last - Name_Len + 1 .. Last) =
Name_Buffer (1 .. Name_Len)
then
Last := Last - Name_Len;
Get_Name_String
(Lang.Config.Naming_Data.Body_Suffix);
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-o");
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'(Spec (Spec'First .. Last) &
Name_Buffer (1 .. Name_Len));
end if;
end;
end if;
end if;
-- Add the directory of the spec as the destination directory
-- of the body, if there is no destination directory already
-- specified.
if File_Index /= 0 then
for Index in File_Index + 1 .. Last loop
if Last_Switches.Table (Index)
(Last_Switches.Table (Index)'First) /= '-'
then
Dir_Index := Index;
exit;
end if;
end loop;
if Dir_Index = 0 then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'
(Dir_Name (Last_Switches.Table (File_Index).all));
end if;
end if;
end;
end if;
-- For gnatmetric, the generated files should be put in the object
-- directory. This must be the first switch, because it may be
-- overridden by a switch in package Metrics in the project file or
-- by a command line option. Note that we don't add the -d= switch
-- if there is no object directory available.
if The_Command = Metric
and then Project.Object_Directory /= No_Path_Information
then
First_Switches.Increment_Last;
First_Switches.Table (2 .. First_Switches.Last) :=
First_Switches.Table (1 .. First_Switches.Last - 1);
First_Switches.Table (1) :=
new String'("-d=" &
Get_Name_String (Project.Object_Directory.Name));
end if;
-- For gnat check, -rules and the following switches need to be the
-- last options, so move all these switches to table Rules_Switches.
if The_Command = Check then
declare
New_Last : Natural;
-- Set to rank of options preceding "-rules"
In_Rules_Switches : Boolean;
-- Set to True when options "-rules" is found
begin
New_Last := First_Switches.Last;
In_Rules_Switches := False;
for J in 1 .. First_Switches.Last loop
if In_Rules_Switches then
Add_To_Rules_Switches (First_Switches.Table (J));
elsif First_Switches.Table (J).all = "-rules" then
New_Last := J - 1;
In_Rules_Switches := True;
end if;
end loop;
if In_Rules_Switches then
First_Switches.Set_Last (New_Last);
end if;
New_Last := Last_Switches.Last;
In_Rules_Switches := False;
for J in 1 .. Last_Switches.Last loop
if In_Rules_Switches then
Add_To_Rules_Switches (Last_Switches.Table (J));
elsif Last_Switches.Table (J).all = "-rules" then
New_Last := J - 1;
In_Rules_Switches := True;
end if;
end loop;
if In_Rules_Switches then
Last_Switches.Set_Last (New_Last);
end if;
end;
end if;
-- For gnat check, sync, metric or pretty with -U + a main, get the
-- list of sources from the closure and add them to the arguments.
if ASIS_Main /= null then
Get_Closure;
-- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list,
-- and gnat stack, if no file has been put on the command line, call
-- tool with all the sources of the main project.
elsif The_Command = Check or else if The_Command = Sync or else
The_Command = Sync or else
The_Command = Pretty or else
The_Command = Metric or else
The_Command = List or else The_Command = List or else
The_Command = Stack The_Command = Stack
then then
......
gcc/ada/sem_ch13.adb
...@@ -3798,7 +3798,8 @@ package body Sem_Ch13 is ...@@ -3798,7 +3798,8 @@ package body Sem_Ch13 is
("variable indexing must return a reference type"); ("variable indexing must return a reference type");
return; return;
elsif Is_Access_Constant (Etype (First_Discriminant (Ret_Type))) elsif Is_Access_Constant
(Etype (First_Discriminant (Ret_Type)))
then then
Illegal_Indexing Illegal_Indexing
("variable indexing must return an access to variable"); ("variable indexing must return an access to variable");
...@@ -10936,7 +10937,8 @@ package body Sem_Ch13 is ...@@ -10936,7 +10937,8 @@ package body Sem_Ch13 is
SSO_Set_High_By_Default (Bas_Typ))) SSO_Set_High_By_Default (Bas_Typ)))
then then
Set_Reverse_Storage_Order (Bas_Typ, Set_Reverse_Storage_Order (Bas_Typ,
Reverse_Storage_Order (Base_Type (Etype (Bas_Typ)))); Reverse_Storage_Order
(Implementation_Base_Type (Etype (Bas_Typ))));
-- Clear default SSO indications, since the inherited aspect -- Clear default SSO indications, since the inherited aspect
-- which was set explicitly overrides the default. -- which was set explicitly overrides the default.
......
gcc/ada/sem_ch6.adb
...@@ -326,6 +326,17 @@ package body Sem_Ch6 is ...@@ -326,6 +326,17 @@ package body Sem_Ch6 is
then then
Def_Id := Analyze_Subprogram_Specification (Spec); Def_Id := Analyze_Subprogram_Specification (Spec);
Prev := Find_Corresponding_Spec (N); Prev := Find_Corresponding_Spec (N);
-- The previous entity may be an expression function as well, in
-- which case the redeclaration is illegal.
if Present (Prev)
and then Nkind (Original_Node (Unit_Declaration_Node (Prev)))
= N_Expression_Function
then
Error_Msg_N ("Duplicate expression function", N);
return;
end if;
end if; end if;
Ret := Make_Simple_Return_Statement (LocX, Expression (N)); Ret := Make_Simple_Return_Statement (LocX, Expression (N));
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment