OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR ada/5909 (Ada has no test suite.)

Browse Source 
* Makefile.generic: Add missing substitution on object_deps handling.

	PR ada/5909:
	* Make-lang.in (check-ada): Enable ACATS test suite.

	* exp_ch3.adb:
	(Freeze_Array_Type): We do not need an initialization routine for types
	derived from String or Wide_String. They should be treated the same
	as String and Wide_String themselves. This caused problems with the
	use of Initialize_Scalars.

	* exp_ch5.adb:
	(Expand_Assign_Record): Do component-wise assignment of non-byte aligned
	composites. This allows use of component clauses that are not byte
	aligned.

	* sem_prag.adb:
	(Analyze_Pragma, case Pack): Generate warning and ignore pack if there
	is an attempt to pack an array of atomic objects.

	* make.adb, prj-env.adb, prj-env.ads: Minor reformatting

	* g-dirope.adb:
	(Basename): Check for drive letters in a pathname only on DOS based OS.

	* make.adb:
	(Gnatmake): When unable to change dir to the object dir, display the
	content of the parent dir of the obj dir, to try to understand why this
	happens.

	* Make-lang.in: Makefile automatically updated

	* sem_ch12.adb:
	(Inline_Instance_Body): Indicate that the save/restore of use_clauses
	should not be done in Save/Restore_Scope_Stack, because it is performed
	locally.

	* sem_ch8.adb:
	(Save_Scope_Stack, Restore_Scope_Stack): Add parameter to indicate
	whether use clauses should be removed/restored.

	* sem_ch8.ads:
	(Save_Scope_Stack, Restore_Scope_Stack): Add parameter to indicate
	whether use clauses should be removed/restored.

From-SVN: r72983
This commit is contained in:
Arnaud Charlet 2003-10-27 15:27:17 +01:00
parent e1ffc70a2d
commit ecad994dd1
13 changed files with 2627 additions and 1514 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
gcc/ada/ChangeLog
View File

@ -1,3 +1,60 @@
2003-10-27 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.generic: Add missing substitution on object_deps handling.
PR ada/5909:
* Make-lang.in (check-ada): Enable ACATS test suite.
2003-10-27 Robert Dewar <dewar@gnat.com>
* exp_ch3.adb:
(Freeze_Array_Type): We do not need an initialization routine for types
derived from String or Wide_String. They should be treated the same
as String and Wide_String themselves. This caused problems with the
use of Initialize_Scalars.
* exp_ch5.adb:
(Expand_Assign_Record): Do component-wise assignment of non-byte aligned
composites. This allows use of component clauses that are not byte
aligned.
* sem_prag.adb:
(Analyze_Pragma, case Pack): Generate warning and ignore pack if there
is an attempt to pack an array of atomic objects.
* make.adb, prj-env.adb, prj-env.ads: Minor reformatting
2003-10-27 Pascal Obry <obry@gnat.com>
* g-dirope.adb:
(Basename): Check for drive letters in a pathname only on DOS based OS.
2003-10-27 Vincent Celier <celier@gnat.com>
* make.adb:
(Gnatmake): When unable to change dir to the object dir, display the
content of the parent dir of the obj dir, to try to understand why this
happens.
2003-10-27 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
2003-10-27 Ed Schonberg <schonberg@gnat.com>
* sem_ch12.adb:
(Inline_Instance_Body): Indicate that the save/restore of use_clauses
should not be done in Save/Restore_Scope_Stack, because it is performed
locally.
* sem_ch8.adb:
(Save_Scope_Stack, Restore_Scope_Stack): Add parameter to indicate
whether use clauses should be removed/restored.
* sem_ch8.ads:
(Save_Scope_Stack, Restore_Scope_Stack): Add parameter to indicate
whether use clauses should be removed/restored.
2003-10-26 Andreas Jaeger <aj@suse.de>
* Makefile.in: Remove duplicated lines.

3796
gcc/ada/Make-lang.in
View File

File diff suppressed because it is too large Load Diff

2
gcc/ada/Makefile.generic
View File

@ -157,7 +157,7 @@ $(compile_deps): force
@$(MAKE) -C $(dir $(subst |,:,$(@:compile_%=%))) -f Makefile.$(notdir $@) internal-compile
$(object_deps): force
@$(MAKE) -C $(dir $(@:object_%=%)) -f Makefile.$(notdir $@) internal-archive-objects ARCHIVE=$(ARCHIVE)
@$(MAKE) -C $(dir $(subst |,:,$(@:object_%=%))) -f Makefile.$(notdir $@) internal-archive-objects ARCHIVE=$(ARCHIVE)
$(ada_deps): force
@$(MAKE) -C $(dir $(subst |,:,$(@:ada_%=%))) -f Makefile.$(notdir $@) internal-ada

