procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2004-06-28  Robert Dewar  <dewar@gnat.com>

	* mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb,
	mlib-tgt-irix.adb, mlib-tgt-hpux.adb, mlib-tgt-linux.adb,
	mlib-tgt-linux.adb, mlib-tgt-solaris.adb, mlib-tgt-solaris.adb,
	mlib-tgt-vms-alpha.adb, mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb,
	a-strmap.adb, a-strmap.ads, clean.adb: Minor reformatting

	* exp_util.adb (Is_Possibly_Unaligned_Slice): Completely rewritten, to
	deal with problem of inefficient slices on machines with strict
	alignment, when the slice is a component of a composite.

	* checks.adb (Apply_Array_Size_Check): Do not special case 64-bit
	machines, we need the check there as well.

2004-06-28  Ed Schonberg  <schonberg@gnat.com>

	* exp_ch5.adb (Expand_Assign_Array): Use correct condition to
	determine safe copying direction for overlapping slice assignments
	when component is controlled.

	* sem_ch12.adb (Instantiate_Formal_Package): Implicit operations of a
	formal derived type in the actual for a formal package are visible in
	the enclosing instance.

2004-06-28  Ed Schonberg  <schonberg@gnat.com>

	PR ada/15600
	* sem_util.adb (Trace_Components): Diagnose properly an illegal
	circularity involving a private type whose completion includes a
	self-referential component.
	(Enter_Name): Use Is_Inherited_Operation to distinguish a source
	renaming or an instantiation from an implicit derived operation.

2004-06-28  Pascal Obry  <obry@gnat.com>

	* mlib-tgt-mingw.adb: (Library_Exists_For): Remove "lib" prefix from
	DLL.
	(Library_File_Name_For): Idem.

2004-06-28  Matthew Gingell  <gingell@gnat.com>

	* g-traceb.ads: Add explanatory note on the format of addresses
	expected by addr2line.

2004-06-28  Jerome Guitton  <guitton@act-europe.fr>

	* Makefile.in: Force debugging information on s-tasdeb.adb,
	a-except.adb and s-assert.adb needed by the debugger.

2004-06-28  Vincent Celier  <celier@gnat.com>

	* make.adb (Collect_Arguments_And_Compile): Change Flag1 to
	Need_To_Build_Lib.
	(Gnatmake): Ditto.

	* mlib-prj.adb (Check_Library): Replace Flag1 with Need_To_Build_Lib

	* prj.adb: Minor reformatting
	(Project_Empty): Change Flag1 to Need_To_Build_Lib. Remove Flag2.

	* prj.ads: Comment updates
	Minor reformatting
	(Project_Data): Change Flag1 to Need_To_Build_Lib.
	Remove Flag2: not used.

	* prj-dect.adb (Parse_Declarative_Items): Accept "null" as a
	declaration.

	* gnat_ugn.texi: Put a "null;" declaration in one project file example

	* gnat_rm.texi: Document Empty declarations "null;".

	* makegpr.adb (Compile_Link_With_Gnatmake): Put the global archives in
	front of the linker options.
	(Link_Foreign): Put the global archives and the libraries in front of
	the linker options.

2004-06-28  Javier Miranda  <miranda@gnat.com>

	* rtsfind.adb: (Get_Unit_Name): Fix typo in comment
	(RTU_Loaded): Code cleanup
	(Set_RTU_Loaded): New procedure to register as *loaded* explicitly
	withed predefined units.

	* rtsfind.ads (Set_RTU_Loaded): New procedure to register as *loaded*
	explicitly withed predefined units.
	Fix typo in comment

	* sem_ch10.adb (Analyze_Compilation_Unit): Register as *loaded*
	explicitly withed predefined units.

From-SVN: r83789
This commit is contained in:
Arnaud Charlet 2004-06-28 16:37:05 +02:00
parent 45da19e38e
commit 246d2ceb32
31 changed files with 564 additions and 317 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

92
gcc/ada/ChangeLog
View file

@ -1,3 +1,95 @@
2004-06-28 Robert Dewar <dewar@gnat.com>
* mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb,
mlib-tgt-irix.adb, mlib-tgt-hpux.adb, mlib-tgt-linux.adb,
mlib-tgt-linux.adb, mlib-tgt-solaris.adb, mlib-tgt-solaris.adb,
mlib-tgt-vms-alpha.adb, mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb,
a-strmap.adb, a-strmap.ads, clean.adb: Minor reformatting
* exp_util.adb (Is_Possibly_Unaligned_Slice): Completely rewritten, to
deal with problem of inefficient slices on machines with strict
alignment, when the slice is a component of a composite.
* checks.adb (Apply_Array_Size_Check): Do not special case 64-bit
machines, we need the check there as well.
2004-06-28 Ed Schonberg <schonberg@gnat.com>
* exp_ch5.adb (Expand_Assign_Array): Use correct condition to
determine safe copying direction for overlapping slice assignments
when component is controlled.
* sem_ch12.adb (Instantiate_Formal_Package): Implicit operations of a
formal derived type in the actual for a formal package are visible in
the enclosing instance.
2004-06-28 Ed Schonberg <schonberg@gnat.com>
PR ada/15600
* sem_util.adb (Trace_Components): Diagnose properly an illegal
circularity involving a private type whose completion includes a
self-referential component.
(Enter_Name): Use Is_Inherited_Operation to distinguish a source
renaming or an instantiation from an implicit derived operation.
2004-06-28 Pascal Obry <obry@gnat.com>
* mlib-tgt-mingw.adb: (Library_Exists_For): Remove "lib" prefix from
DLL.
(Library_File_Name_For): Idem.
2004-06-28 Matthew Gingell <gingell@gnat.com>
* g-traceb.ads: Add explanatory note on the format of addresses
expected by addr2line.
2004-06-28 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in: Force debugging information on s-tasdeb.adb,
a-except.adb and s-assert.adb needed by the debugger.
2004-06-28 Vincent Celier <celier@gnat.com>
* make.adb (Collect_Arguments_And_Compile): Change Flag1 to
Need_To_Build_Lib.
(Gnatmake): Ditto.
* mlib-prj.adb (Check_Library): Replace Flag1 with Need_To_Build_Lib
* prj.adb: Minor reformatting
(Project_Empty): Change Flag1 to Need_To_Build_Lib. Remove Flag2.
* prj.ads: Comment updates
Minor reformatting
(Project_Data): Change Flag1 to Need_To_Build_Lib.
Remove Flag2: not used.
* prj-dect.adb (Parse_Declarative_Items): Accept "null" as a
declaration.
* gnat_ugn.texi: Put a "null;" declaration in one project file example
* gnat_rm.texi: Document Empty declarations "null;".
* makegpr.adb (Compile_Link_With_Gnatmake): Put the global archives in
front of the linker options.
(Link_Foreign): Put the global archives and the libraries in front of
the linker options.
2004-06-28 Javier Miranda <miranda@gnat.com>
* rtsfind.adb: (Get_Unit_Name): Fix typo in comment
(RTU_Loaded): Code cleanup
(Set_RTU_Loaded): New procedure to register as *loaded* explicitly
withed predefined units.
* rtsfind.ads (Set_RTU_Loaded): New procedure to register as *loaded*
explicitly withed predefined units.
Fix typo in comment
* sem_ch10.adb (Analyze_Compilation_Unit): Register as *loaded*
explicitly withed predefined units.
2004-06-25 Pascal Obry <obry@gnat.com>
* makegpr.adb (Build_Library): Remove parameter Lib_Address and

22
gcc/ada/Makefile.in
View file

