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

[multiple changes] 

2004-02-23  Ed Schonberg  <schonberg@gnat.com>

	* exp_ch6.adb (Expand_N_Subprogram_Declaration): Do not create
	protected operations if original subprogram is flagged as eliminated.
	(Expand_N_Subprogram_Body): For a protected operation, create
	discriminals for next operation before checking whether the operation
	is eliminated.

	* exp_ch9.adb (Expand_N_Protected_Body,
	Expand_N_Protected_Type_Declaration): Do not generate specs and bodies
	for internal protected operations if the original subprogram is
	eliminated.

	* sem_elim.adb (Check_Eliminated): Handle properly protected operations
	declared in a single protected object.

2004-02-23  Vincent Celier  <celier@gnat.com>

	* prj-attr.adb: Make attribute Builder'Executable an associative array,
	case insensitive if file names are case insensitive, instead of a
	standard associative array.

	* prj-attr.adb (Initialize): For 'b' associative arrays, do not set
	them as case insensitive on platforms where the file names are case
	sensitive.

	* prj-part.adb (Parse_Single_Project): Make sure, when checking if
	project file has already been parsed that canonical path are compared.

2004-02-23  Robert Dewar  <dewar@gnat.com>

	* sinput-c.ads: Correct bad unit title in header

	* freeze.adb: Minor reformatting

2004-02-23  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	* trans.c (tree_transform, case N_Procedure_Call_Statement): For
	nonaddressable COMPONENT_REF that is removing padding that we are
	taking the address of, take the address of the padded record instead
	if item is variable size.

From-SVN: r78292
This commit is contained in:
Arnaud Charlet 2004-02-23 12:17:13 +01:00
parent 615a5ba6b1
commit 6871ba5ffc
9 changed files with 207 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
gcc/ada/ChangeLog
View File

@ -1,3 +1,45 @@
2004-02-23 Ed Schonberg <schonberg@gnat.com>
* exp_ch6.adb (Expand_N_Subprogram_Declaration): Do not create
protected operations if original subprogram is flagged as eliminated.
(Expand_N_Subprogram_Body): For a protected operation, create
discriminals for next operation before checking whether the operation
is eliminated.
* exp_ch9.adb (Expand_N_Protected_Body,
Expand_N_Protected_Type_Declaration): Do not generate specs and bodies
for internal protected operations if the original subprogram is
eliminated.
* sem_elim.adb (Check_Eliminated): Handle properly protected operations
declared in a single protected object.
2004-02-23 Vincent Celier <celier@gnat.com>
* prj-attr.adb: Make attribute Builder'Executable an associative array,
case insensitive if file names are case insensitive, instead of a
standard associative array.
* prj-attr.adb (Initialize): For 'b' associative arrays, do not set
them as case insensitive on platforms where the file names are case
sensitive.
* prj-part.adb (Parse_Single_Project): Make sure, when checking if
project file has already been parsed that canonical path are compared.
2004-02-23 Robert Dewar <dewar@gnat.com>
* sinput-c.ads: Correct bad unit title in header
* freeze.adb: Minor reformatting
2004-02-23 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c (tree_transform, case N_Procedure_Call_Statement): For
nonaddressable COMPONENT_REF that is removing padding that we are
taking the address of, take the address of the padded record instead
if item is variable size.
2004-02-20 Robert Dewar <dewar@gnat.com>
* bld.adb, exp_util.adb, gprcmd.adb: Minor reformatting

63
gcc/ada/exp_ch6.adb
View File