4
gcc/ada/exp_ch3.adb
View File

@ -3428,8 +3428,8 @@ package body Exp_Ch3 is
-- initialize scalars mode, and these types are treated specially
-- and do not need initialization procedures.
elsif Base = Standard_String
or else Base = Standard_Wide_String
elsif Root_Type (Base) = Standard_String
or else Root_Type (Base) = Standard_Wide_String
then
null;

146
gcc/ada/exp_ch5.adb
View File

@ -91,8 +91,25 @@ package body Exp_Ch5 is
procedure Expand_Assign_Record (N : Node_Id);
-- N is an assignment of a non-tagged record value. This routine handles
-- the special cases and checks required for such assignments, including
-- change of representation.
-- the case where the assignment must be made component by component,
-- either because the target is not byte aligned, or there is a change
-- of representation.
function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean;
-- This function is used in processing the assignment of a record or
-- indexed component. The back end can handle such assignments fine
-- if the object involved is small (64-bits) or if it is aligned on
-- a byte boundary (starts on a byte, and ends on a byte). However,
-- problems arise for large components that are not byte aligned,
-- since the assignment may clobber other components that share
-- bit positions in the starting or ending bytes. This function is
-- used to detect such situations, so that the assignment can be
-- handled component-wise. A value of False means that either the
-- object is known to be greater than 64 bits, or that it is known
-- to be byte aligned. True is returned if the object is known to
-- be greater than 64 bits, and is known to be unaligned. As implied
-- by the name, the result is conservative, in that if the compiler
-- cannot determine these conditions at compile time, True is returned.
function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
-- Generate the necessary code for controlled and Tagged assignment,
@ -982,19 +999,38 @@ package body Exp_Ch5 is
-- by field assignments.
procedure Expand_Assign_Record (N : Node_Id) is
Lhs : constant Node_Id := Name (N);
Rhs : Node_Id := Expression (N);
begin
if not Change_Of_Representation (N) then
-- If change of representation, then extract the real right hand
-- side from the type conversion, and proceed with component-wise
-- assignment, since the two types are not the same as far as the
-- back end is concerned.
if Change_Of_Representation (N) then
Rhs := Expression (Rhs);
-- If this may be a case of a large bit aligned component, then
-- proceed with component-wise assignment, to avoid possible
-- clobbering of other components sharing bits in the first or
-- last byte of the component to be assigned.
elsif Maybe_Bit_Aligned_Large_Component (Lhs) then
null;
-- If neither condition met, then nothing special to do, the back end
-- can handle assignment of the entire component as a single entity.
else
return;
end if;
-- At this stage we know that the right hand side is a conversion
-- At this stage we know that we must do a component wise assignment
declare
Loc : constant Source_Ptr := Sloc (N);
Lhs : constant Node_Id := Name (N);
Rhs : constant Node_Id := Expression (Expression (N));
R_Rec : constant Node_Id := Expression (Expression (N));
R_Typ : constant Entity_Id := Base_Type (Etype (R_Rec));
R_Typ : constant Entity_Id := Base_Type (Etype (Rhs));
L_Typ : constant Entity_Id := Base_Type (Etype (Lhs));
Decl : constant Node_Id := Declaration_Node (R_Typ);
RDef : Node_Id;
@ -1002,8 +1038,7 @@ package body Exp_Ch5 is
function Find_Component
(Typ : Entity_Id;
Comp : Entity_Id)
return Entity_Id;
Comp : Entity_Id) return Entity_Id;
-- Find the component with the given name in the underlying record
-- declaration for Typ. We need to use the actual entity because
-- the type may be private and resolution by identifier alone would
@ -1027,9 +1062,7 @@ package body Exp_Ch5 is
function Find_Component
(Typ : Entity_Id;
Comp : Entity_Id)
return Entity_Id
Comp : Entity_Id) return Entity_Id
is
Utyp : constant Entity_Id := Underlying_Type (Typ);
C : Entity_Id;
@ -3175,4 +3208,91 @@ package body Exp_Ch5 is
return Empty_List;
end Make_Tag_Ctrl_Assignment;
---------------------------------------
-- Maybe_Bit_Aligned_Large_Component --
---------------------------------------
function Maybe_Bit_Aligned_Large_Component (N : Node_Id) return Boolean is
begin
case Nkind (N) is
-- Case of indexed component
when N_Indexed_Component =>
declare
P : constant Node_Id := Prefix (N);
Ptyp : constant Entity_Id := Etype (P);
begin
-- If we know the component size and it is less than 64, then
-- we are definitely OK. The back end always does assignment
-- of misaligned small objects correctly.
if Known_Static_Component_Size (Ptyp)
and then Component_Size (Ptyp) <= 64
then
return False;
-- Otherwise, we need to test the prefix, to see if we are
-- indexing from a possibly unaligned component.
else
return Maybe_Bit_Aligned_Large_Component (P);
end if;
end;
-- Case of selected component
when N_Selected_Component =>
declare
P : constant Node_Id := Prefix (N);
Comp : constant Entity_Id := Entity (Selector_Name (N));
begin
-- If there is no component clause, then we are in the clear
-- since the back end will never misalign a large component
-- unless it is forced to do so. In the clear means we need
-- only the recursive test on the prefix.
if No (Component_Clause (Comp)) then
return Maybe_Bit_Aligned_Large_Component (P);
-- Otherwise we have a component clause, which means that
-- the Esize and Normalized_First_Bit fields are set and
-- contain static values known at compile time.
else
-- If we know the size is 64 bits or less we are fine
-- since the back end always handles small fields right.
if Esize (Comp) <= 64 then
return False;
-- Otherwise if the component is not byte aligned, we
-- know we have the nasty unaligned case.
elsif Normalized_First_Bit (Comp) /= Uint_0
or else Esize (Comp) mod System_Storage_Unit /= Uint_0
then
return True;
-- If we are large and byte aligned, then OK at this level
-- but we still need to test our prefix recursively.
else
return Maybe_Bit_Aligned_Large_Component (P);
end if;
end if;
end;
-- If we have neither a record nor array component, it means that
-- we have fallen off the top testing prefixes recursively, and
-- we now have a stand alone object, where we don't have a problem
when others =>
return False;
end case;
end Maybe_Bit_Aligned_Large_Component;
end Exp_Ch5;

