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

[multiple changes] 

2012-07-12  Robert Dewar  <dewar@adacore.com>

	* make.adb, sem_ch9.adb, prj.adb, s-rident.ads, snames.ads-tmpl: Minor
	reformatting.

2012-07-12  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Is_User_Defined_Equality): New subprogram.
	(Make_Neq_Body): New subprogram.
	(Make_Predefined_Primitive_Specs): Adding local variable
	Has_Predef_Eq_ Renaming to ensure that we enable the machinery
	which handles renamings of predefined primitive operators.

From-SVN: r189432
This commit is contained in:
Arnaud Charlet 2012-07-12 12:19:13 +02:00
parent 381ec0f4cd
commit cd20e505e7
7 changed files with 273 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/ada/ChangeLog
View File

@ -1,3 +1,16 @@
2012-07-12 Robert Dewar <dewar@adacore.com>
* make.adb, sem_ch9.adb, prj.adb, s-rident.ads, snames.ads-tmpl: Minor
reformatting.
2012-07-12 Javier Miranda <miranda@adacore.com>
* exp_ch3.adb (Is_User_Defined_Equality): New subprogram.
(Make_Neq_Body): New subprogram.
(Make_Predefined_Primitive_Specs): Adding local variable
Has_Predef_Eq_ Renaming to ensure that we enable the machinery
which handles renamings of predefined primitive operators.
2012-07-09 Pascal Obry <obry@adacore.com>
* prj.adb (For_Every_Project_Imported_Context): Make sure we

238
gcc/ada/exp_ch3.adb
View File

