+2010-09-09 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Is_Progenitor): Relocated to sem_type.
+ (Replace_Type): Code cleanup.
+ * sem_type.ads, sem_type.adb (Is_Progenitor): Relocated from sem_ch3
+
+2010-09-09 Thomas Quinot <quinot@adacore.com>
+
+ * exp_ch8.adb: Minor reformatting.
+
+2010-09-09 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch9.adb, einfo.adb, einfo.ads: New attribute
+ Corresponding_Protected_Entry.
+
2010-09-09 Ed Schonberg <schonberg@adacore.com>
* exp_ch3.adb (Build_Untagged_Equality): Do not set alias of implicit
-- Alias Node18
-- Corresponding_Concurrent_Type Node18
+ -- Corresponding_Protected_Entry Node18
-- Corresponding_Record_Type Node18
-- Delta_Value Ureal18
-- Enclosing_Scope Node18
return Node13 (Id);
end Corresponding_Equality;
+ function Corresponding_Protected_Entry (Id : E) return E is
+ begin
+ return Node18 (Id);
+ end Corresponding_Protected_Entry;
+
function Corresponding_Record_Type (Id : E) return E is
begin
pragma Assert (Is_Concurrent_Type (Id));
Set_Node13 (Id, V);
end Set_Corresponding_Equality;
+ procedure Set_Corresponding_Protected_Entry (Id : E; V : E) is
+ begin
+ Set_Node18 (Id, V);
+ end Set_Corresponding_Protected_Entry;
+
procedure Set_Corresponding_Record_Type (Id : E; V : E) is
begin
pragma Assert (Is_Concurrent_Type (Id));
when E_Record_Type =>
Write_Str ("Corresponding_Concurrent_Type");
+ when E_Subprogram_Body =>
+ Write_Str ("Corresponding_Protected_Entry");
+
when E_Entry_Index_Parameter =>
Write_Str ("Entry_Index_Constant");
-- other function entities, only in implicit inequality routines,
-- where Comes_From_Source is always False.
+-- Corresponding_Protected_Entry (Node18)
+-- Present in subrogram bodies that implement entries of protected
+-- types.
+
-- Corresponding_Record_Type (Node18)
-- Present in protected and task types and subtypes. References the
-- entity for the corresponding record type constructed by the expander
function Corresponding_Concurrent_Type (Id : E) return E;
function Corresponding_Discriminant (Id : E) return E;
function Corresponding_Equality (Id : E) return E;
+ function Corresponding_Protected_Entry (Id : E) return E;
function Corresponding_Record_Type (Id : E) return E;
function Corresponding_Remote_Type (Id : E) return E;
function Current_Use_Clause (Id : E) return E;
procedure Set_Corresponding_Concurrent_Type (Id : E; V : E);
procedure Set_Corresponding_Discriminant (Id : E; V : E);
procedure Set_Corresponding_Equality (Id : E; V : E);
+ procedure Set_Corresponding_Protected_Entry (Id : E; V : E);
procedure Set_Corresponding_Record_Type (Id : E; V : E);
procedure Set_Corresponding_Remote_Type (Id : E; V : E);
procedure Set_Current_Use_Clause (Id : E; V : E);
pragma Inline (Corresponding_Concurrent_Type);
pragma Inline (Corresponding_Discriminant);
pragma Inline (Corresponding_Equality);
+ pragma Inline (Corresponding_Protected_Entry);
pragma Inline (Corresponding_Record_Type);
pragma Inline (Corresponding_Remote_Type);
pragma Inline (Current_Use_Clause);
pragma Inline (Set_Corresponding_Concurrent_Type);
pragma Inline (Set_Corresponding_Discriminant);
pragma Inline (Set_Corresponding_Equality);
+ pragma Inline (Set_Corresponding_Protected_Entry);
pragma Inline (Set_Corresponding_Record_Type);
pragma Inline (Set_Corresponding_Remote_Type);
pragma Inline (Set_Current_Use_Clause);
end if;
-- Check whether this is a renaming of a predefined equality on an
- -- untagged record type (AI05-0123).
+ -- untagged record type (AI05-0123).
if Is_Entity_Name (Nam)
and then Chars (Entity (Nam)) = Name_Op_Eq
Id : constant Entity_Id := Defining_Entity (N);
Typ : constant Entity_Id := Etype (First_Formal (Id));
- Decl : Node_Id;
- Body_Id : constant Entity_Id
- := Make_Defining_Identifier (Sloc (N), Chars (Id));
+ Decl : Node_Id;
+ Body_Id : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc (N), Chars (Id));
begin
if Is_Record_Type (Typ)
Set_Has_Delayed_Freeze (Id);
Decl := Make_Subprogram_Body (Loc,
- Specification =>
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Body_Id,
- Parameter_Specifications => Copy_Parameter_List (Id),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc)),
- Declarations => Empty_List,
- Handled_Statement_Sequence => Empty);
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Body_Id,
+ Parameter_Specifications =>
+ Copy_Parameter_List (Id),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc)),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence => Empty);
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
raise Program_Error;
end case;
+ -- Establish link between subprogram body entity and source entry.
+
+ Set_Corresponding_Protected_Entry (Edef, Ent);
+
-- Create body of entry procedure. The renaming declarations are
-- placed ahead of the block that contains the actual entry body.
-- copying the record declaration for the derived base. In the tagged case
-- the value returned is irrelevant.
- function Is_Progenitor
- (Iface : Entity_Id;
- Typ : Entity_Id) return Boolean;
- -- Determine whether the interface Iface is implemented by Typ. It requires
- -- traversing the list of abstract interfaces of the type, as well as that
- -- of the ancestor types. The predicate is used to determine when a formal
- -- in the signature of an inherited operation must carry the derived type.
-
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
Constraint_Kind : Node_Kind) return Boolean;
Set_Etype (New_Id, Base_Type (Derived_Type));
end if;
- -- Ada 2005 (AI-251): Handle derivations of abstract interface
- -- primitives.
-
- elsif Is_Interface (Etype (Id))
- and then not Is_Class_Wide_Type (Etype (Id))
- and then Is_Progenitor (Etype (Id), Derived_Type)
- then
- Set_Etype (New_Id, Derived_Type);
-
else
Set_Etype (New_Id, Etype (Id));
end if;
end if;
end Is_Null_Extension;
- --------------------
- -- Is_Progenitor --
- --------------------
-
- function Is_Progenitor
- (Iface : Entity_Id;
- Typ : Entity_Id) return Boolean
- is
- begin
- return Implements_Interface (Typ, Iface,
- Exclude_Parents => True);
- end Is_Progenitor;
-
------------------------------
-- Is_Valid_Constraint_Kind --
------------------------------
end if;
end Is_Invisible_Operator;
+ --------------------
+ -- Is_Progenitor --
+ --------------------
+
+ function Is_Progenitor
+ (Iface : Entity_Id;
+ Typ : Entity_Id) return Boolean
+ is
+ begin
+ return Implements_Interface (Typ, Iface, Exclude_Parents => True);
+ end Is_Progenitor;
+
-------------------
-- Is_Subtype_Of --
-------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
-- T1 is a tagged type (not class-wide). Verify that it is one of the
-- ancestors of type T2 (which may or not be class-wide).
+ function Is_Progenitor
+ (Iface : Entity_Id;
+ Typ : Entity_Id) return Boolean;
+ -- Determine whether the interface Iface is implemented by Typ. It requires
+ -- traversing the list of abstract interfaces of the type, as well as that
+ -- of the ancestor types. The predicate is used to determine when a formal
+ -- in the signature of an inherited operation must carry the derived type.
+
function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean;
-- Checks whether T1 is any subtype of T2 directly or indirectly. Applies
-- only to scalar subtypes???
projects / platform / upstream / linaro-gcc.git / commitdiff