8
gcc/ada/g-dirope.adb
View File

@ -123,11 +123,17 @@ package body GNAT.Directory_Operations is
Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset);
-- Here we use Base_Name.Path to keep the original casing
Has_Drive_Letter : constant Boolean :=
OS_Lib.Path_Separator /= ':';
-- If Path separator is not ':' then we are on a DOS based OS
-- where this character is used as a drive letter separator.
begin
if BN = "." or else BN = ".." then
return "";
elsif BN'Length > 2
elsif Has_Drive_Letter
and then BN'Length > 2
and then Characters.Handling.Is_Letter (BN (BN'First))
and then BN (BN'First + 1) = ':'
then

57
gcc/ada/make.adb
View File

@ -3386,7 +3386,7 @@ package body Make is
loop
declare
Main : constant String := Mains.Next_Main;
Main : constant String := Mains.Next_Main;
-- The name specified on the command line may include
-- directory information.
@ -3416,7 +3416,7 @@ package body Make is
if Main /= File_Name then
declare
Data : constant Project_Data :=
Projects.Table (Main_Project);
Projects.Table (Main_Project);
Project_Path : constant String :=
Prj.Env.File_Name_Of_Library_Unit_Body
@ -3478,12 +3478,14 @@ package body Make is
end if;
if not Unique_Compile then
-- Record the project, if it is the first main
if Real_Main_Project = No_Project then
Real_Main_Project := Proj;
elsif Proj /= Real_Main_Project then
-- Fail, as the current main is not a source
-- of the same project as the first main.
@ -3557,11 +3559,14 @@ package body Make is
declare
Data : Project_Data := Projects.Table (Main_Project);
Languages : Variable_Value :=
Prj.Util.Value_Of
(Name_Languages, Data.Decl.Attributes);
Prj.Util.Value_Of
(Name_Languages, Data.Decl.Attributes);
Current : String_List_Id;
Element : String_Element;
Foreign_Language : Boolean := False;
At_Least_One_Main : Boolean := False;
@ -3593,8 +3598,8 @@ package body Make is
while Value /= Prj.Nil_String loop
Get_Name_String (String_Elements.Table (Value).Value);
-- To know if a main is an Ada main, get its project;
-- it should be the project specified on the command
-- To know if a main is an Ada main, get its project.
-- It should be the project specified on the command
-- line.
if (not Foreign_Language) or else
@ -3616,6 +3621,7 @@ package body Make is
-- we put all sources of the main project in the Q.
if not At_Least_One_Main then
-- First make sure that the binder and the linker
-- will not be invoked.
@ -3739,6 +3745,45 @@ package body Make is
exception
when Directory_Error =>
-- This should never happen. But, if it does, display the
-- content of the parent directory of the obj dir.
declare
Parent : constant Dir_Name_Str :=
Dir_Name
(Get_Name_String
(Projects.Table (Main_Project).Object_Directory));
Dir : Dir_Type;
Str : String (1 .. 200);
Last : Natural;
begin
Write_Str ("Contents of directory """);
Write_Str (Parent);
Write_Line (""":");
Open (Dir, Parent);
loop
Read (Dir, Str, Last);
exit when Last = 0;
Write_Str (" ");
Write_Line (Str (1 .. Last));
end loop;
Close (Dir);
exception
when X : others =>
Write_Line ("(unexpected exception)");
Write_Line (Exception_Information (X));
if Is_Open (Dir) then
Close (Dir);
end if;
end;
Make_Failed ("unable to change working directory to """,
Get_Name_String
(Projects.Table (Main_Project).Object_Directory),

23
gcc/ada/prj-env.adb
View File

@ -203,10 +203,13 @@ package body Prj.Env is
return Projects.Table (Project).Ada_Include_Path;
end Ada_Include_Path;
----------------------
-- Ada_Include_Path --
----------------------
function Ada_Include_Path
(Project : Project_Id;
Recursive : Boolean)
return String
Recursive : Boolean) return String
is
begin
if Recursive then
@ -224,8 +227,7 @@ package body Prj.Env is
function Ada_Objects_Path
(Project : Project_Id;
Including_Libraries : Boolean := True)
return String_Access
Including_Libraries : Boolean := True) return String_Access
is
procedure Add (Project : Project_Id);
-- Add all the object directories of a project to the path only if
@ -1061,8 +1063,7 @@ package body Prj.Env is
(Name : String;
Project : Project_Id;
Main_Project_Only : Boolean := True;
Full_Path : Boolean := False)
return String
Full_Path : Boolean := False) return String
is
The_Project : Project_Id := Project;
Data : Project_Data := Projects.Table (Project);
@ -1547,8 +1548,7 @@ package body Prj.Env is
function Path_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id)
return String
Project : Project_Id) return String
is
Data : constant Project_Data := Projects.Table (Project);
Original_Name : String := Name;
@ -1733,8 +1733,7 @@ package body Prj.Env is
function Project_Of
(Name : String;
Main_Project : Project_Id)
return Project_Id
Main_Project : Project_Id) return Project_Id
is
Result : Project_Id := No_Project;
@ -1777,10 +1776,13 @@ package body Prj.Env is
Unit := Units.Table (Current);
-- Check for body
Current_Name := Unit.File_Names (Body_Part).Name;
-- Case of a body present
if Current_Name /= No_Name then
-- If it has the name of the original name or the body name,
-- we have found the project.
@ -1798,6 +1800,7 @@ package body Prj.Env is
Current_Name := Unit.File_Names (Specification).Name;
if Current_Name /= No_Name then
-- If name same as the original name, or the spec name, we have
-- found the project.