@ -202,6 +202,9 @@ package body Exp_Ch3 is
-- Check if E is defined in the RTL (in a child of Ada or System). Used
-- to avoid to bring in the overhead of _Input, _Output for tagged types.
function Is_User_Defined_Equality (Prim : Node_Id) return Boolean;
-- Returns true if Prim is a user defined equality function
function Is_Variable_Size_Array (E : Entity_Id) return Boolean;
-- Returns true if E has variable size components
@ -237,6 +240,11 @@ package body Exp_Ch3 is
-- formals at some upper level). E provides the Sloc to be used for the
-- generated code.
function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id;
-- Search for a renaming of the inequality dispatching primitive of
-- this tagged type. If found then build and return the corresponding
-- rename-as-body inequality subprogram; otherwise return Empty.
procedure Make_Predefined_Primitive_Specs
(Tag_Typ : Entity_Id;
Predef_List : out List_Id;
@ -7677,6 +7685,18 @@ package body Exp_Ch3 is
end loop;
end Init_Secondary_Tags;
------------------------
-- Is_User_Defined_Eq --
------------------------
function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is
begin
return Chars (Prim) = Name_Op_Eq
and then Etype (First_Formal (Prim)) =
Etype (Next_Formal (First_Formal (Prim)))
and then Base_Type (Etype (Prim)) = Standard_Boolean;
end Is_User_Defined_Equality;
----------------------------
-- Is_Variable_Size_Array --
----------------------------
@ -8140,6 +8160,175 @@ package body Exp_Ch3 is
end if;
end Make_Eq_If;
--------------------
-- Make_Neq_Body --
--------------------
function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is
function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean;
-- Returns true if Prim is a renaming of an unresolved predefined
-- inequality operation.
--------------------------------
-- Is_Predefined_Neq_Renaming --
--------------------------------
function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is
begin
return Chars (Prim) /= Name_Op_Ne
and then Present (Alias (Prim))
and then Comes_From_Source (Prim)
and then Is_Intrinsic_Subprogram (Alias (Prim))
and then Chars (Alias (Prim)) = Name_Op_Ne;
end Is_Predefined_Neq_Renaming;
-- Local variables
Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ));
Stmts : constant List_Id := New_List;
Decl : Node_Id;
Eq_Prim : Entity_Id;
Left_Op : Entity_Id;
Renaming_Prim : Entity_Id;
Right_Op : Entity_Id;
Target : Entity_Id;
-- Start of processing for Make_Neq_Body
begin
-- For a call on a renaming of a dispatching subprogram that is
-- overridden, if the overriding occurred before the renaming, then
-- the body executed is that of the overriding declaration, even if the
-- overriding declaration is not visible at the place of the renaming;
-- otherwise, the inherited or predefined subprogram is called, see
-- (RM 8.5.4(8))
-- Stage 1: Search for a renaming of the unequality primitive and also
-- search for an overriding of the equality primitive located before the
-- renaming declaration.
declare
Elmt : Elmt_Id;
Prim : Node_Id;
begin
Eq_Prim := Empty;
Renaming_Prim := Empty;
Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
while Present (Elmt) loop
Prim := Node (Elmt);
if Is_User_Defined_Equality (Prim)
and then No (Alias (Prim))
then
if No (Renaming_Prim) then
pragma Assert (No (Eq_Prim));
Eq_Prim := Prim;
end if;
elsif Is_Predefined_Neq_Renaming (Prim) then
Renaming_Prim := Prim;
end if;
Next_Elmt (Elmt);
end loop;
end;
-- No further action needed if no renaming was found
if No (Renaming_Prim) then
return Empty;
end if;
-- Stage 2: Replace the renaming declaration by a subprogram declaration
-- (required to add its body)
Decl := Parent (Parent (Renaming_Prim));
Rewrite (Decl,
Make_Subprogram_Declaration (Loc,
Specification => Specification (Decl)));
Set_Analyzed (Decl);
-- Remove the decoration of intrinsic renaming subprogram
Set_Is_Intrinsic_Subprogram (Renaming_Prim, False);
Set_Convention (Renaming_Prim, Convention_Ada);
Set_Alias (Renaming_Prim, Empty);
Set_Has_Completion (Renaming_Prim, False);
-- Stage 3: Build the corresponding body
Left_Op := First_Formal (Renaming_Prim);
Right_Op := Next_Formal (Left_Op);
Decl :=
Predef_Spec_Or_Body (Loc,
Tag_Typ => Tag_Typ,
Name => Chars (Renaming_Prim),
Profile => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars (Left_Op)),
Parameter_Type => New_Reference_To (Tag_Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars (Right_Op)),
Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
Ret_Type => Standard_Boolean,
For_Body => True);
-- If the overriding of the equality primitive occurred before the
-- renaming, then generate:
-- function <Neq_Name> (X : Y : Typ) return Boolean is
-- begin
-- return not Oeq (X, Y);
-- end;
if Present (Eq_Prim) then
Target := Eq_Prim;
-- Otherwise build a nested subprogram which performs the predefined
-- evaluation of the equality operator. That is, generate:
-- function <Neq_Name> (X : Y : Typ) return Boolean is
-- function Oeq (X : Y) return Boolean is
-- begin
-- <<body of default implementation>>
-- end;
-- begin
-- return not Oeq (X, Y);
-- end;
else
declare
Local_Subp : Node_Id;
begin
Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq);
Set_Declarations (Decl, New_List (Local_Subp));
Target := Defining_Entity (Local_Subp);
end;
end if;
Append_To (Stmts,
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Op_Not (Loc,
Make_Function_Call (Loc,
Name => New_Reference_To (Target, Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Chars (Left_Op)),
Make_Identifier (Loc, Chars (Right_Op)))))));
Set_Handled_Statement_Sequence
(Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts));
return Decl;
end Make_Neq_Body;
-------------------------------
-- Make_Null_Procedure_Specs --
-------------------------------
@ -8238,13 +8427,6 @@ package body Exp_Ch3 is
Predef_List : out List_Id;
Renamed_Eq : out Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Res : constant List_Id := New_List;
Eq_Name : Name_Id := Name_Op_Eq;
Eq_Needed : Boolean;
Eq_Spec : Node_Id;
Prim : Elmt_Id;
function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean;
-- Returns true if Prim is a renaming of an unresolved predefined
-- equality operation.
@ -8262,6 +8444,19 @@ package body Exp_Ch3 is
and then Chars (Alias (Prim)) = Name_Op_Eq;
end Is_Predefined_Eq_Renaming;
-- Local variables
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Res : constant List_Id := New_List;
Eq_Name : Name_Id := Name_Op_Eq;
Eq_Needed : Boolean;
Eq_Spec : Node_Id;
Prim : Elmt_Id;
Has_Predef_Eq_Renaming : Boolean := False;
-- Set to True if Tag_Typ has a primitive that renames the predefined
-- equality operator. Used to implement (RM 8-5-4(8)).
-- Start of processing for Make_Predefined_Primitive_Specs
begin
@ -8299,9 +8494,9 @@ package body Exp_Ch3 is
end loop;
end;
-- Spec of "=" is expanded if the type is not limited and if a
-- user defined "=" was not already declared for the non-full
-- view of a private extension
-- Spec of "=" is expanded if the type is not limited and if a user
-- defined "=" was not already declared for the non-full view of a
-- private extension
if not Is_Limited_Type (Tag_Typ) then
Eq_Needed := True;
@ -8311,21 +8506,18 @@ package body Exp_Ch3 is
-- If a primitive is encountered that renames the predefined
-- equality operator before reaching any explicit equality
-- primitive, then we still need to create a predefined equality
-- function, because calls to it can occur via the renaming. A new
-- name is created for the equality to avoid conflicting with any
-- user-defined equality. (Note that this doesn't account for
-- function, because calls to it can occur via the renaming. A
-- new name is created for the equality to avoid conflicting with
-- any user-defined equality. (Note that this doesn't account for
-- renamings of equality nested within subpackages???)
if Is_Predefined_Eq_Renaming (Node (Prim)) then
Has_Predef_Eq_Renaming := True;
Eq_Name := New_External_Name (Chars (Node (Prim)), 'E');
-- User-defined equality
elsif Chars (Node (Prim)) = Name_Op_Eq
and then Etype (First_Formal (Node (Prim))) =
Etype (Next_Formal (First_Formal (Node (Prim))))
and then Base_Type (Etype (Node (Prim))) = Standard_Boolean
then
elsif Is_User_Defined_Equality (Node (Prim)) then
if No (Alias (Node (Prim)))
or else Nkind (Unit_Declaration_Node (Node (Prim))) =
N_Subprogram_Renaming_Declaration
@ -8394,7 +8586,7 @@ package body Exp_Ch3 is
Ret_Type => Standard_Boolean);
Append_To (Res, Eq_Spec);
if Eq_Name /= Name_Op_Eq then
if Has_Predef_Eq_Renaming then
Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec));
Prim := First_Elmt (Primitive_Operations (Tag_Typ));
@ -8966,6 +9158,14 @@ package body Exp_Ch3 is
Append_To (Res, Decl);
end if;
-- Body for inequality (if required!)
Decl := Make_Neq_Body (Tag_Typ);
if Present (Decl) then
Append_To (Res, Decl);
end if;
-- Body for dispatching assignment
Decl :=