@ -1892,6 +1892,28 @@ endif
s-traceb.o : s-traceb.adb
$(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) \
$(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) \
$< $(OUTPUT_OPTION)
# force debugging information on s-tasdeb.o so that it is always
# possible to set conditional breakpoints on tasks.
s-tasdeb.o : s-tasdeb.adb s-tasdeb.ads
$(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \
$< $(OUTPUT_OPTION)
# force debugging information on a-except.o so that it is always
# possible to set conditional breakpoints on exceptions.
# use -O1 otherwise gdb isn't able to get a full backtrace on mips targets.
a-except.o : a-except.adb a-except.ads
$(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \
$(ADA_INCLUDES) $< $(OUTPUT_OPTION)
# force debugging information on s-assert.o so that it is always
# possible to set breakpoint on assert failures.
s-assert.o : s-assert.adb s-assert.ads a-except.ads
$(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 $(ADA_INCLUDES) \
$< $(OUTPUT_OPTION)
adadecode.o : adadecode.c adadecode.h

53
gcc/ada/a-strmap.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -54,7 +54,7 @@ package body Ada.Strings.Maps is
-- "=" --
---------
function "=" (Left, Right : in Character_Set) return Boolean is
function "=" (Left, Right : Character_Set) return Boolean is
begin
return Character_Set_Internal (Left) = Character_Set_Internal (Right);
end "=";
@ -63,7 +63,7 @@ package body Ada.Strings.Maps is
-- "and" --
-----------
function "and" (Left, Right : in Character_Set) return Character_Set is
function "and" (Left, Right : Character_Set) return Character_Set is
begin
return Character_Set
(Character_Set_Internal (Left) and Character_Set_Internal (Right));
@ -73,7 +73,7 @@ package body Ada.Strings.Maps is
-- "not" --
-----------
function "not" (Right : in Character_Set) return Character_Set is
function "not" (Right : Character_Set) return Character_Set is
begin
return Character_Set (not Character_Set_Internal (Right));
end "not";
@ -82,7 +82,7 @@ package body Ada.Strings.Maps is
-- "or" --
----------
function "or" (Left, Right : in Character_Set) return Character_Set is
function "or" (Left, Right : Character_Set) return Character_Set is
begin
return Character_Set
(Character_Set_Internal (Left) or Character_Set_Internal (Right));
@ -92,7 +92,7 @@ package body Ada.Strings.Maps is
-- "xor" --
-----------
function "xor" (Left, Right : in Character_Set) return Character_Set is
function "xor" (Left, Right : Character_Set) return Character_Set is
begin
return Character_Set
(Character_Set_Internal (Left) xor Character_Set_Internal (Right));
@ -104,8 +104,7 @@ package body Ada.Strings.Maps is
function Is_In
(Element : Character;
Set : Character_Set)
return Boolean
Set : Character_Set) return Boolean
is
begin
return Set (Element);
@ -117,8 +116,7 @@ package body Ada.Strings.Maps is
function Is_Subset
(Elements : Character_Set;
Set : Character_Set)
return Boolean
Set : Character_Set) return Boolean
is
begin
return (Elements and Set) = Elements;
@ -128,7 +126,7 @@ package body Ada.Strings.Maps is
-- To_Domain --
---------------
function To_Domain (Map : in Character_Mapping) return Character_Sequence
function To_Domain (Map : Character_Mapping) return Character_Sequence
is
Result : String (1 .. Map'Length);
J : Natural;
@ -150,8 +148,7 @@ package body Ada.Strings.Maps is
----------------
function To_Mapping
(From, To : in Character_Sequence)
return Character_Mapping
(From, To : Character_Sequence) return Character_Mapping
is
Result : Character_Mapping;
Inserted : Character_Set := Null_Set;
@ -183,11 +180,10 @@ package body Ada.Strings.Maps is
-- To_Range --
--------------
function To_Range (Map : in Character_Mapping) return Character_Sequence
function To_Range (Map : Character_Mapping) return Character_Sequence
is
Result : String (1 .. Map'Length);
J : Natural;
begin
J := 0;
for C in Map'Range loop
@ -204,7 +200,7 @@ package body Ada.Strings.Maps is
-- To_Ranges --
---------------
function To_Ranges (Set : in Character_Set) return Character_Ranges is
function To_Ranges (Set : Character_Set) return Character_Ranges is
Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1);
Range_Num : Natural;
C : Character;
@ -214,7 +210,7 @@ package body Ada.Strings.Maps is
Range_Num := 0;
loop
-- Skip gap between subsets.
-- Skip gap between subsets
while not Set (C) loop
exit when C = Character'Last;
@ -226,7 +222,7 @@ package body Ada.Strings.Maps is
Range_Num := Range_Num + 1;
Max_Ranges (Range_Num).Low := C;
-- Span a subset.
-- Span a subset
loop
exit when not Set (C) or else C = Character'Last;
@ -248,13 +244,9 @@ package body Ada.Strings.Maps is
-- To_Sequence --
-----------------
function To_Sequence
(Set : Character_Set)
return Character_Sequence
is
function To_Sequence (Set : Character_Set) return Character_Sequence is
Result : String (1 .. Character'Pos (Character'Last) + 1);
Count : Natural := 0;
begin
for Char in Set'Range loop
if Set (Char) then
@ -270,9 +262,8 @@ package body Ada.Strings.Maps is
-- To_Set --
------------
function To_Set (Ranges : in Character_Ranges) return Character_Set is
function To_Set (Ranges : Character_Ranges) return Character_Set is
Result : Character_Set;
begin
for C in Result'Range loop
Result (C) := False;
@ -287,9 +278,8 @@ package body Ada.Strings.Maps is
return Result;
end To_Set;
function To_Set (Span : in Character_Range) return Character_Set is
function To_Set (Span : Character_Range) return Character_Set is
Result : Character_Set;
begin
for C in Result'Range loop
Result (C) := False;
@ -304,7 +294,6 @@ package body Ada.Strings.Maps is
function To_Set (Sequence : Character_Sequence) return Character_Set is
Result : Character_Set := Null_Set;
begin
for J in Sequence'Range loop
Result (Sequence (J)) := True;
@ -315,7 +304,6 @@ package body Ada.Strings.Maps is
function To_Set (Singleton : Character) return Character_Set is
Result : Character_Set := Null_Set;
begin
Result (Singleton) := True;
return Result;
@ -325,9 +313,10 @@ package body Ada.Strings.Maps is
-- Value --
-----------
function Value (Map : in Character_Mapping; Element : in Character)
return Character is
function Value
(Map : Character_Mapping;
Element : Character) return Character
is
begin
return Map (Element);
end Value;

56
gcc/ada/a-strmap.ads
View file

@ -61,48 +61,44 @@ pragma Preelaborate (Maps);
type Character_Ranges is array (Positive range <>) of Character_Range;
function To_Set (Ranges : in Character_Ranges) return Character_Set;
function To_Set (Ranges : Character_Ranges) return Character_Set;
function To_Set (Span : in Character_Range) return Character_Set;
function To_Set (Span : Character_Range) return Character_Set;
function To_Ranges (Set : in Character_Set) return Character_Ranges;
function To_Ranges (Set : Character_Set) return Character_Ranges;
----------------------------------
-- Operations on Character Sets --
----------------------------------
function "=" (Left, Right : in Character_Set) return Boolean;
function "=" (Left, Right : Character_Set) return Boolean;
function "not" (Right : in Character_Set) return Character_Set;
function "and" (Left, Right : in Character_Set) return Character_Set;
function "or" (Left, Right : in Character_Set) return Character_Set;
function "xor" (Left, Right : in Character_Set) return Character_Set;
function "-" (Left, Right : in Character_Set) return Character_Set;
function "not" (Right : Character_Set) return Character_Set;
function "and" (Left, Right : Character_Set) return Character_Set;
function "or" (Left, Right : Character_Set) return Character_Set;
function "xor" (Left, Right : Character_Set) return Character_Set;
function "-" (Left, Right : Character_Set) return Character_Set;
function Is_In
(Element : in Character;
Set : in Character_Set)
return Boolean;
(Element : Character;
Set : Character_Set) return Boolean;
function Is_Subset
(Elements : in Character_Set;
Set : in Character_Set)
return Boolean;
(Elements : Character_Set;
Set : Character_Set) return Boolean;
function "<="
(Left : in Character_Set;
Right : in Character_Set)
return Boolean
(Left : Character_Set;
Right : Character_Set) return Boolean
renames Is_Subset;
subtype Character_Sequence is String;
-- Alternative representation for a set of character values
function To_Set (Sequence : in Character_Sequence) return Character_Set;
function To_Set (Sequence : Character_Sequence) return Character_Set;
function To_Set (Singleton : Character) return Character_Set;
function To_Set (Singleton : in Character) return Character_Set;
function To_Sequence (Set : in Character_Set) return Character_Sequence;
function To_Sequence (Set : Character_Set) return Character_Sequence;
------------------------------------
-- Character Mapping Declarations --
@ -112,9 +108,8 @@ pragma Preelaborate (Maps);
-- Representation for a character to character mapping:
function Value
(Map : in Character_Mapping;
Element : in Character)
return Character;
(Map : Character_Mapping;
Element : Character) return Character;
Identity : constant Character_Mapping;
@ -123,19 +118,16 @@ pragma Preelaborate (Maps);
----------------------------
function To_Mapping
(From, To : in Character_Sequence)
return Character_Mapping;
(From, To : Character_Sequence) return Character_Mapping;
function To_Domain
(Map : in Character_Mapping)
return Character_Sequence;
(Map : Character_Mapping) return Character_Sequence;
function To_Range
(Map : in Character_Mapping)
return Character_Sequence;
(Map : Character_Mapping) return Character_Sequence;
type Character_Mapping_Function is
access function (From : in Character) return Character;
access function (From : Character) return Character;
private
pragma Inline (Is_In);

7
gcc/ada/checks.adb
View file

@ -831,13 +831,6 @@ package body Checks is
if Size_Known_At_Compile_Time (Typ) then
return;
end if;
-- No problem on 64-bit machines, we just don't bother with
-- the case where the size in bytes overflows 64-bits.
if System_Address_Size = 64 then
return;
end if;
end if;
-- Following code is temporarily deleted, since GCC 3 is returning

35
gcc/ada/clean.adb
View file

@ -325,15 +325,14 @@ package body Clean is
procedure Clean_Archive (Project : Project_Id) is
Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
Data : constant Project_Data := Projects.Table (Project);
Archive_Name : constant String :=
"lib" & Get_Name_String (Data.Name) & '.' & Archive_Ext;
"lib" & Get_Name_String (Data.Name) & '.' & Archive_Ext;
-- The name of the archive file for this project
Archive_Dep_Name : constant String :=
"lib" & Get_Name_String (Data.Name) & ".deps";
"lib" & Get_Name_String (Data.Name) & ".deps";
-- The name of the archive dependency file for this project
Obj_Dir : constant String := Get_Name_String (Data.Object_Directory);
@ -439,8 +438,7 @@ package body Clean is
Extract_From_Q (Lib_File);
Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
-- If we have an existing ALI file that is not read-only,
-- process it.
-- If we have existing ALI file that is not read-only, process it
if Full_Lib_File /= No_File
and then not Is_Readonly_Library (Full_Lib_File)
@ -484,8 +482,7 @@ package body Clean is
end if;
end if;
-- Now, delete all the existing files corresponding to this
-- ALI file.
-- Now delete all existing files corresponding to this ALI file
declare
Obj_Dir : constant String :=
@ -515,9 +512,10 @@ package body Clean is
for J in 1 .. Sources.Last loop
declare
Deb : constant String :=
Debug_File_Name (Sources.Table (J));
Debug_File_Name (Sources.Table (J));
Rep : constant String :=
Repinfo_File_Name (Sources.Table (J));
Repinfo_File_Name (Sources.Table (J));
begin
if Is_Regular_File (Obj_Dir & Dir_Separator & Deb) then
Delete (Obj_Dir, Deb);
@ -557,8 +555,7 @@ package body Clean is
procedure Clean_Project (Project : Project_Id) is
Main_Source_File : File_Name_Type;
-- Name of the executable on the command line, without directory
-- information.
-- Name of executable on the command line without directory info
Executable : Name_Id;
-- Name of the executable file
@ -610,7 +607,8 @@ package body Clean is
begin
Change_Dir (Obj_Dir);
-- First, deal with Ada.
-- First, deal with Ada
-- Look through the units to find those that are either immediate
-- sources or inherited sources of the project.
@ -765,8 +763,9 @@ package body Clean is
end if;
if Data.Other_Sources_Present then
-- There is non-Ada code: delete the object files and
-- the dependency files, if they exist.
-- the dependency files if they exist.
Source_Id := Data.First_Other_Source;
@ -1093,8 +1092,8 @@ package body Clean is
Prj.Pars.Set_Verbosity (To => Prj.Com.Current_Verbosity);
-- Parse the project file.
-- If there is an error, Main_Project will still be No_Project.
-- Parse the project file. If there is an error, Main_Project
-- will still be No_Project.
Prj.Pars.Parse
(Project => Main_Project,
@ -1103,8 +1102,7 @@ package body Clean is
Process_Languages => All_Languages);
if Main_Project = No_Project then
Fail ("""" & Project_File_Name.all &
""" processing failed");
Fail ("""" & Project_File_Name.all & """ processing failed");
end if;
if Opt.Verbose_Mode then
@ -1311,7 +1309,8 @@ package body Clean is
procedure Parse_Cmd_Line is
Source_Index : Int := 0;
Index : Positive := 1;
Last : constant Natural := Argument_Count;
Last : constant Natural := Argument_Count;
begin
while Index <= Last loop
declare

9
gcc/ada/exp_ch5.adb
View file

@ -826,8 +826,8 @@ package body Exp_Ch5 is
-- the explicit bounds of right- and left-hand side.
declare
Proc : constant Node_Id :=
TSS (Base_Type (L_Type), TSS_Slice_Assign);
Proc : constant Node_Id :=
TSS (Base_Type (L_Type), TSS_Slice_Assign);
Actuals : List_Id;
begin
@ -840,7 +840,10 @@ package body Exp_Ch5 is
Duplicate_Subexpr (Left_Hi, Name_Req => True),
Duplicate_Subexpr (Right_Lo, Name_Req => True),
Duplicate_Subexpr (Right_Hi, Name_Req => True));
Append_To (Actuals, Condition);
Append_To (Actuals,
Make_Op_Not (Loc,
Right_Opnd => Condition));
Rewrite (N,
Make_Procedure_Call_Statement (Loc,

168
gcc/ada/exp_util.adb
View file

@ -2384,34 +2384,6 @@ package body Exp_Util is
---------------------------------
function Is_Possibly_Unaligned_Slice (P : Node_Id) return Boolean is
function Has_Non_Trivial_Component_Clause (E : Entity_Id) return Boolean;
-- Check whether the component clause might place the component at an
-- alignment that will require the use of a copy when a slice is passed
-- as a parameter. The code is conservative because at this point the
-- expander does not know the alignment choice that the back-end will
-- make. For now we return true if the component is not the first one
-- in the enclosing record. This routine is a place holder for further
-- analysis of this kind.
--------------------------------------
-- Has_Non_Trivial_Component_Clause --
--------------------------------------
function Has_Non_Trivial_Component_Clause (E : Entity_Id) return Boolean
is
Rep_Clause : constant Node_Id := Component_Clause (E);
begin
if No (Rep_Clause) then
return False;
else
return Intval (Position (Rep_Clause)) /= Uint_0
or else Intval (First_Bit (Rep_Clause)) /= Uint_0;
end if;
end Has_Non_Trivial_Component_Clause;
-- Start of processing for Is_Possibly_Unaligned_Slice
begin
-- ??? GCC3 will eventually handle strings with arbitrary alignments,
-- but for now the following check must be disabled.
@ -2420,6 +2392,8 @@ package body Exp_Util is
-- return False;
-- end if;
-- For renaming case, go to renamed object
if Is_Entity_Name (P)
and then Is_Object (Entity (P))
and then Present (Renamed_Object (Entity (P)))
@ -2427,57 +2401,121 @@ package body Exp_Util is
return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (P)));
end if;
-- We only need to worry if the target has strict alignment, unless
-- it is a nested record component with a component clause, which
-- Gigi does not handle well. This patch should disappear with GCC 3.0
-- and it is not clear why it is needed even when the representation
-- clause is a confirming one, but in its absence gigi complains that
-- the slice is not addressable.???
if not Target_Strict_Alignment then
if Nkind (P) /= N_Slice
or else Nkind (Prefix (P)) /= N_Selected_Component
or else Nkind (Prefix (Prefix (P))) /= N_Selected_Component
then
return False;
end if;
end if;
-- The reference must be a slice
if Nkind (P) /= N_Slice then
return False;
end if;
-- Always assume the worst for a nested record component with a
-- component clause, which gigi/gcc does not appear to handle well.
-- It is not clear why this special test is needed at all ???
if Nkind (Prefix (P)) = N_Selected_Component
and then Nkind (Prefix (Prefix (P))) = N_Selected_Component
and then
Present (Component_Clause (Entity (Selector_Name (Prefix (P)))))
then
return True;
end if;
-- We only need to worry if the target has strict alignment
if not Target_Strict_Alignment then
return False;
end if;
-- If it is a slice, then look at the array type being sliced
declare
Pref : constant Node_Id := Prefix (P);
Typ : constant Entity_Id := Etype (Prefix (P));
Sarr : constant Node_Id := Prefix (P);
-- Prefix of the slice, i.e. the array being sliced
Styp : constant Entity_Id := Etype (Prefix (P));
-- Type of the array being sliced
Pref : Node_Id;
Ptyp : Entity_Id;
begin
-- The worrisome case is one where we don't know the alignment
-- of the array, or we know it and it is greater than 1 (if the
-- alignment is one, then obviously it cannot be misaligned).
-- The problems arise if the array object that is being sliced
-- is a component of a record or array, and we cannot guarantee
-- the alignment of the array within its containing object.
if Known_Alignment (Typ) and then Alignment (Typ) = 1 then
return False;
end if;
-- To investigate this, we look at successive prefixes to see
-- if we have a worrisome indexed or selected component.
-- The only way we can be unaligned is if the array being sliced
-- is a component of a record, and either the record is packed,
-- or the component has a component clause, or the record has
-- a specified alignment (that might be too small).
Pref := Sarr;
loop
-- Case of array is part of an indexed component reference
return
Nkind (Pref) = N_Selected_Component
and then
(Is_Packed (Etype (Prefix (Pref)))
or else
Known_Alignment (Etype (Prefix (Pref)))
or else
Has_Non_Trivial_Component_Clause
(Entity (Selector_Name (Pref))));
if Nkind (Pref) = N_Indexed_Component then
Ptyp := Etype (Prefix (Pref));
-- The only problematic case is when the array is packed,
-- in which case we really know nothing about the alignment
-- of individual components.
if Is_Bit_Packed_Array (Ptyp) then
return True;
end if;
-- Case of array is part of a selected component reference
elsif Nkind (Pref) = N_Selected_Component then
Ptyp := Etype (Prefix (Pref));
-- We are definitely in trouble if the record in question
-- has an alignment, and either we know this alignment is
-- inconsistent with the alignment of the slice, or we
-- don't know what the alignment of the slice should be.
if Known_Alignment (Ptyp)
and then (Unknown_Alignment (Styp)
or else Alignment (Styp) > Alignment (Ptyp))
then
return True;
end if;
-- We are in potential trouble if the record type is packed.
-- We could special case when we know that the array is the
-- first component, but that's not such a simple case ???
if Is_Packed (Ptyp) then
return True;
end if;
-- We are in trouble if there is a component clause, and
-- either we do not know the alignment of the slice, or
-- the alignment of the slice is inconsistent with the
-- bit position specified by the component clause.
declare
Field : constant Entity_Id := Entity (Selector_Name (Pref));
begin
if Present (Component_Clause (Field))
and then
(Unknown_Alignment (Styp)
or else
(Component_Bit_Offset (Field) mod
(System_Storage_Unit * Alignment (Styp))) /= 0)
then
return True;
end if;
end;
-- For cases other than selected or indexed components we
-- know we are OK, since no issues arise over alignment.
else
return False;
end if;
-- We processed an indexed component or selected component
-- reference that looked safe, so keep checking prefixes.
Pref := Prefix (Pref);
end loop;
end;
end Is_Possibly_Unaligned_Slice;

3
gcc/ada/g-traceb.ads
View file

@ -54,7 +54,8 @@
-- Compile without -g
-- Run the program, and call Call_Chain
-- Recompile with -g
-- Use addr2line to interpret the absolute call locations
-- Use addr2line to interpret the absolute call locations (note that
-- addr2line expects addresses in hexadecimal format).
-- This capability is currently supported on the following targets:

17
gcc/ada/gnat_rm.texi
View file

@ -13309,6 +13309,7 @@ See the chapter on project files in the GNAT Users guide for examples of use.
* Reserved Words::
* Lexical Elements::
* Declarations::
* Empty declarations::
* Typed string declarations::
* Variables::
* Expressions::
@ -13379,9 +13380,21 @@ simple_declarative_item ::=
variable_declaration |
typed_variable_declaration |
attribute_declaration |
case_construction
case_construction |
empty_declaration
@end smallexample
@node Empty declarations
@section Empty declarations
@smallexample
empty_declaration ::=
@b{null} ;
@end smallexample
An empty declaration is allowed anywhere a declaration is allowed.
It has no effect.
@node Typed string declarations
@section Typed string declarations
@ -13683,7 +13696,7 @@ case_construction ::=
case_item ::=
@b{when} discrete_choice_list =>
@{case_construction | attribute_declaration@}
@{case_construction | attribute_declaration | empty_declaration@}
discrete_choice_list ::=
string_literal @{| string_literal@} |

2
gcc/ada/gnat_ugn.texi
View file

@ -10809,6 +10809,8 @@ project Build is
for ^Default_Switches^Default_Switches^ ("Ada")
use ("^-g^-g^");
for Executable ("proc") use "proc1";
when others =>
null;
end case;
end Builder;

16
gcc/ada/make.adb
View file

@ -2231,7 +2231,9 @@ package body Make is
The_Data := Projects.Table (Prj);
end loop;
if The_Data.Library and then not The_Data.Flag1 then
if The_Data.Library
and then not The_Data.Need_To_Build_Lib
then
-- Add to the Q all sources of the project that
-- have not been marked
@ -2242,7 +2244,7 @@ package body Make is
-- Now mark the project as processed
Projects.Table (Prj).Flag1 := True;
Projects.Table (Prj).Need_To_Build_Lib := True;
end if;
end;
end if;
@ -4337,10 +4339,10 @@ package body Make is
if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then
for Proj in Projects.First .. Projects.Last loop
if Projects.Table (Proj).Library then
Projects.Table (Proj).Flag1 :=
Projects.Table (Proj).Need_To_Build_Lib :=
not MLib.Tgt.Library_Exists_For (Proj);
if Projects.Table (Proj).Flag1 then
if Projects.Table (Proj).Need_To_Build_Lib then
if Verbose_Mode then
Write_Str
("Library file does not exist for project """);
@ -4722,12 +4724,12 @@ package body Make is
end if;
if Projects.Table (Proj1).Library
and then not Projects.Table (Proj1).Flag1
and then not Projects.Table (Proj1).Need_To_Build_Lib
then
MLib.Prj.Check_Library (Proj1);
end if;
if Projects.Table (Proj1).Flag1 then
if Projects.Table (Proj1).Need_To_Build_Lib then
Library_Projs.Increment_Last;
Current := Library_Projs.Last;
Depth := Projects.Table (Proj1).Depth;
@ -4744,7 +4746,7 @@ package body Make is
end loop;
Library_Projs.Table (Current) := Proj1;
Projects.Table (Proj1).Flag1 := False;
Projects.Table (Proj1).Need_To_Build_Lib := False;
end if;
end loop;
end;

23
gcc/ada/makegpr.adb
View file

@ -2395,16 +2395,10 @@ package body Makegpr is
if not Compile_Only then
-- If there are linking options from the command line,
-- transmit them to gnatmake.
-- Linking options
if Linker_Options.Last /= 0 then
Add_Argument (Dash_largs, True);
for Arg in 1 .. Linker_Options.Last loop
Add_Argument (Linker_Options.Table (Arg), True);
end loop;
else
Add_Argument (Dash_largs, Verbose_Mode);
end if;
@ -2412,6 +2406,13 @@ package body Makegpr is
-- Add the archives
Add_Archives (For_Gnatmake => True);
-- If there are linking options from the command line,
-- transmit them to gnatmake.
for Arg in 1 .. Linker_Options.Last loop
Add_Argument (Linker_Options.Table (Arg), True);
end loop;
end if;
-- And invoke gnatmake
@ -3318,6 +3319,10 @@ package body Makegpr is
Get_Name_String (Source.Object_Name),
True);
-- Add all the archives, in a correct order
Add_Archives (For_Gnatmake => False);
-- Add the switches specified in package Linker of
-- the main project.
@ -3345,10 +3350,6 @@ package body Makegpr is
Add_Argument (Linker_Options.Table (Arg), True);
end loop;
-- Add all the archives, in a correct order
Add_Archives (For_Gnatmake => False);
-- If there are shared libraries and the run path
-- option is supported, add the run path switch.

14
gcc/ada/mlib-prj.adb
View file

@ -1556,7 +1556,7 @@ package body MLib.Prj is
Data : constant Project_Data := Projects.Table (For_Project);
begin
if Data.Library and not Data.Flag1 then
if Data.Library and not Data.Need_To_Build_Lib then
declare
Current : constant Dir_Name_Str := Get_Current_Dir;
Lib_Name : constant Name_Id := Library_File_Name_For (For_Project);
@ -1596,17 +1596,17 @@ package body MLib.Prj is
Obj_TS := File_Stamp (Name_Find);
-- If library file time stamp is earlier, set Flag1 and
-- return. String comparaison is used, otherwise time stamps
-- may be too close and the comparaison would return True,
-- which would trigger an unnecessary rebuild of the
-- library.
-- If library file time stamp is earlier, set
-- Need_To_Build_Lib and return. String comparaison is used,
-- otherwise time stamps may be too close and the
-- comparaison would return True, which would trigger
-- an unnecessary rebuild of the library.
if String (Lib_TS) < String (Obj_TS) then
-- Library must be rebuilt
Projects.Table (For_Project).Flag1 := True;
Projects.Table (For_Project).Need_To_Build_Lib := True;
exit;
end if;
end if;

4
gcc/ada/mlib-tgt-aix.adb
View file

@ -134,8 +134,8 @@ package body MLib.Tgt is
pragma Unreferenced (Lib_Version);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
Lib_Dir & Directory_Separator & "lib" &
MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
-- The file name of the library
Init_Fini : Argument_List_Access := Empty_Argument_List;

5
gcc/ada/mlib-tgt-hpux.adb
View file

@ -113,8 +113,8 @@ package body MLib.Tgt is
pragma Unreferenced (Symbol_Data);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
Lib_Dir & Directory_Separator & "lib" &
MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
Version_Arg : String_Access;
Symbolic_Link_Needed : Boolean := False;
@ -135,6 +135,7 @@ package body MLib.Tgt is
end if;
-- If specified, add automatic elaboration/finalization
if Auto_Init then
Init_Fini := Init_Fini_List;
Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init");

5
gcc/ada/mlib-tgt-irix.adb
View file

@ -114,8 +114,8 @@ package body MLib.Tgt is
pragma Unreferenced (Symbol_Data);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
Lib_Dir & Directory_Separator & "lib" &
MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
Version_Arg : String_Access;
Symbolic_Link_Needed : Boolean := False;
@ -129,6 +129,7 @@ package body MLib.Tgt is
end if;
-- If specified, add automatic elaboration/finalization
if Auto_Init then
Init_Fini := Init_Fini_List;
Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init");

5
gcc/ada/mlib-tgt-linux.adb
View file

@ -117,8 +117,8 @@ package body MLib.Tgt is
pragma Unreferenced (Symbol_Data);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
Fil.Ext_To (Lib_Filename, DLL_Ext);
Lib_Dir & Directory_Separator & "lib" &
Fil.Ext_To (Lib_Filename, DLL_Ext);
Version_Arg : String_Access;
Symbolic_Link_Needed : Boolean := False;
@ -132,6 +132,7 @@ package body MLib.Tgt is
end if;
-- If specified, add automatic elaboration/finalization
if Auto_Init then
Init_Fini := Init_Fini_List;
Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init");

12
gcc/ada/mlib-tgt-mingw.adb
View file

@ -107,8 +107,8 @@ package body MLib.Tgt is
pragma Unreferenced (Lib_Version);
Lib_File : constant String :=
Lib_Dir & Directory_Separator &
Files.Ext_To (Lib_Filename, DLL_Ext);
Lib_Dir & Directory_Separator &
Files.Ext_To (Lib_Filename, DLL_Ext);
-- Start of processing for Build_Dynamic_Library
@ -207,7 +207,7 @@ package body MLib.Tgt is
else
return Is_Regular_File
(Lib_Dir & Directory_Separator & "lib" &
(Lib_Dir & Directory_Separator &
MLib.Fil.Ext_To (Lib_Name, DLL_Ext));
end if;
end;
@ -231,13 +231,13 @@ package body MLib.Tgt is
Get_Name_String (Projects.Table (Project).Library_Name);
begin
Name_Len := 3;
Name_Buffer (1 .. Name_Len) := "lib";
if Projects.Table (Project).Library_Kind = Static then
Name_Len := 3;
Name_Buffer (1 .. Name_Len) := "lib";
Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
else
Name_Len := 0;
Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
end if;

5
gcc/ada/mlib-tgt-solaris.adb
View file

@ -111,8 +111,8 @@ package body MLib.Tgt is
pragma Unreferenced (Symbol_Data);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
Fil.Ext_To (Lib_Filename, DLL_Ext);
Lib_Dir & Directory_Separator & "lib" &
Fil.Ext_To (Lib_Filename, DLL_Ext);
Version_Arg : String_Access;
Symbolic_Link_Needed : Boolean := False;
@ -126,6 +126,7 @@ package body MLib.Tgt is
end if;
-- If specified, add automatic elaboration/finalization
if Auto_Init then
Init_Fini := Init_Fini_List;
Init_Fini (1) :=

4
gcc/ada/mlib-tgt-tru64.adb
View file

@ -119,8 +119,8 @@ package body MLib.Tgt is
pragma Unreferenced (Symbol_Data);
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
Fil.Ext_To (Lib_Filename, DLL_Ext);
Lib_Dir & Directory_Separator & "lib" &
Fil.Ext_To (Lib_Filename, DLL_Ext);
Version_Arg : String_Access;
Symbolic_Link_Needed : Boolean := False;

6
gcc/ada/mlib-tgt-vms-alpha.adb
View file

@ -140,7 +140,7 @@ package body MLib.Tgt is
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
Fil.Ext_To (Lib_Filename, DLL_Ext);
Fil.Ext_To (Lib_Filename, DLL_Ext);
Opts : Argument_List := Options;
Last_Opt : Natural := Opts'Last;
@ -151,8 +151,8 @@ package body MLib.Tgt is
function Is_Interface (Obj_File : String) return Boolean;
-- For a Stand-Alone Library, returns True if Obj_File is the object
-- file name of an interface of the SAL.
-- For other libraries, always return True.
-- file name of an interface of the SAL. For other libraries, always
-- return True.
function Option_File_Name return String;
-- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"

6
gcc/ada/mlib-tgt-vms-ia64.adb
View file

@ -140,7 +140,7 @@ package body MLib.Tgt is
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
Fil.Ext_To (Lib_Filename, DLL_Ext);
Fil.Ext_To (Lib_Filename, DLL_Ext);
Opts : Argument_List := Options;
Last_Opt : Natural := Opts'Last;
@ -151,8 +151,8 @@ package body MLib.Tgt is
function Is_Interface (Obj_File : String) return Boolean;
-- For a Stand-Alone Library, returns True if Obj_File is the object
-- file name of an interface of the SAL.
-- For other libraries, always return True.
-- file name of an interface of the SAL. For other libraries, always
-- return True.
function Option_File_Name return String;
-- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"

4
gcc/ada/prj-dect.adb
View file

@ -747,6 +747,10 @@ package body Prj.Dect is
Set_End_Of_Line (Current_Declaration);
Set_Previous_Line_Node (Current_Declaration);
when Tok_Null =>
Scan; -- past "null"
when Tok_Package =>
-- Package declaration

5
gcc/ada/prj.adb
View file

@ -78,8 +78,8 @@ package body Prj is
First_Referred_By => No_Project,
Name => No_Name,
Path_Name => No_Name,
Virtual => False,
Display_Path_Name => No_Name,
Virtual => False,
Location => No_Location,
Mains => Nil_String,
Directory => No_Name,
@ -127,8 +127,7 @@ package body Prj is
Language_Independent_Checked => False,
Checked => False,
Seen => False,
Flag1 => False,
Flag2 => False,
Need_To_Build_Lib => False,
Depth => 0,
Unkept_Comments => False);

204
gcc/ada/prj.ads
View file

@ -40,8 +40,8 @@ with GNAT.OS_Lib; use GNAT.OS_Lib;
package Prj is
Empty_Name : Name_Id;
-- Name_Id for an empty name (no characters).
-- Initialized by procedure Initialize.
-- Name_Id for an empty name (no characters). Initialized by the call
-- to procedure Initialize.
All_Packages : constant String_List_Access := null;
-- Default value of parameter Packages of procedures Parse, in Prj.Pars and
@ -52,9 +52,8 @@ package Prj is
-- normally forbidden for project names, there cannot be any name clash.
Project_File_Extension : String := ".gpr";
-- The standard project file name extension.
-- It is not a constant, because Canonical_Case_File_Name is called
-- on this variable in the body of Prj.
-- The standard project file name extension. It is not a constant, because
-- Canonical_Case_File_Name is called on this variable in the body of Prj.
Default_Ada_Spec_Suffix : Name_Id;
-- The Name_Id for the standard GNAT suffix for Ada spec source file
@ -72,15 +71,24 @@ package Prj is
type Programming_Language is
(Lang_Ada, Lang_C, Lang_C_Plus_Plus);
-- The list of language supported
-- The set of languages supported
subtype Other_Programming_Language is
Programming_Language range Lang_C .. Programming_Language'Last;
Programming_Language range Lang_C .. Programming_Language'Last;
-- The set of non-Ada languages supported
type Languages_In_Project is array (Programming_Language) of Boolean;
-- Set of supported languages used in a project
No_Languages : constant Languages_In_Project := (others => False);
-- No supported languages are used
type Impl_Suffix_Array is array (Programming_Language) of Name_Id;
-- Suffixes for the non spec sources of the different supported languages
-- in a project.
No_Impl_Suffixes : constant Impl_Suffix_Array := (others => No_Name);
-- A default value for the non spec source suffixes
Lang_Ada_Name : aliased String := "ada";
Lang_C_Name : aliased String := "c";
@ -93,7 +101,8 @@ package Prj is
-- -x when using a GCC compiler.
Lang_Name_Ids : array (Programming_Language) of Name_Id;
-- Initialized by Prj.Initialize
-- Same as Lang_Names, but using Name_Id, instead of String_Access.
-- Initialized by Prj.Initialize.
Lang_Ada_Display_Name : aliased String := "Ada";
Lang_C_Display_Name : aliased String := "C";
@ -115,8 +124,9 @@ package Prj is
Lang_C_Plus_Plus => C_Plus_Plus_Impl_Suffix'Access);
-- Default extension of the sources of the different languages.
Lang_Suffix_Ids : array (Programming_Language) of Name_Id;
-- Initialized by Prj.Initialize
Lang_Suffix_Ids : array (Programming_Language) of Name_Id;
-- Same as Lang_Suffixes, but using Name_Id, instead of String_Access.
-- Initialized by Prj.Initialize.
Gnatmake_String : aliased String := "gnatmake";
Gcc_String : aliased String := "gcc";
@ -137,6 +147,10 @@ package Prj is
(Lang_Ada => Ada_Args_Strings 'Access,
Lang_C => C_Args_String 'Access,
Lang_C_Plus_Plus => C_Plus_Plus_Args_String'Access);
-- For each supported language, the string between "-c" and "args" to
-- be used in the gprmake switch for the start of the compiling switch
-- section for each supported language. For example, "-ccargs" indicates
-- the start of the C compiler switch section.
type Other_Source_Id is new Nat;
No_Other_Source : constant Other_Source_Id := 0;
@ -154,6 +168,7 @@ package Prj is
Naming_Exception : Boolean := False; -- True if a naming exception
Next : Other_Source_Id := No_Other_Source;
end record;
-- Data for a source in a language other than Ada
package Other_Sources is new Table.Table
(Table_Component_Type => Other_Source,
@ -171,9 +186,13 @@ package Prj is
-- High is extremely verbose.
type Lib_Kind is (Static, Dynamic, Relocatable);
type Policy is (Autonomous, Compliant, Controlled, Restricted);
-- See explaination about this type in package Symbols
-- Type to specify the symbol policy, when symbol control is supported.
-- See full explanation about this type in package Symbols.
-- Autonomous: Create a symbol file without considering any reference
-- Compliant: Try to be as compatible as possible with an existing ref
-- Controlled: Fail if symbols are not the same as those in the reference
-- Restricted: Restrict the symbols to those in the symbol file
type Symbol_Record is record
Symbol_File : Name_Id := No_Name;
@ -186,8 +205,10 @@ package Prj is
(Symbol_File => No_Name,
Reference => No_Name,
Symbol_Policy => Autonomous);
-- The default value of the symbol data
function Empty_String return Name_Id;
-- Return the Name_Id for an empty string ""
type Project_Id is new Nat;
No_Project : constant Project_Id := 0;
@ -237,8 +258,8 @@ package Prj is
Index : Int := 0;
end case;
end record;
-- Values for variables and array elements.
-- Default is True if the current value is the default one for the variable
-- Values for variables and array elements. Default is True if the
-- current value is the default one for the variable
Nil_Variable_Value : constant Variable_Value :=
(Project => No_Project,
@ -314,13 +335,15 @@ package Prj is
Arrays : Array_Id := No_Array;
Packages : Package_Id := No_Package;
end record;
-- Contains the declarations (variables, single and array attributes,
-- packages) for a project or a package in a project.
No_Declarations : constant Declarations :=
(Variables => No_Variable,
Attributes => No_Variable,
Arrays => No_Array,
Packages => No_Package);
-- Declarations. Used in project structures and packages (what for???)
-- Default value of Declarations: indicates that there is no declarations.
type Package_Element is record
Name : Name_Id := No_Name;
@ -387,36 +410,32 @@ package Prj is
-- Current_Body_Suffix is defined.
Separate_Suffix : Name_Id := No_Name;
-- The string to append to the unit name for the
-- source file name of an Ada subunit.
-- String to append to unit name for source file name of an Ada subunit.
Sep_Suffix_Loc : Source_Ptr := No_Location;
-- The position in the project file source where
-- Separate_Suffix is defined.
-- Position in the project file source where Separate_Suffix is defined.
Specs : Array_Element_Id := No_Array_Element;
-- An associative array mapping individual specs
-- to source file names. Specific to Ada.
-- An associative array mapping individual specs to source file names.
-- This is specific to Ada.
Bodies : Array_Element_Id := No_Array_Element;
-- An associative array mapping individual bodies
-- to source file names. Specific to Ada.
-- An associative array mapping individual bodies to source file names.
-- This is specific to Ada.
Specification_Exceptions : Array_Element_Id := No_Array_Element;
-- An associative array listing spec file names that don't have the
-- spec suffix. Not used by Ada. Indexed by the programming language
-- name.
-- An associative array listing spec file names that do not have the
-- spec suffix. Not used by Ada. Indexed by programming language name.
Implementation_Exceptions : Array_Element_Id := No_Array_Element;
-- An associative array listing body file names that don't have the
-- body suffix. Not used by Ada. Indexed by the programming language
-- name.
-- An associative array listing body file names that do not have the
-- body suffix. Not used by Ada. Indexed by programming language name.
end record;
function Standard_Naming_Data return Naming_Data;
pragma Inline (Standard_Naming_Data);
-- The standard GNAT naming scheme.
-- The standard GNAT naming scheme
function Same_Naming_Scheme
(Left, Right : Naming_Data)
@ -426,14 +445,14 @@ package Prj is
type Project_List is new Nat;
Empty_Project_List : constant Project_List := 0;
-- A list of project files.
-- A list of project files
type Project_Element is record
Project : Project_Id := No_Project;
Next : Project_List := Empty_Project_List;
end record;
-- Element in a list of project file.
-- Next is the id of the next project file in the list.
-- Element in a list of project files. Next is the id of the next
-- project file in the list.
package Project_Lists is new Table.Table
(Table_Component_Type => Project_Element,
@ -442,7 +461,7 @@ package Prj is
Table_Initial => 100,
Table_Increment => 100,
Table_Name => "Prj.Project_Lists");
-- The table that contains the lists of project files.
-- The table that contains the lists of project files
-- The following record describes a project file representation
@ -459,30 +478,27 @@ package Prj is
-- Set by Prj.Proc.Process.
Name : Name_Id := No_Name;
-- The name of the project.
-- Set by Prj.Proc.Process.
-- The name of the project. Set by Prj.Proc.Process.
Path_Name : Name_Id := No_Name;
-- The path name of the project file.
-- Set by Prj.Proc.Process.
-- The path name of the project file. Set by Prj.Proc.Process.
Display_Path_Name : Name_Id := No_Name;
-- The path name used for display purposes. May be different from
-- Path_Name for platforms where the file names are case-insensitive.
Virtual : Boolean := False;
-- True for virtual extending projects
Display_Path_Name : Name_Id := No_Name;
Location : Source_Ptr := No_Location;
-- The location in the project file source of the
-- reserved word project.
-- Set by Prj.Proc.Process.
-- The location in the project file source of the reserved word
-- project. Set by Prj.Proc.Process.
Mains : String_List_Id := Nil_String;
-- The list of mains as specified by attribute Main.
-- Set by Prj.Nmsc.Ada_Check.
-- List of mains specified by attribute Main. Set by Prj.Nmsc.Ada_Check.
Directory : Name_Id := No_Name;
-- The directory where the project file resides.
-- Set by Prj.Proc.Process.
-- Directory where the project file resides. Set by Prj.Proc.Process.
Display_Directory : Name_Id := No_Name;
@ -499,6 +515,9 @@ package Prj is
-- Set by Prj.Nmsc.Language_Independent_Check.
Display_Library_Dir : Name_Id := No_Name;
-- The name of the library directory, for display purposes.
-- May be different from Library_Dir for platforms where the file names
-- are case-insensitive.
Library_Src_Dir : Name_Id := No_Name;
-- If a library project, directory where the sources and the ALI files
@ -508,6 +527,9 @@ package Prj is
-- Set by Prj.Nmsc.Language_Independent_Check.
Display_Library_Src_Dir : Name_Id := No_Name;
-- The name of the library source directory, for display purposes.
-- May be different from Library_Src_Dir for platforms where the file
-- names are case-insensitive.
Library_Name : Name_Id := No_Name;
-- If a library project, name of the library
@ -527,10 +549,9 @@ package Prj is
Lib_Interface_ALIs : String_List_Id := Nil_String;
-- For Standalone Library Project Files, indicate the list
-- of Interface ALI files.
-- Set by Prj.Nmsc.Ada_Check.
-- of Interface ALI files. Set by Prj.Nmsc.Ada_Check.
Lib_Auto_Init : Boolean := False;
Lib_Auto_Init : Boolean := False;
-- For non static Standalone Library Project Files, indicate if
-- the library initialisation should be automatic.
@ -539,16 +560,17 @@ package Prj is
Ada_Sources_Present : Boolean := True;
-- A flag that indicates if there are Ada sources in this project file.
-- There are no sources if 1) Source_Dirs is specified as an
-- empty list, 2) Source_Files is specified as an empty list, or
-- 3) Ada is not in the list of the specified Languages.
-- There are no sources if any of the following is true:
-- 1) Source_Dirs is specified as an empty list
-- 2) Source_Files is specified as an empty list
-- 3) Ada is not in the list of the specified Languages
Other_Sources_Present : Boolean := True;
Other_Sources_Present : Boolean := True;
-- A flag that indicates that there are non-Ada sources in this project
Sources : String_List_Id := Nil_String;
-- The list of all the source file names.
-- Set by Prj.Nmsc.Check_Ada_Naming_Scheme.
-- The list of all the source file names. Set by
-- Prj.Nmsc.Check_Ada_Naming_Scheme.
First_Other_Source : Other_Source_Id := No_Other_Source;
Last_Other_Source : Other_Source_Id := No_Other_Source;
@ -563,8 +585,7 @@ package Prj is
-- -I switches.
Include_Data_Set : Boolean := False;
-- Set to True when Imported_Directories_Switches or Include_Path are
-- set.
-- Set True when Imported_Directories_Switches or Include_Path are set
Source_Dirs : String_List_Id := Nil_String;
-- The list of all the source directories.
@ -580,48 +601,48 @@ package Prj is
-- Set by Prj.Nmsc.Language_Independent_Check.
Display_Object_Dir : Name_Id := No_Name;
-- The name of the object directory, for display purposes.
-- May be different from Object_Directory for platforms where the file
-- names are case-insensitive.
Exec_Directory : Name_Id := No_Name;
-- The exec directory of this project file.
-- Default is equal to Object_Directory.
-- Set by Prj.Nmsc.Language_Independent_Check.
Exec_Directory : Name_Id := No_Name;
-- The exec directory of this project file. Default is equal to
-- Object_Directory. Set by Prj.Nmsc.Language_Independent_Check.
Display_Exec_Dir : Name_Id := No_Name;
-- The name of the exec directory, for display purposes.
-- May be different from Exec_Directory for platforms where the file
-- names are case-insensitive.
Extends : Project_Id := No_Project;
-- The reference of the project file, if any, that this
-- project file extends.
-- Set by Prj.Proc.Process.
-- project file extends. Set by Prj.Proc.Process.
Extended_By : Project_Id := No_Project;
-- The reference of the project file, if any, that
-- extends this project file.
-- Set by Prj.Proc.Process.
-- extends this project file. Set by Prj.Proc.Process.
Naming : Naming_Data := Standard_Naming_Data;
-- The naming scheme of this project file.
-- Set by Prj.Nmsc.Check_Naming_Scheme.
Decl : Declarations := No_Declarations;
-- The declarations (variables, attributes and packages)
-- of this project file.
-- Set by Prj.Proc.Process.
-- The declarations (variables, attributes and packages) of this
-- project file. Set by Prj.Proc.Process.
Imported_Projects : Project_List := Empty_Project_List;
-- The list of all directly imported projects, if any.
-- Set by Prj.Proc.Process.
Ada_Include_Path : String_Access := null;
Ada_Include_Path : String_Access := null;
-- The cached value of ADA_INCLUDE_PATH for this project file.
-- Do not use this field directly outside of the compiler, use
-- Prj.Env.Ada_Include_Path instead.
-- Set by Prj.Env.Ada_Include_Path.
-- Prj.Env.Ada_Include_Path instead. Set by Prj.Env.Ada_Include_Path.
Ada_Objects_Path : String_Access := null;
Ada_Objects_Path : String_Access := null;
-- The cached value of ADA_OBJECTS_PATH for this project file.
-- Do not use this field directly outside of the compiler, use
-- Prj.Env.Ada_Objects_Path instead.
-- Set by Prj.Env.Ada_Objects_Path
-- Prj.Env.Ada_Objects_Path instead. Set by Prj.Env.Ada_Objects_Path
Include_Path_File : Name_Id := No_Name;
-- The cached value of the source path temp file for this project file.
@ -629,13 +650,11 @@ package Prj is
Objects_Path_File_With_Libs : Name_Id := No_Name;
-- The cached value of the object path temp file (including library
-- dirs) for this project file.
-- Set by gnatmake (Prj.Env.Set_Ada_Paths).
-- dirs) for this project file. Set by gnatmake (Prj.Env.Set_Ada_Paths).
Objects_Path_File_Without_Libs : Name_Id := No_Name;
-- The cached value of the object path temp file (excluding library
-- dirs) for this project file.
-- Set by gnatmake (Prj.Env.Set_Ada_Paths).
-- dirs) for this project file. Set by gnatmake (Prj.Env.Set_Ada_Paths).
Config_File_Name : Name_Id := No_Name;
-- The name of the configuration pragmas file, if any.
@ -657,17 +676,15 @@ package Prj is
Checked : Boolean := False;
-- A flag to avoid checking repetitively the naming scheme of
-- this project file.
-- Set by Prj.Nmsc.Check_Ada_Naming_Scheme.
-- this project file. Set by Prj.Nmsc.Check_Ada_Naming_Scheme.
Seen : Boolean := False;
Flag1 : Boolean := False;
Flag2 : Boolean := False;
-- Various flags that are used in an ad hoc manner
-- That's really not a good enough comment ??? we need to know what
-- these flags are used for, and give them proper names. If Flag1
-- and Flag2 have multiple uses, then either we use multiple fields
-- or a renaming scheme.
Seen : Boolean := False;
-- A flag to mark a project as "visited" to avoid processing the same
-- project several time.
Need_To_Build_Lib : Boolean := False;
-- Indicates that the library of a Library Project needs to be built or
-- rebuilt.
Depth : Natural := 0;
-- The maximum depth of a project in the project graph.
@ -680,7 +697,7 @@ package Prj is
end record;
function Empty_Project return Project_Data;
-- Return the representation of an empty project.
-- Return the representation of an empty project
package Projects is new Table.Table (
Table_Component_Type => Project_Data,
@ -689,12 +706,12 @@ package Prj is
Table_Initial => 100,
Table_Increment => 100,
Table_Name => "Prj.Projects");
-- The set of all project files.
-- The set of all project files
type Put_Line_Access is access procedure
(Line : String;
Project : Project_Id);
-- Use to customize error reporting in Prj.Proc and Prj.Nmsc.
-- Use to customize error reporting in Prj.Proc and Prj.Nmsc
procedure Expect (The_Token : Token_Type; Token_Image : String);
-- Check that the current token is The_Token. If it is not, then
@ -709,7 +726,7 @@ package Prj is
-- project file tree. Initialize must be called before the call to Reset.
procedure Register_Default_Naming_Scheme
(Language : Name_Id;
(Language : Name_Id;
Default_Spec_Suffix : Name_Id;
Default_Body_Suffix : Name_Id);
-- Register the default suffixs for a given language. These extensions
@ -736,6 +753,7 @@ package Prj is
private
Initial_Buffer_Size : constant := 100;
-- Initial size for extensible buffer used below
Buffer : String_Access := new String (1 .. Initial_Buffer_Size);
-- An extensible character buffer to store names. Used in Prj.Part and

53
gcc/ada/rtsfind.adb
View file

@ -70,6 +70,11 @@ package body Rtsfind is
-- a unit is loaded to contain the defining entity for the unit, the
-- unit name, and the unit number.
-- Note that a unit can be loaded either by a call to find an entity
-- within the unit (e.g. RTE), or by an explicit with of the unit. In
-- the latter case it is critical to make a call to Set_RTU_Loaded to
-- ensure that the entry in this table reflects the load.
type RT_Unit_Table_Record is record
Entity : Entity_Id;
Uname : Unit_Name_Type;
@ -139,7 +144,7 @@ package body Rtsfind is
function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type;
-- Retrieves the Unit Name given a unit id represented by its
-- enumaration value in RTU_Id.
-- enumeration value in RTU_Id.
procedure Load_RTU
(U_Id : RTU_Id;
@ -958,7 +963,7 @@ package body Rtsfind is
-- a WITH if the current unit is part of the extended main code
-- unit, and if we have not already added the with. The WITH is
-- added to the appropriate unit (the current one). We do not need
-- to generate a WITH for an
-- to generate a WITH for an ????
<<Found>>
if (not U.Withed)
@ -1052,11 +1057,49 @@ package body Rtsfind is
function RTU_Loaded (U : RTU_Id) return Boolean is
begin
return True or else Present (RT_Unit_Table (U).Entity);
-- Temporary kludge until we get proper interaction to ensure that
-- an explicit WITH of a unit is properly registered in rtsfind ???
return Present (RT_Unit_Table (U).Entity);
end RTU_Loaded;
--------------------
-- Set_RTU_Loaded --
--------------------
procedure Set_RTU_Loaded (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
Uname : constant Unit_Name_Type := Unit_Name (Unum);
E : constant Entity_Id :=
Defining_Entity (Unit (Cunit (Unum)));
begin
pragma Assert (Is_Predefined_File_Name (Unit_File_Name (Unum)));
-- Loop through entries in RTU table looking for matching entry
for U_Id in RTU_Id'Range loop
-- Here we have a match
if Get_Unit_Name (U_Id) = Uname then
declare
U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
-- The RT_Unit_Table entry that may need updating
begin
-- If entry is not set, set it now
if not Present (U.Entity) then
U.Entity := E;
U.Uname := Get_Unit_Name (U_Id);
U.Unum := Unum;
U.Withed := False;
end if;
return;
end;
end if;
end loop;
end Set_RTU_Loaded;
--------------------
-- Text_IO_Kludge --
--------------------

5
gcc/ada/rtsfind.ads
View file

@ -2695,7 +2695,7 @@ package Rtsfind is
--
-- If RTE returns, the returned value is the required entity
--
-- If the entity is not available, then an error message is given The
-- If the entity is not available, then an error message is given. The
-- form of the message depends on whether we are in configurable run time
-- mode or not. In configurable run time mode, a missing entity is not
-- that surprising and merely says that the particular construct is not
@ -2732,6 +2732,9 @@ package Rtsfind is
-- If the unit has not been loaded, returns False. Note that this does
-- not mean that an attempt to load it subsequently would fail.
procedure Set_RTU_Loaded (N : Node_Id);
-- Register the predefined unit N as already loaded.
procedure Text_IO_Kludge (Nam : Node_Id);
-- In Ada 83, and hence for compatibility in Ada 9X, package Text_IO has
-- generic subpackages (e.g. Integer_IO). They really should be child

11
gcc/ada/sem_ch10.adb
View file

@ -43,6 +43,7 @@ with Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
@ -496,6 +497,16 @@ package body Sem_Ch10 is
Set_Acts_As_Spec (N);
end if;
-- Register predefined units in Rtsfind
declare
Unum : constant Unit_Number_Type := Get_Source_Unit (Sloc (N));
begin
if Is_Predefined_File_Name (Unit_File_Name (Unum)) then
Set_RTU_Loaded (Unit_Node);
end if;
end;
-- Treat compilation unit pragmas that appear after the library unit
if Present (Pragmas_After (Aux_Decls_Node (N))) then

6
gcc/ada/sem_ch12.adb
View file

@ -6568,9 +6568,11 @@ package body Sem_Ch12 is
Next_Non_Pragma (Formal_Node);
else
-- No further formals to match.
-- No further formals to match, but the generic
-- part may contain inherited operation that are
-- not hidden in the enclosing instance.
exit;
Next_Entity (Actual_Ent);
end if;
end loop;

24
gcc/ada/sem_util.adb
View file

@ -1676,10 +1676,8 @@ package body Sem_Util is
-- hides the implicit one, which is removed from all visibility,
-- i.e. the entity list of its scope, and homonym chain of its name.
elsif (Is_Overloadable (E) and then Present (Alias (E)))
elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
or else Is_Internal (E)
or else (Ekind (E) = E_Enumeration_Literal
and then Is_Derived_Type (Etype (E)))
then
declare
Prev : Entity_Id;
@ -5363,7 +5361,25 @@ package body Sem_Util is
if Is_Private_Type (Btype)
and then not Is_Generic_Type (Btype)
then
return Btype;
if Present (Full_View (Btype))
and then Is_Record_Type (Full_View (Btype))
and then not Is_Frozen (Btype)
then
-- To indicate that the ancestor depends on a private type,
-- the current Btype is sufficient. However, to check for
-- circular definition we must recurse on the full view.
Candidate := Trace_Components (Full_View (Btype), True);
if Candidate = Any_Type then
return Any_Type;
else
return Btype;
end if;
else
return Btype;
end if;
elsif Is_Array_Type (Btype) then
return Trace_Components (Component_Type (Btype), True);