22
gcc/ada/prj-env.ads
View File

@ -66,8 +66,7 @@ package Prj.Env is
function Ada_Include_Path
(Project : Project_Id;
Recursive : Boolean)
return String;
Recursive : Boolean) return String;
-- Get the ADA_INCLUDE_PATH of a Project file. If Recursive it True,
-- get all the source directories of the imported and modified project
-- files (recursively). If Recursive is False, just get the path for the
@ -76,8 +75,7 @@ package Prj.Env is
function Ada_Objects_Path
(Project : Project_Id;
Including_Libraries : Boolean := True)
return String_Access;
Including_Libraries : Boolean := True) return String_Access;
-- Get the ADA_OBJECTS_PATH of a Project file. For the first call, compute
-- it and cache it. When Including_Libraries is False, do not include the
-- object directories of the library projects, and do not cache the result.
@ -86,7 +84,7 @@ package Prj.Env is
(Project : Project_Id;
Including_Libraries : Boolean);
-- Set the env vars for additional project path files, after
-- creating if necessary the path files.
-- creating the path files if necessary.
procedure Delete_All_Path_Files;
-- Delete all temporary path files that have been created by
@ -94,22 +92,23 @@ package Prj.Env is
function Path_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id)
return String;
-- Returns the Path of a library unit.
Project : Project_Id) return String;
-- Returns the Path of a library unit
function File_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id;
Main_Project_Only : Boolean := True;
Full_Path : Boolean := False)
return String;
Full_Path : Boolean := False) return String;
-- Returns the file name of a library unit, in canonical case. Name may or
-- may not have an extension (corresponding to the naming scheme of the
-- project). If there is no body with this name, but there is a spec, the
-- name of the spec is returned.
--
-- If Full_Path is False (the default), the simple file name is returned.
--
-- If Full_Path is True, the absolute path name is returned.
--
-- If neither a body nor a spec can be found, an empty string is returned.
-- If Main_Project_Only is True, the unit must be an immediate source of
-- Project. If it is False, it may be a source of one of its imported
@ -117,8 +116,7 @@ package Prj.Env is
function Project_Of
(Name : String;
Main_Project : Project_Id)
return Project_Id;
Main_Project : Project_Id) return Project_Id;
-- Get the project of a source. The source file name may be truncated
-- (".adb" or ".ads" may be missing). If the source is in a project being
-- extended, return the ultimate extending project. If it is not a source