@ -3191,6 +3191,34 @@ package body Exp_Ch6 is
end;
end if;
Scop := Scope (Spec_Id);
-- Add discriminal renamings to protected subprograms.
-- Install new discriminals for expansion of the next
-- subprogram of this protected type, if any.
if Is_List_Member (N)
and then Present (Parent (List_Containing (N)))
and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
then
Add_Discriminal_Declarations
(Declarations (N), Scop, Name_uObject, Loc);
Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc);
-- Associate privals and discriminals with the next protected
-- operation body to be expanded. These are used to expand
-- references to private data objects and discriminants,
-- respectively.
Next_Op := Next_Protected_Operation (N);
if Present (Next_Op) then
Dec := Parent (Base_Type (Scop));
Set_Privals (Dec, Next_Op, Loc);
Set_Discriminals (Dec);
end if;
end if;
-- Clear out statement list for stubbed procedure
if Present (Corresponding_Spec (N)) then
@ -3208,8 +3236,6 @@ package body Exp_Ch6 is
end if;
end if;
Scop := Scope (Spec_Id);
-- Returns_By_Ref flag is normally set when the subprogram is frozen
-- but subprograms with no specs are not frozen
@ -3298,32 +3324,6 @@ package body Exp_Ch6 is
end;
end if;
-- Add discriminal renamings to protected subprograms.
-- Install new discriminals for expansion of the next
-- subprogram of this protected type, if any.
if Is_List_Member (N)
and then Present (Parent (List_Containing (N)))
and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
then
Add_Discriminal_Declarations
(Declarations (N), Scop, Name_uObject, Loc);
Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc);
-- Associate privals and discriminals with the next protected
-- operation body to be expanded. These are used to expand
-- references to private data objects and discriminants,
-- respectively.
Next_Op := Next_Protected_Operation (N);
if Present (Next_Op) then
Dec := Parent (Base_Type (Scop));
Set_Privals (Dec, Next_Op, Loc);
Set_Discriminals (Dec);
end if;
end if;
-- If subprogram contains a parameterless recursive call, then we may
-- have an infinite recursion, so see if we can generate code to check
-- for this possibility if storage checks are not suppressed.
@ -3420,14 +3420,17 @@ package body Exp_Ch6 is
Prot_Id : Entity_Id;
begin
-- Deal with case of protected subprogram
-- Deal with case of protected subprogram. Do not generate
-- protected operation if operation is flagged as eliminated.
if Is_List_Member (N)
and then Present (Parent (List_Containing (N)))
and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
and then Is_Protected_Type (Scop)
then
if No (Protected_Body_Subprogram (Subp)) then
if No (Protected_Body_Subprogram (Subp))
and then not Is_Eliminated (Subp)
then
Prot_Decl :=
Make_Subprogram_Declaration (Loc,
Specification =>

11
gcc/ada/exp_ch9.adb
View File

@ -4885,7 +4885,9 @@ package body Exp_Ch9 is
-- Exclude functions created to analyze defaults.
if not Is_Eliminated (Defining_Entity (Op_Body)) then
if not Is_Eliminated (Defining_Entity (Op_Body))
and then not Is_Eliminated (Corresponding_Spec (Op_Body))
then
New_Op_Body :=
Build_Unprotected_Subprogram_Body (Op_Body, Pid);
@ -5372,14 +5374,17 @@ package body Exp_Ch9 is
-- subprogram; one to call from outside the object and one to
-- call from inside. Build a barrier function and an entry
-- body action procedure specification for each protected entry.
-- Initialize the entry body array.
-- Initialize the entry body array. If subprogram is flagged as
-- eliminated, do not generate any internal operations.
E_Count := 0;
Comp := First (Visible_Declarations (Pdef));
while Present (Comp) loop
if Nkind (Comp) = N_Subprogram_Declaration then
if Nkind (Comp) = N_Subprogram_Declaration
and then not Is_Eliminated (Defining_Entity (Comp))
then
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>

14
gcc/ada/freeze.adb
View File

@ -1479,6 +1479,10 @@ package body Freeze is
-- might otherwise be frozen in the wrong scope, and a freeze node
-- on subtype has no effect.
-----------------
-- Check_Itype --
-----------------
procedure Check_Itype (Desig : Entity_Id) is
begin
if not Is_Frozen (Desig)
@ -1522,11 +1526,10 @@ package body Freeze is
then
Set_First_Entity (Rec, First_Entity (Base_Type (Rec)));
-- If this is an internal type without a declaration, as for
-- a record component, the base type may not yet be frozen,
-- and its controller has not been created. Add an explicit
-- freeze node for the itype, so it will be frozen after the
-- base type.
-- If this is an internal type without a declaration, as for a
-- record component, the base type may not yet be frozen, and its
-- controller has not been created. Add an explicit freeze node
-- for the itype, so it will be frozen after the base type.
elsif Is_Itype (Rec)
and then Has_Delayed_Freeze (Base_Type (Rec))
@ -1997,7 +2000,6 @@ package body Freeze is
-- Loop through formals
Formal := First_Formal (E);
while Present (Formal) loop
F_Type := Etype (Formal);
Freeze_And_Append (F_Type, Loc, Result);

6
gcc/ada/prj-attr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2001-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- --
@ -105,7 +105,7 @@ package body Prj.Attr is
"Pbuilder#" &
"Ladefault_switches#" &
"Lbswitches#" &
"SAexecutable#" &
"Sbexecutable#" &
"SVexecutable_suffix#" &
"SVglobal_configuration_pragmas#" &
@ -258,7 +258,7 @@ package body Prj.Attr is
when 'b' =>
if File_Names_Case_Sensitive then
Kind_2 := Case_Insensitive_Associative_Array;
Kind_2 := Associative_Array;
else
Kind_2 := Case_Insensitive_Associative_Array;
end if;

131
gcc/ada/prj-part.adb
View File

@ -97,13 +97,14 @@ package body Prj.Part is
-- projects. These imported projects will be effectively parsed after the
-- name of the current project has been extablished.
type Name_And_Id is record
Name : Name_Id;
type Names_And_Id is record
Path_Name : Name_Id;
Canonical_Path_Name : Name_Id;
Id : Project_Node_Id;
end record;
package Project_Stack is new Table.Table
(Table_Component_Type => Name_And_Id,
(Table_Component_Type => Names_And_Id,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 10,
@ -717,7 +718,7 @@ package body Prj.Part is
if Project_Stack.Last > 1 then
for Index in reverse 1 .. Project_Stack.Last loop
Error_Msg_Name_1 := Project_Stack.Table (Index).Name;
Error_Msg_Name_1 := Project_Stack.Table (Index).Path_Name;
Error_Msg ("\imported by {", Current_With.Location);
end loop;
end if;
@ -761,7 +762,7 @@ package body Prj.Part is
Canonical_Path_Name := Name_Find;
for Index in 1 .. Project_Stack.Last loop
if Project_Stack.Table (Index).Name =
if Project_Stack.Table (Index).Canonical_Path_Name =
Canonical_Path_Name
then
-- We have found the limited imported project,
@ -875,13 +876,15 @@ package body Prj.Part is
-- Check for a circular dependency
for Index in 1 .. Project_Stack.Last loop
if Canonical_Path_Name = Project_Stack.Table (Index).Name then
if Canonical_Path_Name =
Project_Stack.Table (Index).Canonical_Path_Name
then
Error_Msg ("circular dependency detected", Token_Ptr);
Error_Msg_Name_1 := Normed_Path_Name;
Error_Msg ("\ { is imported by", Token_Ptr);
for Current in reverse 1 .. Project_Stack.Last loop
Error_Msg_Name_1 := Project_Stack.Table (Current).Name;
Error_Msg_Name_1 := Project_Stack.Table (Current).Path_Name;
if Error_Msg_Name_1 /= Canonical_Path_Name then
Error_Msg
@ -901,63 +904,74 @@ package body Prj.Part is
-- Put the new path name on the stack
Project_Stack.Increment_Last;
Project_Stack.Table (Project_Stack.Last).Name := Canonical_Path_Name;
Project_Stack.Table (Project_Stack.Last).Path_Name := Normed_Path_Name;
Project_Stack.Table (Project_Stack.Last).Canonical_Path_Name :=
Canonical_Path_Name;
-- Check if the project file has already been parsed.
while
A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node
loop
if
Path_Name_Of (A_Project_Name_And_Node.Node) = Canonical_Path_Name
then
if Extended then
if A_Project_Name_And_Node.Extended then
Error_Msg
("cannot extend the same project file several times",
Token_Ptr);
else
Error_Msg
("cannot extend an already imported project file",
Token_Ptr);
end if;
elsif A_Project_Name_And_Node.Extended then
Extends_All := Is_Extending_All (A_Project_Name_And_Node.Node);
-- If the imported project is an extended project A, and we are
-- in an extended project, replace A with the ultimate project
-- extending A.
if From_Extended /= None then
declare
Decl : Project_Node_Id :=
Project_Declaration_Of
(A_Project_Name_And_Node.Node);
Prj : Project_Node_Id :=
Extending_Project_Of (Decl);
begin
loop
Decl := Project_Declaration_Of (Prj);
exit when Extending_Project_Of (Decl) = Empty_Node;
Prj := Extending_Project_Of (Decl);
end loop;
A_Project_Name_And_Node.Node := Prj;
end;
else
Error_Msg
("cannot import an already extended project file",
Token_Ptr);
end if;
declare
Path_Id : Name_Id := Path_Name_Of (A_Project_Name_And_Node.Node);
begin
if Path_Id /= No_Name then
Get_Name_String (Path_Id);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Path_Id := Name_Find;
end if;
Project := A_Project_Name_And_Node.Node;
Project_Stack.Decrement_Last;
return;
end if;
if Path_Id = Canonical_Path_Name then
if Extended then
if A_Project_Name_And_Node.Extended then
Error_Msg
("cannot extend the same project file several times",
Token_Ptr);
else
Error_Msg
("cannot extend an already imported project file",
Token_Ptr);
end if;
elsif A_Project_Name_And_Node.Extended then
Extends_All :=
Is_Extending_All (A_Project_Name_And_Node.Node);
-- If the imported project is an extended project A,
-- and we are in an extended project, replace A with the
-- ultimate project extending A.
if From_Extended /= None then
declare
Decl : Project_Node_Id :=
Project_Declaration_Of
(A_Project_Name_And_Node.Node);
Prj : Project_Node_Id :=
Extending_Project_Of (Decl);
begin
loop
Decl := Project_Declaration_Of (Prj);
exit when Extending_Project_Of (Decl) = Empty_Node;
Prj := Extending_Project_Of (Decl);
end loop;
A_Project_Name_And_Node.Node := Prj;
end;
else
Error_Msg
("cannot import an already extended project file",
Token_Ptr);
end if;
end if;
Project := A_Project_Name_And_Node.Node;
Project_Stack.Decrement_Last;
return;
end if;
end;
A_Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_Next;
end loop;
@ -1202,11 +1216,12 @@ package body Prj.Part is
if Project_Stack.Last > 1 then
Error_Msg_Name_1 :=
Project_Stack.Table (Project_Stack.Last).Name;
Project_Stack.Table (Project_Stack.Last).Path_Name;
Error_Msg ("\extended by {", Token_Ptr);
for Index in reverse 1 .. Project_Stack.Last - 1 loop
Error_Msg_Name_1 := Project_Stack.Table (Index).Name;
Error_Msg_Name_1 :=
Project_Stack.Table (Index).Path_Name;
Error_Msg ("\imported by {", Token_Ptr);
end loop;
end if;

27
gcc/ada/sem_elim.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1997-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- --
@ -232,6 +232,29 @@ package body Sem_Elim is
Ctr : Nat;
Ent : Entity_Id;
function Original_Chars (S : Entity_Id) return Name_Id;
-- If the candidate subprogram is a protected operation of a single
-- protected object, the scope of the operation is the created
-- protected type, and we have to retrieve the original name of
-- the object.
--------------------
-- Original_Chars --
--------------------
function Original_Chars (S : Entity_Id) return Name_Id is
begin
if Ekind (S) /= E_Protected_Type
or else Comes_From_Source (S)
then
return Chars (S);
else
return Chars (Defining_Identifier (Original_Node (Parent (S))));
end if;
end Original_Chars;
-- Start of processing for Check_Eliminated
begin
if No_Elimination then
return;
@ -270,7 +293,7 @@ package body Sem_Elim is
Scop := Scope (E);
if Elmt.Entity_Scope /= null then
for J in reverse Elmt.Entity_Scope'Range loop
if Elmt.Entity_Scope (J) /= Chars (Scop) then
if Elmt.Entity_Scope (J) /= Original_Chars (Scop) then
goto Continue;
end if;

4
gcc/ada/sinput-c.ads
View File

@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S I N P U T . P --
-- S I N P U T . C --
-- --
-- S p e c --
-- --
-- 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- --

13
gcc/ada/trans.c
View File

@ -2997,6 +2997,19 @@ tree_transform (Node_Id gnat_node)
gnu_actual);
}
/* Otherwise, if we have a non-addressable COMPONENT_REF of a
variable-size type see if it's doing a unpadding operation.
If so, remove that operation since we have no way of
allocating the required temporary. */
if (TREE_CODE (gnu_actual) == COMPONENT_REF
&& ! TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
&& (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual, 0)))
== RECORD_TYPE)
&& TYPE_IS_PADDING_P (TREE_TYPE
(TREE_OPERAND (gnu_actual, 0)))
&& !addressable_p (gnu_actual))
gnu_actual = TREE_OPERAND (gnu_actual, 0);
/* The symmetry of the paths to the type of an entity is
broken here since arguments don't know that they will
be passed by ref. */