6
gcc/ada/make.adb
View File

@ -4807,8 +4807,10 @@ package body Make is
return;
end if;
-- Regenerate libraries, if there are any and if object files
-- have been regenerated.
-- Regenerate libraries, if there are any and if object files have been
-- regenerated. Note that we skip this in CodePeer mode because we don't
-- need libraries in this case, and more importantly, the object files
-- may not be present.
if Main_Project /= No_Project
and then not CodePeer_Mode

8
gcc/ada/prj.adb
View File

@ -599,12 +599,14 @@ package body Prj is
function Has_Sources (P : Project_Id) return Boolean is
Lang : Language_Ptr;
begin
Lang := P.Languages;
while Lang /= No_Language_Index loop
if Lang.First_Source /= No_Source then
return True;
end if;
Lang := Lang.Next;
end loop;
@ -617,6 +619,7 @@ package body Prj is
function Get_From_Tree (P : Project_Id) return Project_Id is
List : Project_List := Tree.Projects;
begin
if not Has_Sources (P) then
while List /= null loop
@ -625,6 +628,7 @@ package body Prj is
then
return List.Project;
end if;
List := List.Next;
end loop;
end if;
@ -632,8 +636,12 @@ package body Prj is
return P;
end Get_From_Tree;
-- Local variables
List : Project_List;
-- Start of processing for Recursive_Check
begin
if not Seen_Name.Contains (Project.Name) then