4
gcc/ada/sem_ch12.adb
View File

@ -2887,7 +2887,7 @@ package body Sem_Ch12 is
-- Remove entities in current scopes from visibility, so
-- than instance body is compiled in a clean environment.
Save_Scope_Stack;
Save_Scope_Stack (Handle_Use => False);
if Is_Child_Unit (S) then
@ -2951,7 +2951,7 @@ package body Sem_Ch12 is
end loop;
end if;
Restore_Scope_Stack;
Restore_Scope_Stack (Handle_Use => False);
end if;
-- Restore use clauses. For a child unit, use clauses in the

10
gcc/ada/sem_ch8.adb
View File

@ -5072,7 +5072,7 @@ package body Sem_Ch8 is
-- Restore_Scope_Stack --
-------------------------
procedure Restore_Scope_Stack is
procedure Restore_Scope_Stack (Handle_Use : Boolean := True) is
E : Entity_Id;
S : Entity_Id;
Comp_Unit : Node_Id;
@ -5174,6 +5174,7 @@ package body Sem_Ch8 is
if SS_Last >= Scope_Stack.First
and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
and then Handle_Use
then
Install_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
end if;
@ -5183,7 +5184,7 @@ package body Sem_Ch8 is
-- Save_Scope_Stack --
----------------------
procedure Save_Scope_Stack is
procedure Save_Scope_Stack (Handle_Use : Boolean := True) is
E : Entity_Id;
S : Entity_Id;
SS_Last : constant Int := Scope_Stack.Last;
@ -5192,8 +5193,9 @@ package body Sem_Ch8 is
if SS_Last >= Scope_Stack.First
and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
then
End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
if Handle_Use then
End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
end if;
-- If the call is from within a compilation unit, as when
-- called from Rtsfind, make current entries in scope stack

8
gcc/ada/sem_ch8.ads
View File

@ -135,14 +135,18 @@ package Sem_Ch8 is
-- or else a with-clause on system. N is absent when the function is
-- called to find the visibility of implicit operators.
procedure Restore_Scope_Stack;
procedure Save_Scope_Stack;
procedure Restore_Scope_Stack (Handle_Use : Boolean := True);
procedure Save_Scope_Stack (Handle_Use : Boolean := True);
-- These two procedures are called from Semantics, when a unit U1 is
-- to be compiled in the course of the compilation of another unit U2.
-- This happens whenever Rtsfind is called. U1, the unit retrieved by
-- Rtsfind, must be compiled in its own context, and the current scope
-- stack containing U2 and local scopes must be made unreachable. On
-- return, the contents of the scope stack must be made accessible again.
-- The flag Handle_Use indicates whether local use clauses must be
-- removed/installed. In the case of inlining of instance bodies, the
-- visiblity handling is done fully in Inline_Instance_Body, and use
-- clauses are handled there.
procedure Set_Use (L : List_Id);
-- Find use clauses that are declarative items in a package declaration

4
gcc/ada/sem_prag.adb
View File

@ -7477,7 +7477,9 @@ package body Sem_Prag is
Error_Pragma
("pragma% ignored, cannot pack aliased components?");
elsif Has_Atomic_Components (Typ) then
elsif Has_Atomic_Components (Typ)
or else Is_Atomic (Component_Type (Typ))
then
Error_Pragma
("?pragma% ignored, cannot pack atomic components");