19
gcc/ada/s-rident.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
@ -30,16 +30,17 @@
------------------------------------------------------------------------------
-- This package defines the set of restriction identifiers. It is a generic
-- package that is instantiated by the compiler/binder in package Rident, and
-- is instantiated in package System.Restrictions for use at run-time.
-- package that is instantiated by the binder for output of the restrictions
-- structure, and is instantiated in package System.Restrictions for use at
-- run-time.
-- The reason that we make this a generic package is so that in the case of
-- the instantiation in Rident for use at compile time and bind time, we can
-- generate normal image tables for the enumeration types, which are needed
-- for diagnostic and informational messages. At run-time we really do not
-- want to waste the space for these image tables, and they are not needed,
-- so we can do the instantiation under control of Discard_Names to remove
-- the tables.
-- the instantiation in the binder, we can generate normal image tables for
-- the enumeration types, which are needed for diagnostic and informational
-- messages as well as for identification of restrictions. At run-time we
-- really do not want to waste the space for these image tables, and they are
-- not needed, so we can do the instantiation under control of Discard_Names
-- to remove the tables.
pragma Compiler_Unit;

3
gcc/ada/sem_ch9.adb
View File

@ -244,6 +244,9 @@ package body Sem_Ch9 is
----------------
function Check_Node (N : Node_Id) return Traverse_Result is
-- The following function belongs in sem_eval ???
function Is_Static_Function (Attr : Node_Id) return Boolean;
-- Given an attribute reference node Attr, return True if
-- Attr denotes a static function according to the rules in

26
gcc/ada/snames.ads-tmpl
View File

@ -953,18 +953,24 @@ package Snames is
Last_Attribute_Name : constant Name_Id := N + $;
-- Names of internal attributes. They are not real attributes but special
-- names used internally by GNAT in order to deal with certain delayed
-- aspects (Aspect_CPU, Aspect_Dispatching_Domain,
-- Aspect_Interrupt_Priority) that don't have corresponding pragmas or
-- user-referencable attributes. It is convenient to have these internal
-- attributes available in processing the aspects, since the normal
-- approach is to convert an aspect into its corresponding pragma or
-- attribute specification.
-- names used internally by GNAT in order to deal with delayed aspects
-- (Aspect_CPU, Aspect_Dispatching_Domain, Aspect_Interrupt_Priority) that
-- don't have corresponding pragmas or user-referencable attributes.
-- It is convenient to have these internal attributes available for
-- processing the aspects, since the normal approach is to convert an
-- aspect into its corresponding pragma or attribute specification.
-- These attributes do have Attribute_Id values so that case statements
-- on Attribute_Id include these cases, but they are NOT included in the
-- Attribute_Name subtype defined above, which is typically used in the
-- front end for checking syntax of submitted programs (where the use of
-- internal attributes is not permitted).
First_Internal_Attribute_Name : constant Name_Id := N + $;
Name_CPU : constant Name_Id := N + $; -- INT
Name_Dispatching_Domain : constant Name_Id := N + $; -- INT
Name_Interrupt_Priority : constant Name_Id := N + $; -- INT
Name_CPU : constant Name_Id := N + $;
Name_Dispatching_Domain : constant Name_Id := N + $;
Name_Interrupt_Priority : constant Name_Id := N + $;
Last_Internal_Attribute_Name : constant Name_Id := N + $;
-- Names of recognized locking policy identifiers