diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2005-06-16 08:32:47 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2005-06-16 08:32:47 +0000 |
| commit | aad6babd3202684e69d09d60051b89b59092cc2d (patch) | |
| tree | 59a6d971ec99b14088954383ecddf8339a1c0e07 | |
| parent | 970e0382740ebed49eea06020812dcc57ffdbd71 (diff) | |
| download | gcc-aad6babd3202684e69d09d60051b89b59092cc2d.tar.gz | |
2005-06-14 Gary Dismukes <dismukes@adacore.com>
Javier Miranda <miranda@adacore.com>
Ed Schonberg <schonberg@adacore.com>
Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch4.adb (Expand_Allocator_Expression): When an initialized
allocator's designated type is a class-wide type, and compiling for
Ada 2005, emit a run-time check that the accessibility level of the
type given in the allocator's expression is not deeper than the level
of the allocator's access type.
(Tagged_Membership): Modified to gives support to abstract interface
types.
* a-tags.ads, a-tags.adb (type Type_Specific_Data): Add component
Access_Level.
(Descendant_Tag): New predefined function
(Is_Descendant_At_Same_Level): New predefined function
(Get_Access_Level): New private function
(Set_Access_Level): New private procedure
(IW_Membership): New function. Given the tag of an object and the tag
associated with an interface, evaluate if the object implements the
interface.
(Register_Interface_Tag): New procedure used to initialize the table of
interfaces used by the IW_Membership function.
(Set_Offset_To_Top): Initialize the Offset_To_Top field in the prologue
of the dispatch table.
(Inherit_TSD): Modified to copy the table of ancestor tags plus the
table of interfaces of the parent.
(Expanded_Name): Raise Tag_Error if the passed tag equals No_Tag.
(External_Tag): Raise Tag_Error if the passed tag equals No_Tag.
(Parent_Tag): Return No_Tag in the case of a root-level tagged type,
and raise Tag_Error if the passed tag equalis No_Tag, to conform with
Ada 2005 semantics for the new predefined function.
* exp_attr.adb (Expand_N_Attribute, case Attribute_Input): Generate
call to Descendant_Tag rather than Internal_Tag.
(Expand_N_Attribute, case Attribute_Output): Emit a check to ensure that
the accessibility level of the attribute's Item parameter is not deeper
than the level of the attribute's prefix type. Tag_Error is raised if
the check fails. The check is only emitted for Ada_05.
(Find_Stream_Subprogram): If a TSS exists on the type itself for the
requested stream attribute, use it.
(Expand_N_Attribute_Reference): If the designated type is an interface
then rewrite the referenced object as a conversion to force the
displacement of the pointer to the secondary dispatch table.
(Expand_N_Attribute_Reference, case 'Constrained): Return false if this
is a dereference of an object with a constrained partial view.
* exp_ch5.adb (Expand_N_Return_Statement): When a function's result
type is a class-wide type, emit a run-time check that the accessibility
level of the returned object is not deeper than the level of the
function's master (only when compiling for Ada 2005).
* exp_disp.ads, exp_disp.adb (Ada_Actions, Action_Is_Proc,
Action_Nb_Arg): Add entries for new Get_Access_Level and
Set_Access_Level routines in these tables.
(Make_DT): Generate a call to set the accessibility level of the
tagged type in its TSD.
(Make_DT): Code cleanup. The functionality of generating all the
secondary dispatch tables has been moved to freeze_record_type.
(Make_Abstract_Interface_DT): Minor code cleanup.
(Set_All_DT_Position): Code cleanup. As part of the code cleanup
this subprogram implements a new algorithm that provides the
same functionality and it is more clear in case of primitives
associated with abstract interfaces.
(Set_All_Interfaces_DTC_Entity): Removed. As part of the code
clean up, the functionality of this subprogram is now provided
by Set_All_DT_Position.
(Write_DT): New subprogram: a debugging procedure designed to be called
within gdb to display the dispatch tables associated with a tagged
type.
(Collect_All_Interfaces): New subprogram that collects the whole list
of interfaces that are directly or indirectly implemented by a tagged
type.
(Default_Prim_Op_Position): New subprogram that returns the fixed
position in the dispatch table of the default primitive operations.
(Expand_Interface_Actuals): New subprogram to generate code that
displaces all the actuals corresponding to class-wide interfaces to
reference the interface tag of the actual object.
(Expand_Interface_Conversion): New subprogram. Reference the base of
the object to give access to the interface tag associated with the
secondary dispatch table.
(Expand_Interface_Thunk): New subprogram that generates the code of the
thunk. This is required for compatibility with the C+ ABI.
(Make_Abstract_Interface_DT): New subprogram that generate the
declarations for the secondary dispatch tables associated with an
abstract interface.
(Set_All_Interfaces_DTC_Entity): New subprogram that sets the DTC_Entity
attribute for each primitive operation covering interface subprograms
(Expand_Dispatching_Call, Fill_DT_Entry, Make_DT, Set_All_DT_Position):
These subprograms were upgraded to give support to abstract interfaces
* rtsfind.ads (type RE_Id): Add RE_Descendant_Tag,
RE_Is_Descendant_At_Same_Level, RE_Get_Access_Level, and
RE_Set_Access_Level.
(RE_Unit_Table): Add entries for new Ada.Tags operations.
Add support to call the followig new run-time subprograms:
IW_Membership, Register_Interface_Tag, and Set_Offset_To_Top
* sem_ch3.adb (Constant_Redeclaration): Allow a deferred constant to
match its full declaration when both have an access definition with
statically matching designated subtypes.
(Analyze_Component_Declaration): Delete commented out code that was
incorrectly setting the scope of an anonymous access component's type.
(Process_Discriminants): Set Is_Local_Anonymous_Access for the type of
an access discriminant when the containing type is nonlimited.
(Make_Incomplete_Type_Declaration): Create an incomplete type
declaration for a record type that includes self-referential access
components.
(Check_Anonymous_Access_Types): Before full analysis of a record type
declaration, create anonymous access types for each self-referential
access component.
(Analyze_Component_Declaration, Array_Type_Declaration): Indicate that
an access component in this context is a Local_Anonymous_Access, for
proper accessibility checks.
(Access_Definition): Set properly the scope of the anonymous access type
created for a stand-alone access object.
(Find_Type_Of_Object): An object declaration may be given with an access
definition.
(Complete_Subprograms_Derivation): New subprogram used to complete
type derivation of private tagged types implementing interfaces.
In this case some interface primitives may have been overriden
with the partial-view and, instead of re-calculating them, they
are included in the list of primitive operations of the full-view.
(Build_Derived_Record_Type): Modified to give support to private
types implemening interfaces.
(Access_Definition): Reject ALL on anonymous access types.
(Build_Derived_Record_Type): In the case of Ada 2005, allow a tagged
type derivation to occur at a deeper accessibility level than the
parent type.
For the case of derivation within a generic body however, disallow the
derivation if the derived type has an ancestor that is a formal type
declared in the formal part of an enclosing generic.
(Analyze_Object_Declaration): For protected objects, remove the check
that they cannot contain interrupt handlers if not declared at library
level.
(Add_Interface_Tag_Components): New subprogram to add the tag components
corresponding to all the abstract interface types implemented by a
record type or a derived record type.
(Analyze_Private_Extension_Declaration, Build_Derived_Record_Type,
Derived_Type_Declaration, Find_Type_Name, Inherit_Components,
Process_Full_View, Record_Type_Declaration): Modified to give
support to abstract interface types
(Collect_Interfaces): New subprogram that collects the list of
interfaces that are not already implemented by the ancestors
(Process_Full_View): Set flag Has_Partial_Constrained_View appropriately
when partial view has no discriminants and full view has defaults.
(Constrain_Access): Reject a constraint on a general access type
if the discriminants of the designated type have defaults.
(Access_Subprogram_Declaration): Associate the Itype node with the inner
full-type declaration or subprogram spec. This is required to handle
nested anonymous declarations.
(Analyze_Private_Extension_Declaration, Build_Derived_Record_Type,
Derived_Type_Declaration, Find_Type_Name, Inherit_Components,
Process_Full_View, Record_Type_Declaration): Modified to give
support to abstract interface types
(Derive_Subprograms): Addition of a new formal to indicate if
we are in the case of an abstact-interface derivation
(Find_Type_Of_Subtype_Indic): Moved from the body of the package
to the specification because it is requied to analyze all the
identifiers found in a list of interfaces
* debug.adb: Complete documentation of flag "-gnatdZ"
* exp_ch3.adb: Implement config version of persistent_bss pragma
(Check_Stream_Attributes): Use Stream_Attribute_Available instead of
testing for TSS presence to properly enforce visibility rules.
(Freeze_Record_Type): Code cleanup. Modified to call the subprogram
Make_Abstract_Interfaces_DT to generate the secondary tables
associated with abstract interfaces.
(Build_Init_Procedure): Modified to initialize all the tags
corresponding.
(Component_Needs_Simple_Initialization): Similar to other tags,
interface tags do not need initialization.
(Freeze_Record_Type): Modified to give support to abstract interface
types.
(Expand_N_Object_Declaration): Do not generate an initialization for
a scalar temporary marked as internal.
* exp_ch6.adb (Add_Simple_Call_By_Copy_Code): Handle properly an
in-out parameter that is a component in an initialization procedure,
whose constraint might depend on discriminants, and that may be
misaligned because of packing or representation clauses.
(Is_Legal_Copy): New predicate to determine whether a possibly
misaligned in-out actual can actually be passed by copy/return. This
is an error in case the type is by_reference, and a warning if this is
the consequence of a DEC import pragma on the subprogram.
(Expand_Call, Freeze_Subprogram): Modified to give support to abstract
interface types
(Expand_Inlined_Call): Mark temporary generated for the return value as
internal, so that no useless scalar normalization is generated for it.
(Expand_N_Subprogram_Declaration): Save unanalyzed body so calls to
null procedure can always be inlined.
(Expand_N_Subprogram_Declaration): If this is the declaration of a null
procedure, generate an explicit empty body for it.
* exp_util.ads, exp_util.adb (Find_Interface_ADT): New subprogram.
Given a type implementing an interface, returns the corresponding
access_disp_table value.
(Find_Interface_Tag): New subprogram. Given a type implementing an
interface, returns the record component containing the tag of the
interface.
(Find_Interface_Tag): New overloaded subprogram. Subsidiary to the
previous ones that return the corresponding tag and access_disp_table
entities.
(Is_Predefined_Dispatching_Operation): Determines if a subprogram
is a predefined primitive operation.
(Expand_Subtype_From_Expr): If the expression is a selected component
within an initialization procedure, compute its actual subtype, because
the component may depend on the discriminants of the enclosing record.
* i-cpp.ads, i-cpp.adb:
This package has been left available for compatibility with previous
versions of the frontend. As part of the new layout this is now a
dummy package that uses declarations available at a-tags.ads
* par-ch3.adb (P_Identifier_Declarations): Give an error for use of
"constant access" and "aliased [constant] access" when not compiling
with -gnat05.
Suppress Ada 2005 keyword warning if -gnatwY used
(P_Identifier_Declarations): Add support for object declarations with
access definitions.
(Private_Extension_Declaration): Complete the documentation
(P_Derived_Type_Def_Or_Private_Ext_Decl): Fill the inteface_list
attribute in case of private extension declaration
(P_Type_Declaration): Mark as "abstract" the type declarations
corresponding with protected, synchronized and task interfaces
(P_Declarative_Items): "not" and "overriding" are overriding indicators
for a subprogram or instance declaration.
* sem_ch12.adb (Analyze_Subprogram_Instantiation): Verify that an
instantiation that is a dispatching operation has controlling access
parameters that are null excluding.
Save and restore Ada_Version_Explicit, for implementation of AI-362
(Validate_Derived_Type_Instance): Add check for abstract interface
types.
(Analyze_Formal_Package): Establish Instantiation source for the copy of
the generic that is created to represent the formal package.
(Analyze_Package_Instantiation): Instantiate body immediately if the
package is a predefined unit that contains inlined subprograms, and
we are compiling for a Configurable_Run_Time.
(Instantiate_Formal_Subprogram): Indicate that null default subprogram
If the program has a null default, generate an empty body for it.
* sem_ch6.adb, sem_ch9.adb (Analyze_Subprograms_Declaration): Update
error message condition, null procedures are correctly detected now.
(New_Overloaded_Entity): Bypass trivial overriding indicator check
for subprograms in the context of protected types. Instead, the
indicator is examined in Sem_Ch9 while analysing the subprogram
declaration.
(Check_Overriding_Indicator): Check consistency of overriding indicator
on subprogram stubs as well.
(Analyze_Subprogram_Declaration): Diagnose null procedures declared at
the library level.
(Analize_Subprogram_Specification): When analyzing a subprogram in which
the type of the first formal is a concurrent type, replace this type
by the corresponding record type.
(Analyze_Subprogram_Body): Undo the previous work.
(Analyze_Procedure_Call): If the call has the form Object.Op, the
analysis of the prefix ends up analyzing the call itself, after which
we are done.
(Has_Interface_Formals): New subprogram subsidiary to analyze
subprogram_specification that returns true if some non
class-wide interface subprogram is found
(New_Overloaded_Entity): Modified to give support to abstract
interface types
(Conforming_Types): In Ada 2005 mode, conformance checking of anonymous
access to subprograms must be recursive.
(Is_Unchecked_Conversion): Improve the test that recognizes
instantiations of Unchecked_Conversion, and allows them in bodies that
are to be inlined by the front-end. When the body comes from an
instantiation, a reference to Unchecked_Conversion will be an
Expanded_Name, even though the body has not been analyzed yet.
Replace Is_Overriding and Not_Overriding in subprogram_indication with
Must_Override and Must_Not_Override, to better express intent of AI.
(Analyze_Subprogram_Body): If an overriding indicator is given, check
that it is consistent with the overrinding status of the subprogram
at this point.
(Analyze_Subprogram_Declaration): Indicate that a null procedure is
always inlined.
If the subprogram is a null procedure, indicate that it does not need
a completion.
* sem_disp.adb (Check_Controlling_Type): Give support to entities
available through limited-with clauses.
(Check_Dispatching_Operation): A stub acts like a body, and therefore is
allowed as the last primitive of a tagged type if it has no previous
spec.
(Override_Dispatching_Operation, Check_Dispatching_Operation): Modified
to give support to abstract interface types
* sem_res.adb (Valid_Conversion): Perform an accessibility level check
in the case where the target type is an anonymous access type of an
object or component (that is, when Is_Local_Anonymous_Access is true).
Prevent the special checks for conversions of access discriminants in
the case where the discriminant belongs to a nonlimited type, since
such discriminants have their accessibility level defined in the same
way as a normal component of an anonymous access type.
(Resolve_Allocator): When an allocator's designated type is a class-wide
type, check that the accessibility level of type given in the
allocator's expression or subtype indication is not statically deeper
than the level of the allocator's access type.
(Check_Discriminant_Use): Diagnose discriminant given by an expanded
name in a discriminant constraint of a record component.
(Resolve_Explicit_Dereference): Do not check whether the type is
incomplete when the dereference is a use of an access discriminant in
an initialization procedure.
(Resolve_Type_Conversion): Handle conversions to abstract interface
types.
(Valid_Tagged_Conversion): The conversion of a tagged type to an
abstract interface type is always valid.
(Valid_Conversion): Modified to give support to abstract interface types
(Resolve_Actuals): Enable full error reporting on view conversions
between unrelated by_reference array types.
The rule for view conversions of arrays with aliased components is
weakened in Ada 2005.
Call to obsolescent subprogram is now considered to be a violation of
pragma Restrictions (No_Obsolescent_Features).
(Check_Direct_Boolean_Operator): If the boolean operation has been
constant-folded, there is nothing to check.
(Resolve_Comparison_Op, Resolve_Equality_Op, Resolve_Boolean_Op): Defer
check on possible violation of restriction No_Direct_Boolean_Operators
until after expansion of operands, to prevent spurious errors when
operation is constant-folded.
* sem_type.ads, sem_type.adb (Covers, Intersect_Types, Specific_Type,
Has_Compatible_Type): Modified to give support to abstract interface
types.
(Interface_Present_In_Ancestor): New function to theck if some ancestor
of a given type implements a given interface
* sem_ch4.adb (Analyze_Call): Handle properly an indirect call whose
prefix is a parameterless function that returns an access_to_procedure.
(Transform_Object_Operation): Handle properly function calls of the
form Obj.Op (X), which prior to analysis appear as indexed components.
(Analyze_One_Call): Complete the error notification to help new Ada
2005 users.
(Analyze_Allocator): For an allocator without an initial value, where
the designated type has a constrained partial view, a discriminant
constraint is illegal.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@101024 138bc75d-0d04-0410-961f-82ee72b054a4
| -rw-r--r-- | gcc/ada/a-tags.adb | 313 | ||||
| -rw-r--r-- | gcc/ada/a-tags.ads | 75 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 277 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 157 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 85 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 27 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 205 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 1599 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.ads | 50 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 276 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 421 | ||||
| -rw-r--r-- | gcc/ada/i-cpp.adb | 354 | ||||
| -rw-r--r-- | gcc/ada/i-cpp.ads | 171 | ||||
| -rw-r--r-- | gcc/ada/par-ch3.adb | 116 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 20 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 138 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 1609 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 77 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 403 | ||||
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 414 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.adb | 115 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 581 | ||||
| -rw-r--r-- | gcc/ada/sem_type.adb | 183 | ||||
| -rw-r--r-- | gcc/ada/sem_type.ads | 9 |
25 files changed, 5998 insertions, 1679 deletions
diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index df4e58e81f6..1899c6c3024 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUNTIME COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- -- A D A . T A G S -- -- -- @@ -33,6 +33,7 @@ with Ada.Exceptions; with System.HTable; +with System.Storage_Elements; use System.Storage_Elements; pragma Elaborate_All (System.HTable); @@ -57,10 +58,16 @@ package body Ada.Tags is -- +-------------------+ -- | Rec Ctrler offset | -- +-------------------+ +-- | Num_Interfaces | +-- +-------------------+ -- | table of | -- : ancestor : -- | tags | -- +-------------------+ +-- | table of | +-- | interface | +-- | tags | +-- +-------------------+ subtype Cstring is String (Positive); type Cstring_Ptr is access all Cstring; @@ -71,32 +78,34 @@ package body Ada.Tags is -- We suppress index checks because the declared size in the record below -- is a dummy size of one (see below). - type Wide_Boolean is new Boolean; - -- This name should probably be changed sometime ??? and indeed probably - -- this field could simply be of type Standard.Boolean. - type Type_Specific_Data is record - Idepth : Natural; - Expanded_Name : Cstring_Ptr; - External_Tag : Cstring_Ptr; - HT_Link : Tag; - Remotely_Callable : Wide_Boolean; - RC_Offset : SSE.Storage_Offset; - Ancestor_Tags : Tag_Table (0 .. 1); + Idepth : Natural; + Access_Level : Natural; + Expanded_Name : Cstring_Ptr; + External_Tag : Cstring_Ptr; + HT_Link : Tag; + Remotely_Callable : Boolean; + RC_Offset : SSE.Storage_Offset; + Num_Interfaces : Natural; + Tags_Table : Tag_Table (Natural); + + -- The size of the Tags_Table array actually depends on the tagged type + -- to which it applies. The compiler ensures that has enough space to + -- store all the entries of the two tables phisically stored there: the + -- "table of ancestor tags" and the "table of interface tags". For this + -- purpose we are using the same mechanism as for the Prims_Ptr array in + -- the Dispatch_Table record. See comments below for more details. + end record; - -- The size of the Ancestor_Tags array actually depends on the tagged type - -- to which it applies. We are using the same mechanism as for the - -- Prims_Ptr array in the Dispatch_Table record. See comments below for - -- more details. type Dispatch_Table is record - -- Offset_To_Top : Integer := 0; + -- Offset_To_Top : Natural; -- Typeinfo_Ptr : System.Address; -- Currently TSD is also here??? - Prims_Ptr : Address_Array (Positive); + Prims_Ptr : Address_Array (Positive); end record; -- Note on the commented out fields of the Dispatch_Table - -- ------------------------------------------------------ + -- -- According to the C++ ABI the components Offset_To_Top and Typeinfo_Ptr -- are stored just "before" the dispatch table (that is, the Prims_Ptr -- table), and they are referenced with negative offsets referring to the @@ -106,7 +115,6 @@ package body Ada.Tags is -- expander generates a Prims_Ptr table that has enough space for these -- additional components, and generates code that displaces the _Tag to -- point after these components. - -- ----------------------------------------------------------------------- -- The size of the Prims_Ptr array actually depends on the tagged type to -- which it applies. For each tagged type, the expander computes the @@ -131,20 +139,20 @@ package body Ada.Tags is -- Unchecked Conversions for String Fields -- --------------------------------------------- - function To_Cstring_Ptr is - new Unchecked_Conversion (System.Address, Cstring_Ptr); - function To_Address is new Unchecked_Conversion (Cstring_Ptr, System.Address); - ----------------------------------------------------------- - -- Unchecked Conversions for the component offset_to_top -- - ----------------------------------------------------------- + function To_Cstring_Ptr is + new Unchecked_Conversion (System.Address, Cstring_Ptr); + + ------------------------------------------------ + -- Unchecked Conversions for other components -- + ------------------------------------------------ - type Int_Ptr is access Integer; + type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset; - function To_Int_Ptr is - new Unchecked_Conversion (System.Address, Int_Ptr); + function To_Storage_Offset_Ptr is + new Unchecked_Conversion (System.Address, Storage_Offset_Ptr); ----------------------- -- Local Subprograms -- @@ -154,7 +162,8 @@ package body Ada.Tags is -- Length of string represented by the given pointer (treating the string -- as a C-style string, which is Nul terminated). - function Offset_To_Top (T : Tag) return Integer; + function Offset_To_Top + (T : Tag) return System.Storage_Elements.Storage_Offset; -- Returns the current value of the offset_to_top component available in -- the prologue of the dispatch table. @@ -162,7 +171,6 @@ package body Ada.Tags is -- Returns the current value of the typeinfo_ptr component available in -- the prologue of the dispatch table. - pragma Unreferenced (Offset_To_Top); pragma Unreferenced (Typeinfo_Ptr); -- These functions will be used for full compatibility with the C++ ABI @@ -266,8 +274,9 @@ package body Ada.Tags is -- Obj in Typ'Class - -- Each dispatch table contains a reference to a table of ancestors - -- (Ancestor_Tags) and a count of the level of inheritance "Idepth" . + -- Each dispatch table contains a reference to a table of ancestors (stored + -- in the first part of the Tags_Table) and a count of the level of + -- inheritance "Idepth". -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are -- contained in the dispatch table referenced by Obj'Tag . Knowing the @@ -280,16 +289,79 @@ package body Ada.Tags is function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is Pos : constant Integer := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth; begin - return Pos >= 0 and then TSD (Obj_Tag).Ancestor_Tags (Pos) = Typ_Tag; + return Pos >= 0 and then TSD (Obj_Tag).Tags_Table (Pos) = Typ_Tag; end CW_Membership; ------------------- + -- IW_Membership -- + ------------------- + + -- Canonical implementation of Classwide Membership corresponding to: + + -- Obj in Iface'Class + + -- Each dispatch table contains a table with the tags of all the + -- implemented interfaces. + + -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces + -- that are contained in the dispatch table referenced by Obj'Tag. + + function IW_Membership + (This : System.Address; + Iface_Tag : Tag) return Boolean + is + T : constant Tag := To_Tag_Ptr (This).all; + Obj_Base : constant System.Address := This - Offset_To_Top (T); + T_Base : constant Tag := To_Tag_Ptr (Obj_Base).all; + + Obj_TSD : constant Type_Specific_Data_Ptr := TSD (T_Base); + Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces; + Id : Natural; + + begin + if Obj_TSD.Num_Interfaces > 0 then + Id := Obj_TSD.Idepth + 1; + loop + if Obj_TSD.Tags_Table (Id) = Iface_Tag then + return True; + end if; + + Id := Id + 1; + exit when Id > Last_Id; + end loop; + end if; + + return False; + end IW_Membership; + + -------------------- + -- Descendant_Tag -- + -------------------- + + function Descendant_Tag (External : String; Ancestor : Tag) return Tag is + Int_Tag : constant Tag := Internal_Tag (External); + + begin + if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then + raise Tag_Error; + end if; + + return Int_Tag; + end Descendant_Tag; + + ------------------- -- Expanded_Name -- ------------------- function Expanded_Name (T : Tag) return String is - Result : constant Cstring_Ptr := TSD (T).Expanded_Name; + Result : Cstring_Ptr; + begin + if T = No_Tag then + raise Tag_Error; + end if; + + Result := TSD (T).Expanded_Name; return Result (1 .. Length (Result)); end Expanded_Name; @@ -298,12 +370,27 @@ package body Ada.Tags is ------------------ function External_Tag (T : Tag) return String is - Result : constant Cstring_Ptr := TSD (T).External_Tag; + Result : Cstring_Ptr; begin + if T = No_Tag then + raise Tag_Error; + end if; + + Result := TSD (T).External_Tag; + return Result (1 .. Length (Result)); end External_Tag; ---------------------- + -- Get_Access_Level -- + ---------------------- + + function Get_Access_Level (T : Tag) return Natural is + begin + return TSD (T).Access_Level; + end Get_Access_Level; + + ---------------------- -- Get_External_Tag -- ---------------------- @@ -318,8 +405,7 @@ package body Ada.Tags is function Get_Prim_Op_Address (T : Tag; - Position : Positive) return System.Address - is + Position : Positive) return System.Address is begin return T.Prims_Ptr (Position); end Get_Prim_Op_Address; @@ -339,7 +425,7 @@ package body Ada.Tags is function Get_Remotely_Callable (T : Tag) return Boolean is begin - return TSD (T).Remotely_Callable = True; + return TSD (T).Remotely_Callable; end Get_Remotely_Callable; ---------------- @@ -368,15 +454,23 @@ package body Ada.Tags is begin if Old_Tag /= null then - Old_TSD_Ptr := TSD (Old_Tag); + Old_TSD_Ptr := TSD (Old_Tag); New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1; - New_TSD_Ptr.Ancestor_Tags (1 .. New_TSD_Ptr.Idepth) := - Old_TSD_Ptr.Ancestor_Tags (0 .. Old_TSD_Ptr.Idepth); + New_TSD_Ptr.Num_Interfaces := Old_TSD_Ptr.Num_Interfaces; + + -- Copy the "table of ancestor tags" plus the "table of interfaces" + -- of the parent + + New_TSD_Ptr.Tags_Table + (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) + := Old_TSD_Ptr.Tags_Table + (0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces); else - New_TSD_Ptr.Idepth := 0; + New_TSD_Ptr.Idepth := 0; + New_TSD_Ptr.Num_Interfaces := 0; end if; - New_TSD_Ptr.Ancestor_Tags (0) := New_Tag; + New_TSD_Ptr.Tags_Table (0) := New_Tag; end Inherit_TSD; ------------------ @@ -410,6 +504,19 @@ package body Ada.Tags is return Res; end Internal_Tag; + --------------------------------- + -- Is_Descendant_At_Same_Level -- + --------------------------------- + + function Is_Descendant_At_Same_Level + (Descendant : Tag; + Ancestor : Tag) return Boolean + is + begin + return CW_Membership (Descendant, Ancestor) + and then TSD (Descendant).Access_Level = TSD (Ancestor).Access_Level; + end Is_Descendant_At_Same_Level; + ------------ -- Length -- ------------ @@ -425,6 +532,21 @@ package body Ada.Tags is return Len - 1; end Length; + ------------------- + -- Offset_To_Top -- + ------------------- + + function Offset_To_Top + (T : Tag) return System.Storage_Elements.Storage_Offset + is + Offset_To_Top_Ptr : constant Storage_Offset_Ptr := + To_Storage_Offset_Ptr (To_Address (T) + - DT_Typeinfo_Ptr_Size + - DT_Offset_To_Top_Size); + begin + return Offset_To_Top_Ptr.all; + end Offset_To_Top; + ----------------- -- Parent_Size -- ----------------- @@ -439,12 +561,12 @@ package body Ada.Tags is (Obj : System.Address; T : Tag) return SSE.Storage_Count is - Parent_Tag : constant Tag := TSD (T).Ancestor_Tags (1); + Parent_Tag : constant Tag := TSD (T).Tags_Table (1); -- The tag of the parent type through the dispatch table F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1)); -- Access to the _size primitive of the parent. We assume that - -- it is always in the first slot of the distatch table + -- it is always in the first slot of the dispatch table begin -- Here we compute the size of the _parent field of the object @@ -458,9 +580,57 @@ package body Ada.Tags is function Parent_Tag (T : Tag) return Tag is begin - return TSD (T).Ancestor_Tags (1); + if T = No_Tag then + raise Tag_Error; + end if; + + -- The Parent_Tag of a root-level tagged type is defined to be No_Tag. + -- The first entry in the Ancestors_Tags array will be null for such + -- a type, but it's better to be explicit about returning No_Tag in + -- this case. + + if TSD (T).Idepth = 0 then + return No_Tag; + else + return TSD (T).Tags_Table (1); + end if; end Parent_Tag; + ---------------------------- + -- Register_Interface_Tag -- + ---------------------------- + + procedure Register_Interface_Tag + (T : Tag; + Interface_T : Tag) + is + New_T_TSD : constant Type_Specific_Data_Ptr := TSD (T); + Index : Natural; + begin + -- Check if the interface is already registered + + if New_T_TSD.Num_Interfaces > 0 then + declare + Id : Natural := New_T_TSD.Idepth + 1; + Last_Id : constant Natural := New_T_TSD.Idepth + + New_T_TSD.Num_Interfaces; + begin + loop + if New_T_TSD.Tags_Table (Id) = Interface_T then + return; + end if; + + Id := Id + 1; + exit when Id > Last_Id; + end loop; + end; + end if; + + New_T_TSD.Num_Interfaces := New_T_TSD.Num_Interfaces + 1; + Index := New_T_TSD.Idepth + New_T_TSD.Num_Interfaces; + New_T_TSD.Tags_Table (Index) := Interface_T; + end Register_Interface_Tag; + ------------------ -- Register_Tag -- ------------------ @@ -470,6 +640,15 @@ package body Ada.Tags is External_Tag_HTable.Set (T); end Register_Tag; + ---------------------- + -- Set_Access_Level -- + ---------------------- + + procedure Set_Access_Level (T : Tag; Value : Natural) is + begin + TSD (T).Access_Level := Value; + end Set_Access_Level; + ----------------------- -- Set_Expanded_Name -- ----------------------- @@ -488,6 +667,22 @@ package body Ada.Tags is TSD (T).External_Tag := To_Cstring_Ptr (Value); end Set_External_Tag; + ----------------------- + -- Set_Offset_To_Top -- + ----------------------- + + procedure Set_Offset_To_Top + (T : Tag; + Value : System.Storage_Elements.Storage_Offset) + is + Offset_To_Top_Ptr : constant Storage_Offset_Ptr := + To_Storage_Offset_Ptr (To_Address (T) + - DT_Typeinfo_Ptr_Size + - DT_Offset_To_Top_Size); + begin + Offset_To_Top_Ptr.all := Value; + end Set_Offset_To_Top; + ------------------------- -- Set_Prim_Op_Address -- ------------------------- @@ -495,8 +690,7 @@ package body Ada.Tags is procedure Set_Prim_Op_Address (T : Tag; Position : Positive; - Value : System.Address) - is + Value : System.Address) is begin T.Prims_Ptr (Position) := Value; end Set_Prim_Op_Address; @@ -516,11 +710,7 @@ package body Ada.Tags is procedure Set_Remotely_Callable (T : Tag; Value : Boolean) is begin - if Value then - TSD (T).Remotely_Callable := True; - else - TSD (T).Remotely_Callable := False; - end if; + TSD (T).Remotely_Callable := Value; end Set_Remotely_Callable; ------------- @@ -528,31 +718,17 @@ package body Ada.Tags is ------------- procedure Set_TSD (T : Tag; Value : System.Address) is - use type System.Storage_Elements.Storage_Offset; TSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); begin TSD_Ptr.all := Value; end Set_TSD; - ------------------- - -- Offset_To_Top -- - ------------------- - - function Offset_To_Top (T : Tag) return Integer is - use type System.Storage_Elements.Storage_Offset; - TSD_Ptr : constant Int_Ptr := - To_Int_Ptr (To_Address (T) - DT_Prologue_Size); - begin - return TSD_Ptr.all; - end Offset_To_Top; - ------------------ -- Typeinfo_Ptr -- ------------------ function Typeinfo_Ptr (T : Tag) return System.Address is - use type System.Storage_Elements.Storage_Offset; TSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); begin @@ -564,7 +740,6 @@ package body Ada.Tags is --------- function TSD (T : Tag) return Type_Specific_Data_Ptr is - use type System.Storage_Elements.Storage_Offset; TSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); begin diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 0d517a0ac07..6532c1a7e32 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -40,17 +40,30 @@ with System.Storage_Elements; with Unchecked_Conversion; package Ada.Tags is +pragma Preelaborate_05 (Tags); +-- In accordance with Ada 2005 AI-362 pragma Elaborate_Body; + -- We need a dummy body to solve bootstrap path issues (why ???) type Tag is private; + No_Tag : constant Tag; + function Expanded_Name (T : Tag) return String; function External_Tag (T : Tag) return String; function Internal_Tag (External : String) return Tag; + function Descendant_Tag (External : String; Ancestor : Tag) return Tag; + + function Is_Descendant_At_Same_Level + (Descendant : Tag; + Ancestor : Tag) return Boolean; + + function Parent_Tag (T : Tag) return Tag; + Tag_Error : exception; private @@ -81,6 +94,9 @@ private type Dispatch_Table; type Tag is access all Dispatch_Table; + type Interface_Tag is access all Dispatch_Table; + + No_Tag : constant Tag := null; type Type_Specific_Data; type Type_Specific_Data_Ptr is access all Type_Specific_Data; @@ -91,6 +107,16 @@ private -- Given the tag of an object and the tag associated to a type, return -- true if Obj is in Typ'Class. + function IW_Membership + (This : System.Address; + Iface_Tag : Tag) return Boolean; + -- Ada 2005 (AI-251): Given the tag of an object and the tag associated + -- with an interface, return true if Obj is in Iface'Class. + + function Get_Access_Level (T : Tag) return Natural; + -- Given the tag associated with a type, returns the accessibility level + -- of the type. + function Get_External_Tag (T : Tag) return System.Address; -- Retrieve the address of a null terminated string containing -- the external name @@ -115,8 +141,8 @@ private -- Return the value previously set by Set_Remotely_Callable procedure Inherit_DT - (Old_T : Tag; - New_T : Tag; + (Old_T : Tag; + New_T : Tag; Entry_Count : Natural); -- Entry point used to initialize the DT of a type knowing the tag -- of the direct ancestor and the number of primitive ops that are @@ -137,17 +163,24 @@ private pragma Export (Ada, Parent_Size, "ada__tags__parent_size"); -- This procedure is used in s-finimp and is thus exported manually - function Parent_Tag (T : Tag) return Tag; - -- Obj is the address of a tagged object. Parent_Tag fetch the tag of the - -- immediate ancestor (parent) of the type associated with Obj. - - pragma Export (Ada, Parent_Tag, "ada__tags__parent_tag"); - -- This procedure is used in s-finimp and is thus exported manually + procedure Register_Interface_Tag + (T : Tag; + Interface_T : Tag); + -- Ada 2005 (AI-251): Used to initialize the table of interfaces + -- implemented by a type. Required to give support to IW_Membership. procedure Register_Tag (T : Tag); -- Insert the Tag and its associated external_tag in a table for the -- sake of Internal_Tag + procedure Set_Offset_To_Top + (T : Tag; + Value : System.Storage_Elements.Storage_Offset); + -- Ada 2005 (AI-251): Initialize the Offset_To_Top field in the prologue of + -- the dispatch table. In primary dispatch tables the value of this field + -- is always 0; in secondary dispatch tables this is the offset to the base + -- of the enclosing type. + procedure Set_Prim_Op_Address (T : Tag; Position : Positive; @@ -160,6 +193,10 @@ private -- Given a pointer T to a dispatch Table, stores the address of the record -- containing the Type Specific Data generated by GNAT + procedure Set_Access_Level (T : Tag; Value : Natural); + -- Sets the accessibility level of the tagged type associated with T + -- in its TSD. + procedure Set_Expanded_Name (T : Tag; Value : System.Address); -- Set the address of the string containing the expanded name -- in the Dispatch table @@ -185,19 +222,24 @@ private (2 * (Standard'Address_Size / System.Storage_Unit)); -- Size of the first part of the dispatch table + DT_Offset_To_Top_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (Standard'Address_Size / System.Storage_Unit); + -- Size of the Offset_To_Top field of the Dispatch Table + DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count := SSE.Storage_Count (Standard'Address_Size / System.Storage_Unit); - -- Size of the Typeinfo_Ptr field of the Dispatch Table. + -- Size of the Typeinfo_Ptr field of the Dispatch Table DT_Entry_Size : constant SSE.Storage_Count := SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); - -- Size of each primitive operation entry in the Dispatch Table. + -- Size of each primitive operation entry in the Dispatch Table TSD_Prologue_Size : constant SSE.Storage_Count := SSE.Storage_Count - (6 * Standard'Address_Size / System.Storage_Unit); + (8 * (Standard'Address_Size / System.Storage_Unit)); -- Size of the first part of the type specific data TSD_Entry_Size : constant SSE.Storage_Count := @@ -210,6 +252,8 @@ private -- of this type are declared with a dummy size of 1, the actual size -- depending on the number of primitive operations. + -- Unchecked Conversions for Tag and TSD + function To_Type_Specific_Data_Ptr is new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); @@ -220,22 +264,31 @@ private new Unchecked_Conversion (Tag, System.Address); type Addr_Ptr is access System.Address; + type Tag_Ptr is access Tag; function To_Addr_Ptr is new Unchecked_Conversion (System.Address, Addr_Ptr); + function To_Tag_Ptr is + new Unchecked_Conversion (System.Address, Tag_Ptr); + -- Primitive dispatching operations are always inlined, to facilitate -- use in a minimal/no run-time environment for high integrity use. pragma Inline_Always (CW_Membership); + pragma Inline_Always (IW_Membership); + pragma Inline_Always (Get_Access_Level); pragma Inline_Always (Get_Prim_Op_Address); pragma Inline_Always (Get_RC_Offset); pragma Inline_Always (Get_Remotely_Callable); pragma Inline_Always (Inherit_DT); pragma Inline_Always (Inherit_TSD); + pragma Inline_Always (Register_Interface_Tag); pragma Inline_Always (Register_Tag); + pragma Inline_Always (Set_Access_Level); pragma Inline_Always (Set_Expanded_Name); pragma Inline_Always (Set_External_Tag); + pragma Inline_Always (Set_Offset_To_Top); pragma Inline_Always (Set_Prim_Op_Address); pragma Inline_Always (Set_RC_Offset); pragma Inline_Always (Set_Remotely_Callable); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index a0cc0fbf031..56baf47c794 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -91,7 +91,7 @@ package body Debug is -- dW Disable warnings on calls for IN OUT parameters -- dX Enable Frontend ZCX even when it is not supported -- dY Enable configurable run-time mode - -- dZ + -- dZ Generate listing showing the contents of the dispatch tables -- d.a -- d.b diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index e832c5a5457..dc20de9660a 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -626,6 +626,16 @@ package body Exp_Attr is Rewrite (N, Conversion); Analyze_And_Resolve (N, Typ); end if; + + -- Ada 2005 (AI-251): If the designated type is an interface, + -- then rewrite the referenced object as a conversion to force + -- the displacement of the pointer to the secondary dispatch + -- table. + + elsif Is_Interface (Directly_Designated_Type (Btyp)) then + Conversion := Convert_To (Typ, New_Copy_Tree (Ref_Object)); + Rewrite (N, Conversion); + Analyze_And_Resolve (N, Typ); end if; end; @@ -996,7 +1006,7 @@ package body Exp_Attr is -- Callable -- -------------- - -- Transforms 'Callable attribute into a call to the Callable function. + -- Transforms 'Callable attribute into a call to the Callable function when Attribute_Callable => Callable : begin @@ -1106,6 +1116,7 @@ package body Exp_Attr is when Attribute_Constrained => Constrained : declare Formal_Ent : constant Entity_Id := Param_Entity (Pref); + Typ : constant Entity_Id := Etype (Pref); begin -- Reference to a parameter where the value is passed as an extra @@ -1189,15 +1200,20 @@ package body Exp_Attr is -- Prefix is not an entity name. These are also cases where -- we can always tell at compile time by looking at the form - -- and type of the prefix. + -- and type of the prefix. If an explicit dereference of an + -- object with constrained partial view, this is unconstrained + -- (Ada 2005 AI-363). else Rewrite (N, New_Reference_To ( Boolean_Literals ( not Is_Variable (Pref) - or else Nkind (Pref) = N_Explicit_Dereference - or else Is_Constrained (Etype (Pref))), + or else + (Nkind (Pref) = N_Explicit_Dereference + and then + not Has_Constrained_Partial_View (Base_Type (Typ))) + or else Is_Constrained (Typ)), Loc)); end if; @@ -1665,7 +1681,7 @@ package body Exp_Attr is -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined - -- in Ada.Task_Identification. + -- in Ada.Task_Identification when Attribute_Identity => Identity : declare Id_Kind : Entity_Id; @@ -1865,10 +1881,16 @@ package body Exp_Attr is -- initialize a dummy tag object: -- Dnn : Ada.Tags.Tag - -- := Internal_Tag (String'Input (Strm)); + -- := Descendant_Tag (String'Input (Strm), P_Type); -- This dummy object is used only to provide a controlling - -- argument for the eventual _Input call. + -- argument for the eventual _Input call. Descendant_Tag is + -- called rather than Internal_Tag to ensure that we have a + -- tag for a type that is descended from the prefix type and + -- declared at the same accessibility level (the exception + -- Tag_Error will be raised otherwise). The level check is + -- required for Ada 2005 because tagged types can be + -- extended in nested scopes (AI-344). Dnn := Make_Defining_Identifier (Loc, @@ -1882,7 +1904,7 @@ package body Exp_Attr is Expression => Make_Function_Call (Loc, Name => - New_Occurrence_Of (RTE (RE_Internal_Tag), Loc), + New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => @@ -1890,15 +1912,18 @@ package body Exp_Attr is Attribute_Name => Name_Input, Expressions => New_List ( Relocate_Node - (Duplicate_Subexpr (Strm))))))); + (Duplicate_Subexpr (Strm)))), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P_Type, Loc), + Attribute_Name => Name_Tag)))); Insert_Action (N, Decl); -- Now we need to get the entity for the call, and construct -- a function call node, where we preset a reference to Dnn - -- as the controlling argument (doing an unchecked - -- conversion to the class-wide tagged type to make it - -- look like a real tagged object). + -- as the controlling argument (doing an unchecked convert + -- to the class-wide tagged type to make it look like a real + -- tagged object). Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input); Cntrl := Unchecked_Convert_To (P_Type, @@ -1912,9 +1937,9 @@ package body Exp_Attr is elsif Is_Tagged_Type (U_Type) then Fname := Find_Prim_Op (U_Type, TSS_Stream_Input); - -- All other record type cases, including protected records. - -- The latter only arise for expander generated code for - -- handling shared passive partition access. + -- All other record type cases, including protected records. The + -- latter only arise for expander generated code for handling + -- shared passive partition access. else pragma Assert @@ -1967,9 +1992,9 @@ package body Exp_Attr is end if; end if; - -- If we fall through, Fname is the function to be called. The - -- result is obtained by calling the appropriate function, then - -- converting the result. The conversion does a subtype check. + -- If we fall through, Fname is the function to be called. The result + -- is obtained by calling the appropriate function, then converting + -- the result. The conversion does a subtype check. Call := Make_Function_Call (Loc, @@ -2081,10 +2106,10 @@ package body Exp_Attr is -- function Leading_Part in Fat_xxx (where xxx is the root type) -- Note: strictly, we should have special case code to deal with - -- absurdly large positive arguments (greater than Integer'Last), - -- which result in returning the first argument unchanged, but it - -- hardly seems worth the effort. We raise constraint error for - -- absurdly negative arguments which is fine. + -- absurdly large positive arguments (greater than Integer'Last), which + -- result in returning the first argument unchanged, but it hardly seems + -- worth the effort. We raise constraint error for absurdly negative + -- arguments which is fine. when Attribute_Leading_Part => Expand_Fpt_Attribute_RI (N); @@ -2276,9 +2301,9 @@ package body Exp_Attr is -- Mantissa -- -------------- - -- The only case that can get this far is the dynamic case of the - -- old Ada 83 Mantissa attribute for the fixed-point case. For this - -- case, we expand: + -- The only case that can get this far is the dynamic case of the old + -- Ada 83 Mantissa attribute for the fixed-point case. For this case, we + -- expand: -- typ'Mantissa @@ -2352,12 +2377,11 @@ package body Exp_Attr is -- a) The integer value is non-negative. In this case, it is -- returned as the result (since it is less than the modulus). - -- b) The integer value is negative. In this case, we know that - -- the result is modulus + value, where the value might be as - -- small as -modulus. The trouble is what type do we use to do - -- this subtraction. No type will do, since modulus can be as - -- big as 2**64, and no integer type accomodates this value. - -- Let's do a bit of algebra + -- b) The integer value is negative. In this case, we know that the + -- result is modulus + value, where the value might be as small as + -- -modulus. The trouble is what type do we use to do the subtract. + -- No type will do, since modulus can be as big as 2**64, and no + -- integer type accomodates this value. Let's do bit of algebra -- modulus + value -- = modulus - (-value) @@ -2452,10 +2476,10 @@ package body Exp_Attr is -- strmtyp'Output (Stream, strmwrite (acttyp (Item))); - -- where strmwrite is the given Write function that converts - -- an argument of type sourcetyp or a type acctyp, from which - -- it is derived to type strmtyp. The conversion to acttyp is - -- required for the derived case. + -- where strmwrite is the given Write function that converts an + -- argument of type sourcetyp or a type acctyp, from which it is + -- derived to type strmtyp. The conversion to acttyp is required + -- for the derived case. Prag := Get_Stream_Convert_Pragma (P_Type); @@ -2518,7 +2542,43 @@ package body Exp_Attr is begin -- The code is: - -- String'Output (Strm, External_Tag (Item'Tag)) + -- if Get_Access_Level (Item'Tag) + -- /= Get_Access_Level (P_Type'Tag) + -- then + -- raise Tag_Error; + -- end if; + -- String'Output (Strm, External_Tag (Item'Tag)); + + -- Ada 2005 (AI-344): Check that the accessibility level + -- of the type of the output object is not deeper than + -- that of the attribute's prefix type. + + if Ada_Version >= Ada_05 then + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To + (RTE (RE_Get_Access_Level), Loc), + Parameter_Associations => + New_List (Make_Attribute_Reference (Loc, + Prefix => + Relocate_Node ( + Duplicate_Subexpr (Item, + Name_Req => True)), + Attribute_Name => + Name_Tag))), + Right_Opnd => + Make_Integer_Literal + (Loc, Type_Access_Level (P_Type))), + Then_Statements => + New_List (Make_Raise_Statement (Loc, + New_Occurrence_Of ( + RTE (RE_Tag_Error), Loc))))); + end if; Insert_Action (N, Make_Attribute_Reference (Loc, @@ -2544,9 +2604,9 @@ package body Exp_Attr is elsif Is_Tagged_Type (U_Type) then Pname := Find_Prim_Op (U_Type, TSS_Stream_Output); - -- All other record type cases, including protected records. - -- The latter only arise for expander generated code for - -- handling shared passive partition access. +-- -- All other record type cases, including protected records. +-- -- The latter only arise for expander generated code for +-- -- handling shared passive partition access. else pragma Assert @@ -2857,10 +2917,10 @@ package body Exp_Attr is -- Item := sourcetyp (strmread (strmtyp'Input (Stream))); - -- where strmread is the given Read function that converts - -- an argument of type strmtyp to type sourcetyp or a type - -- from which it is derived. The conversion to sourcetyp - -- is required in the latter case. + -- where strmread is the given Read function that converts an + -- argument of type strmtyp to type sourcetyp or a type from which + -- it is derived. The conversion to sourcetyp is required in the + -- latter case. -- A special case arises if Item is a type conversion in which -- case, we have to expand to: @@ -2943,9 +3003,9 @@ package body Exp_Attr is elsif Is_Tagged_Type (U_Type) then Pname := Find_Prim_Op (U_Type, TSS_Stream_Read); - -- All other record type cases, including protected records. - -- The latter only arise for expander generated code for - -- handling shared passive partition access. + -- All other record type cases, including protected records. The + -- latter only arise for expander generated code for handling + -- shared passive partition access. else pragma Assert @@ -2997,36 +3057,35 @@ package body Exp_Attr is -- Round -- ----------- - -- The handling of the Round attribute is quite delicate. The - -- processing in Sem_Attr introduced a conversion to universal - -- real, reflecting the semantics of Round, but we do not want - -- anything to do with universal real at runtime, since this - -- corresponds to using floating-point arithmetic. - - -- What we have now is that the Etype of the Round attribute - -- correctly indicates the final result type. The operand of - -- the Round is the conversion to universal real, described - -- above, and the operand of this conversion is the actual - -- operand of Round, which may be the special case of a fixed - -- point multiplication or division (Etype = universal fixed) - - -- The exapander will expand first the operand of the conversion, - -- then the conversion, and finally the round attribute itself, - -- since we always work inside out. But we cannot simply process - -- naively in this order. In the semantic world where universal - -- fixed and real really exist and have infinite precision, there - -- is no problem, but in the implementation world, where universal - -- real is a floating-point type, we would get the wrong result. - - -- So the approach is as follows. First, when expanding a multiply - -- or divide whose type is universal fixed, we do nothing at all, - -- instead deferring the operation till later. + -- The handling of the Round attribute is quite delicate. The processing + -- in Sem_Attr introduced a conversion to universal real, reflecting the + -- semantics of Round, but we do not want anything to do with universal + -- real at runtime, since this corresponds to using floating-point + -- arithmetic. + + -- What we have now is that the Etype of the Round attribute correctly + -- indicates the final result type. The operand of the Round is the + -- conversion to universal real, described above, and the operand of + -- this conversion is the actual operand of Round, which may be the + -- special case of a fixed point multiplication or division (Etype = + -- universal fixed) + + -- The exapander will expand first the operand of the conversion, then + -- the conversion, and finally the round attribute itself, since we + -- always work inside out. But we cannot simply process naively in this + -- order. In the semantic world where universal fixed and real really + -- exist and have infinite precision, there is no problem, but in the + -- implementation world, where universal real is a floating-point type, + -- we would get the wrong result. + + -- So the approach is as follows. First, when expanding a multiply or + -- divide whose type is universal fixed, we do nothing at all, instead + -- deferring the operation till later. -- The actual processing is done in Expand_N_Type_Conversion which - -- handles the special case of Round by looking at its parent to - -- see if it is a Round attribute, and if it is, handling the - -- conversion (or its fixed multiply/divide child) in an appropriate - -- manner. + -- handles the special case of Round by looking at its parent to see if + -- it is a Round attribute, and if it is, handling the conversion (or + -- its fixed multiply/divide child) in an appropriate manner. -- This means that by the time we get to expanding the Round attribute -- itself, the Round is nothing more than a type conversion (and will @@ -3120,9 +3179,9 @@ package body Exp_Attr is Rewrite (Pref, New_Occurrence_Of (Etype (Pref), Loc)); end if; - -- For a scalar type for which no size was - -- explicitly given, VADS_Size means Object_Size. This is the - -- other respect in which VADS_Size differs from Size. + -- For a scalar type for which no size was explicitly given, + -- VADS_Size means Object_Size. This is the other respect in + -- which VADS_Size differs from Size. if Is_Scalar_Type (Etype (Pref)) and then No (Size_Clause (Etype (Pref))) @@ -3177,9 +3236,9 @@ package body Exp_Attr is elsif Nkind (Pref) = N_Indexed_Component then Siz := Component_Size (Etype (Prefix (Pref))); - -- For a record component, we can do Size in the front end - -- if there is a component clause, or if the record is packed - -- and the component's size is known at compile time. + -- For a record component, we can do Size in the front end if there + -- is a component clause, or if the record is packed and the + -- component's size is known at compile time. elsif Nkind (Pref) = N_Selected_Component then declare @@ -3522,7 +3581,7 @@ package body Exp_Attr is -- Terminated -- ---------------- - -- Transforms 'Terminated attribute into a call to Terminated function. + -- Transforms 'Terminated attribute into a call to Terminated function when Attribute_Terminated => Terminated : begin @@ -3881,9 +3940,9 @@ package body Exp_Attr is Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); -- For biased representations, we will be doing an unchecked - -- conversion without unbiasing the result. That means that - -- the range test has to take this into account, and the - -- proper form of the test is: + -- conversion without unbiasing the result. That means that the range + -- test has to take this into account, and the proper form of the + -- test is: -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length) @@ -3924,18 +3983,18 @@ package body Exp_Attr is -- Unsigned types. Note: it is safe to consider only whether the -- subtype is unsigned, since we will in that case be doing all - -- unsigned comparisons based on the subtype range. Since we use - -- the actual subtype object size, this is appropriate. + -- unsigned comparisons based on the subtype range. Since we use the + -- actual subtype object size, this is appropriate. -- For example, if we have -- subtype x is integer range 1 .. 200; -- for x'Object_Size use 8; - -- Now the base type is signed, but objects of this type are 8 - -- bits unsigned, and doing an unsigned test of the range 1 to - -- 200 is correct, even though a value greater than 127 looks - -- signed to a signed comparison. + -- Now the base type is signed, but objects of this type are bits + -- unsigned, and doing an unsigned test of the range 1 to 200 is + -- correct, even though a value greater than 127 looks signed to a + -- signed comparison. elsif Is_Unsigned_Type (Ptyp) then if Esize (Ptyp) <= 32 then @@ -4188,10 +4247,10 @@ package body Exp_Attr is -- strmtyp'Output (Stream, strmwrite (acttyp (Item))); - -- where strmwrite is the given Write function that converts - -- an argument of type sourcetyp or a type acctyp, from which - -- it is derived to type strmtyp. The conversion to acttyp is - -- required for the derived case. + -- where strmwrite is the given Write function that converts an + -- argument of type sourcetyp or a type acctyp, from which it is + -- derived to type strmtyp. The conversion to acttyp is required + -- for the derived case. Prag := Get_Stream_Convert_Pragma (P_Type); @@ -4272,22 +4331,22 @@ package body Exp_Attr is Rewrite_Stream_Proc_Call (Pname); end Write; - -- Component_Size is handled by Gigi, unless the component size is - -- known at compile time, which is always true in the packed array - -- case. It is important that the packed array case is handled in - -- the front end (see Eval_Attribute) since Gigi would otherwise - -- get confused by the equivalent packed array type. + -- Component_Size is handled by Gigi, unless the component size is known + -- at compile time, which is always true in the packed array case. It is + -- important that the packed array case is handled in the front end (see + -- Eval_Attribute) since Gigi would otherwise get confused by the + -- equivalent packed array type. when Attribute_Component_Size => null; -- The following attributes are handled by Gigi (except that static - -- cases have already been evaluated by the semantics, but in any - -- case Gigi should not count on that). + -- cases have already been evaluated by the semantics, but in any case + -- Gigi should not count on that). - -- In addition Gigi handles the non-floating-point cases of Pred - -- and Succ (including the fixed-point cases, which can just be - -- treated as integer increment/decrement operations) + -- In addition Gigi handles the non-floating-point cases of Pred and + -- Succ (including the fixed-point cases, which can just be treated as + -- integer increment/decrement operations) -- Gigi also handles the non-class-wide cases of Size @@ -4423,8 +4482,14 @@ package body Exp_Attr is function Find_Stream_Subprogram (Typ : Entity_Id; - Nam : TSS_Name_Type) return Entity_Id is + Nam : TSS_Name_Type) return Entity_Id + is + Ent : constant Entity_Id := TSS (Typ, Nam); begin + if Present (Ent) then + return Ent; + end if; + if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 9aa83aa51dd..fc8463d71b4 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -49,6 +49,7 @@ with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Attr; use Sem_Attr; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; @@ -124,8 +125,9 @@ package body Exp_Ch3 is procedure Check_Stream_Attributes (Typ : Entity_Id); -- Check that if a limited extension has a parent with user-defined - -- stream attributes, any limited component of the extension also has - -- the corresponding user-defined stream attributes. + -- stream attributes, and does not itself have user-definer + -- stream-attributes, then any limited component of the extension also + -- has the corresponding user-defined stream attributes. procedure Expand_Tagged_Root (T : Entity_Id); -- Add a field _Tag at the beginning of the record. This field carries @@ -1359,6 +1361,10 @@ package body Exp_Ch3 is Rec_Type : Entity_Id; Set_Tag : Entity_Id := Empty; + ADT : Elmt_Id; + Aux_N : Node_Id; + Aux_Comp : Node_Id; + function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; -- Build a assignment statement node which assigns to record -- component its default expression if defined. The left hand side @@ -1405,12 +1411,12 @@ package body Exp_Ch3 is function Component_Needs_Simple_Initialization (T : Entity_Id) return Boolean; - -- Determines if a component needs simple initialization, given its - -- type T. This is the same as Needs_Simple_Initialization except - -- for the following difference: the types Tag and Vtable_Ptr, which - -- are access types which would normally require simple initialization - -- to null, do not require initialization as components, since they - -- are explicitly initialized by other means. + -- Determines if a component needs simple initialization, given its type + -- T. This is the same as Needs_Simple_Initialization except for the + -- following difference: the types Tag, Interface_Tag, and Vtable_Ptr + -- which are access types which would normally require simple + -- initialization to null, do not require initialization as components, + -- since they are explicitly initialized by other means. procedure Constrain_Array (SI : Node_Id; @@ -1855,6 +1861,60 @@ package body Exp_Ch3 is if not Is_CPP_Class (Etype (Rec_Type)) then Prepend_To (Body_Stmts, Init_Tag); + -- Ada 2005 (AI-251): Initialization of all the tags + -- corresponding with abstract interfaces + + if Present (First_Tag_Component (Rec_Type)) then + + -- Skip the first _Tag, which is the main tag of the + -- tagged type. Following tags correspond with abstract + -- interfaces. + + Aux_Comp := + Next_Tag_Component (First_Tag_Component (Rec_Type)); + + ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type))); + while Present (ADT) loop + Aux_N := Node (ADT); + + -- Initialize the pointer to the secondary DT associated + -- with the interface + + Append_To (Body_Stmts, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => + New_Reference_To (Aux_Comp, Loc)), + Expression => + New_Reference_To (Aux_N, Loc))); + + -- Generate: + -- Set_Offset_To_Top (DT_Ptr, n); + + Append_To (Body_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), + Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (Aux_N, Loc)), + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, + Name_uInit), + Selector_Name => New_Reference_To + (Aux_Comp, Loc)), + Attribute_Name => Name_Position))))); + + Aux_Comp := Next_Tag_Component (Aux_Comp); + Next_Elmt (ADT); + end loop; + end if; + else declare Nod : Node_Id := First (Body_Stmts); @@ -2236,7 +2296,8 @@ package body Exp_Ch3 is return Needs_Simple_Initialization (T) and then not Is_RTE (T, RE_Tag) - and then not Is_RTE (T, RE_Vtable_Ptr); + and then not Is_RTE (T, RE_Vtable_Ptr) + and then not Is_RTE (T, RE_Interface_Tag); -- Ada 2005 (AI-251) end Component_Needs_Simple_Initialization; --------------------- @@ -2388,7 +2449,7 @@ package body Exp_Ch3 is -- 6. One or more components is a type that requires simple -- initialization (see Needs_Simple_Initialization), except - -- that types Tag and Vtable_Ptr are excluded, since fields + -- that types Tag and Interface_Tag are excluded, since fields -- of these types are initialized by other means. -- 7. The type is the record type built for a task type (since at @@ -3012,22 +3073,31 @@ package body Exp_Ch3 is procedure Check_Stream_Attributes (Typ : Entity_Id) is Comp : Entity_Id; - Par : constant Entity_Id := Root_Type (Base_Type (Typ)); - Par_Read : constant Boolean := Present (TSS (Par, TSS_Stream_Read)); - Par_Write : constant Boolean := Present (TSS (Par, TSS_Stream_Write)); + Par_Read : constant Boolean := + Stream_Attribute_Available (Typ, TSS_Stream_Read) + and then not Has_Specified_Stream_Read (Typ); + Par_Write : constant Boolean := + Stream_Attribute_Available (Typ, TSS_Stream_Write) + and then not Has_Specified_Stream_Write (Typ); procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type); -- Check that Comp has a user-specified Nam stream attribute + ---------------- + -- Check_Attr -- + ---------------- + procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is begin - if No (TSS (Base_Type (Etype (Comp)), TSS_Nam)) then + if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then Error_Msg_Name_1 := Nam; Error_Msg_N ("|component& in limited extension must have% attribute", Comp); end if; end Check_Attr; + -- Start of processing for Check_Stream_Attributes + begin if Par_Read or else Par_Write then Comp := First_Component (Typ); @@ -3422,12 +3492,36 @@ package body Exp_Ch3 is -- simple initialization expression in place. This special -- initialization is required even though No_Init_Flag is present. - elsif Needs_Simple_Initialization (Typ) then + -- An internally generated temporary needs no initialization because + -- it will be assigned subsequently. In particular, there is no + -- point in applying Initialize_Scalars to such a temporary. + + elsif Needs_Simple_Initialization (Typ) + and then not Is_Internal (Def_Id) + then Set_No_Initialization (N, False); Set_Expression (N, Get_Simple_Init_Val (Typ, Loc, Esize (Def_Id))); Analyze_And_Resolve (Expression (N), Typ); end if; + -- Generate attribute for Persistent_BSS if needed + + declare + Prag : Node_Id; + begin + if Persistent_BSS_Mode + and then Comes_From_Source (N) + and then Is_Potentially_Persistent_Type (Typ) + and then Is_Library_Level_Entity (Def_Id) + then + Prag := + Make_Linker_Section_Pragma + (Def_Id, Sloc (N), ".persistent.bss"); + Insert_After (N, Prag); + Analyze (Prag); + end if; + end; + -- Explicit initialization present else @@ -4340,6 +4434,7 @@ package body Exp_Ch3 is -- created in the C++ side and we just use it. if Is_Tagged_Type (Def_Id) then + if Is_CPP_Class (Def_Id) then Set_All_DT_Position (Def_Id); Set_Default_Constructor (Def_Id); @@ -4385,6 +4480,36 @@ package body Exp_Ch3 is Expand_Tagged_Root (Def_Id); end if; + -- Build the secondary tables + + if not Java_VM + and then Present (Abstract_Interfaces (Def_Id)) + and then not Is_Empty_Elmt_List (Abstract_Interfaces (Def_Id)) + then + declare + E : Entity_Id; + Result : List_Id; + ADT : Elist_Id := Access_Disp_Table (Def_Id); + + begin + E := First_Entity (Def_Id); + while Present (E) loop + if Is_Tag (E) and then Chars (E) /= Name_uTag then + Make_Abstract_Interface_DT + (AI_Tag => E, + Acc_Disp_Tables => ADT, + Result => Result); + + Append_Freeze_Actions (Def_Id, Result); + end if; + + Next_Entity (E); + end loop; + + Set_Access_Disp_Table (Def_Id, ADT); + end; + end if; + -- Unfreeze momentarily the type to add the predefined primitives -- operations. The reason we unfreeze is so that these predefined -- operations will indeed end up as primitive operations (which @@ -4556,7 +4681,7 @@ package body Exp_Ch3 is -- Full type declarations are expanded at the point at which the type is -- frozen. The formal N is the Freeze_Node for the type. Any statements or -- declarations generated by the freezing (e.g. the procedure generated - -- for initialization) are chained in the Acions field list of the freeze + -- for initialization) are chained in the Actions field list of the freeze -- node using Append_Freeze_Actions. function Freeze_Type (N : Node_Id) return Boolean is diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e817156267c..ea615edead1 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -33,7 +33,6 @@ with Exp_Aggr; use Exp_Aggr; with Exp_Ch3; use Exp_Ch3; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; -with Exp_Disp; use Exp_Disp; with Exp_Fixd; use Exp_Fixd; with Exp_Pakd; use Exp_Pakd; with Exp_Tss; use Exp_Tss; @@ -445,6 +444,41 @@ package body Exp_Ch4 is Expression => Node)); end if; + -- Ada 2005 (AI-344): + -- For an allocator with a class-wide designated type, generate an + -- accessibility check to verify that the level of the type of the + -- created object is not deeper than the level of the access type. + -- If the type of the qualified expression is class-wide, then + -- always generate the check. Otherwise, only generate the check + -- if the level of the qualified expression type is statically deeper + -- than the access type. Although the static accessibility will + -- generally have been performed as a legality check, it won't have + -- been done in cases where the allocator appears in a generic body, + -- so the run-time check is needed in general. (Not yet doing the + -- optimization to suppress the check for the static level case.???) + + if Ada_Version >= Ada_05 + and then Is_Class_Wide_Type (Designated_Type (PtrT)) + then + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Get_Access_Level), Loc), + Parameter_Associations => + New_List (Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Temp, Loc), + Attribute_Name => + Name_Tag))), + Right_Opnd => + Make_Integer_Literal (Loc, Type_Access_Level (PtrT))), + Reason => PE_Accessibility_Check_Failed)); + end if; + -- Suppress the tag assignment when Java_VM because JVM tags -- are represented implicitly in objects. @@ -8015,22 +8049,43 @@ package body Exp_Ch4 is New_Reference_To (First_Tag_Component (Left_Type), Loc)); if Is_Class_Wide_Type (Right_Type) then - return - Make_DT_Access_Action (Left_Type, - Action => CW_Membership, - Args => New_List ( - Obj_Tag, - New_Reference_To - (Node (First_Elmt - (Access_Disp_Table (Root_Type (Right_Type)))), - Loc))); + + -- Ada 2005 (AI-251): Class-wide applied to interfaces + + if Is_Interface (Etype (Class_Wide_Type (Right_Type))) then + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Obj_Tag, + Attribute_Name => Name_Address), + New_Reference_To ( + Node (First_Elmt + (Access_Disp_Table (Root_Type (Right_Type)))), + Loc))); + + -- Ada 95: Normal case + + else + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc), + Parameter_Associations => New_List ( + Obj_Tag, + New_Reference_To ( + Node (First_Elmt + (Access_Disp_Table (Root_Type (Right_Type)))), + Loc))); + end if; + else return Make_Op_Eq (Loc, - Left_Opnd => Obj_Tag, - Right_Opnd => - New_Reference_To - (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc)); + Left_Opnd => Obj_Tag, + Right_Opnd => + New_Reference_To + (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc)); end if; end Tagged_Membership; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index d78da78dbcb..6224d17f54a 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2829,6 +2829,33 @@ package body Exp_Ch5 is Rewrite (Exp, Result_Exp); Analyze_And_Resolve (Exp, Return_Type); end if; + + -- Ada 2005 (AI-344): If the result type is class-wide, then insert + -- a check that the level of the return expression's underlying type + -- is not deeper than the level of the master enclosing the function. + + elsif Ada_Version >= Ada_05 + and then Is_Class_Wide_Type (Return_Type) + then + Insert_Action (Exp, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To + (RTE (RE_Get_Access_Level), Loc), + Parameter_Associations => + New_List (Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr (Exp), + Attribute_Name => + Name_Tag))), + Right_Opnd => + Make_Integer_Literal (Loc, + Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), + Reason => PE_Accessibility_Check_Failed)); end if; -- Deal with returning variable length objects and controlled types diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index c4fc454ab1c..e23e12881c1 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -60,6 +60,7 @@ with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; +with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -515,6 +516,14 @@ package body Exp_Ch6 is -- representation as True. We assume that .FALSE. = False = 0. -- What about functions that return a logical type ??? + function Is_Legal_Copy return Boolean; + -- Check that an actual can be copied before generating the temporary + -- to be used in the call. If the actual is of a by_reference type then + -- the program is illegal (this can only happen in the presence of + -- rep. clauses that force an incorrect alignment). If the formal is + -- a by_reference parameter imposed by a DEC pragma, emit a warning to + -- the effect that this might lead to unaligned arguments. + function Make_Var (Actual : Node_Id) return Entity_Id; -- Returns an entity that refers to the given actual parameter, -- Actual (not including any type conversion). If Actual is an @@ -541,11 +550,15 @@ package body Exp_Ch6 is Crep : Boolean; begin + if not Is_Legal_Copy then + return; + end if; + Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); -- Use formal type for temp, unless formal type is an unconstrained -- array, in which case we don't have to worry about bounds checks, - -- and we use the actual type, since that has appropriate bonds. + -- and we use the actual type, since that has appropriate bounds. if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then Indic := New_Occurrence_Of (Etype (Actual), Loc); @@ -715,6 +728,7 @@ package body Exp_Ch6 is procedure Add_Simple_Call_By_Copy_Code is Temp : Entity_Id; + Decl : Node_Id; Incod : Node_Id; Outcod : Node_Id; Lhs : Node_Id; @@ -723,9 +737,13 @@ package body Exp_Ch6 is F_Typ : constant Entity_Id := Etype (Formal); begin + if not Is_Legal_Copy then + return; + end if; + -- Use formal type for temp, unless formal type is an unconstrained -- array, in which case we don't have to worry about bounds checks, - -- and we use the actual type, since that has appropriate bonds. + -- and we use the actual type, since that has appropriate bounds. if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then Indic := New_Occurrence_Of (Etype (Actual), Loc); @@ -742,17 +760,53 @@ package body Exp_Ch6 is Outcod := New_Copy_Tree (Incod); -- Generate declaration of temporary variable, initializing it - -- with the input parameter unless we have an OUT variable. + -- with the input parameter unless we have an OUT variable or + -- this is an initialization call. if Ekind (Formal) = E_Out_Parameter then Incod := Empty; + + elsif Inside_Init_Proc then + if Nkind (Actual) /= N_Selected_Component + or else + not Has_Discriminant_Dependent_Constraint + (Entity (Selector_Name (Actual))) + then + Incod := Empty; + + else + -- We need the component in order to generate the proper + -- actual subtype, that depends on enclosing discriminants. + -- What is the comment for, given code below is null ??? + + null; + end if; end if; - Insert_Action (N, + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => Indic, - Expression => Incod)); + Expression => Incod); + + if Inside_Init_Proc + and then No (Incod) + then + -- If the call is to initialize a component of a composite type, + -- and the component does not depend on discriminants, use the + -- actual type of the component. This is required in case the + -- component is constrained, because in general the formal of the + -- initialization procedure will be unconstrained. Note that if + -- the component being initialized is constrained by an enclosing + -- discriminant, the presence of the initialization in the + -- declaration will generate an expression for the actual subtype. + + Set_No_Initialization (Decl); + Set_Object_Definition (Decl, + New_Occurrence_Of (Etype (Actual), Loc)); + end if; + + Insert_Action (N, Decl); -- The actual is simply a reference to the temporary @@ -811,6 +865,38 @@ package body Exp_Ch6 is end if; end Check_Fortran_Logical; + ------------------- + -- Is_Legal_Copy -- + ------------------- + + function Is_Legal_Copy return Boolean is + begin + -- An attempt to copy a value of such a type can only occur if + -- representation clauses give the actual a misaligned address. + + if Is_By_Reference_Type (Etype (Formal)) then + Error_Msg_N + ("misaligned actual cannot be passed by reference", Actual); + return False; + + -- For users of Starlet, we assume that the specification of by- + -- reference mechanism is mandatory. This may lead to unligned + -- objects but at least for DEC legacy code it is known to work. + -- The warning will alert users of this code that a problem may + -- be lurking. + + elsif Mechanism (Formal) = By_Reference + and then Is_Valued_Procedure (Scope (Formal)) + then + Error_Msg_N + ("by_reference actual may be misaligned?", Actual); + return False; + + else + return True; + end if; + end Is_Legal_Copy; + -------------- -- Make_Var -- -------------- @@ -1127,6 +1213,8 @@ package body Exp_Ch6 is Extra_Actuals : List_Id := No_List; Cond : Node_Id; + CW_Interface_Formals_Present : Boolean := False; + procedure Add_Actual_Parameter (Insert_Param : Node_Id); -- Adds one entry to the end of the actual parameter list. Used for -- default parameters and for extra actuals (for Extra_Formals). @@ -1391,16 +1479,28 @@ package body Exp_Ch6 is Prev := Actual; Prev_Orig := Original_Node (Prev); - -- Create possible extra actual for constrained case. Usually, - -- the extra actual is of the form actual'constrained, but since - -- this attribute is only available for unconstrained records, - -- TRUE is expanded if the type of the formal happens to be - -- constrained (for instance when this procedure is inherited - -- from an unconstrained record to a constrained one) or if the - -- actual has no discriminant (its type is constrained). An - -- exception to this is the case of a private type without - -- discriminants. In this case we pass FALSE because the - -- object has underlying discriminants with defaults. + -- Ada 2005 (AI-251): Check if any formal is a class-wide interface + -- to expand it in a further round + + CW_Interface_Formals_Present := + CW_Interface_Formals_Present + or else + (Ekind (Etype (Formal)) = E_Class_Wide_Type + and then Is_Interface (Etype (Etype (Formal)))) + or else + (Ekind (Etype (Formal)) = E_Anonymous_Access_Type + and then Is_Interface (Directly_Designated_Type + (Etype (Etype (Formal))))); + + -- Create possible extra actual for constrained case. Usually, the + -- extra actual is of the form actual'constrained, but since this + -- attribute is only available for unconstrained records, TRUE is + -- expanded if the type of the formal happens to be constrained (for + -- instance when this procedure is inherited from an unconstrained + -- record to a constrained one) or if the actual has no discriminant + -- (its type is constrained). An exception to this is the case of a + -- private type without discriminants. In this case we pass FALSE + -- because the object has underlying discriminants with defaults. if Present (Extra_Constrained (Formal)) then if Ekind (Etype (Prev)) in Private_Kind @@ -1756,6 +1856,16 @@ package body Exp_Ch6 is end; end if; + -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand + -- it to point to the correct secondary virtual table + + if (Nkind (N) = N_Function_Call + or else Nkind (N) = N_Procedure_Call_Statement) + and then CW_Interface_Formals_Present + then + Expand_Interface_Actuals (N); + end if; + -- Deals with Dispatch_Call if we still have a call, before expanding -- extra actuals since this will be done on the re-analysis of the -- dispatching call. Note that we do not try to shorten the actual @@ -2858,6 +2968,7 @@ package body Exp_Ch6 is Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + Set_Is_Internal (Temp); Decl := Make_Object_Declaration (Loc, @@ -3685,6 +3796,8 @@ package body Exp_Ch6 is -- protected subprogram an associated formals. For a normal protected -- operation, this is done when expanding the protected type declaration. + -- If the declaration is for a null procedure, emit null body + procedure Expand_N_Subprogram_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Subp : constant Entity_Id := Defining_Entity (N); @@ -3732,6 +3845,24 @@ package body Exp_Ch6 is Set_Protected_Body_Subprogram (Subp, Prot_Id); Pop_Scope; end if; + + elsif Nkind (Specification (N)) = N_Procedure_Specification + and then Null_Present (Specification (N)) + then + declare + Bod : constant Node_Id := + Make_Subprogram_Body (Loc, + Specification => + New_Copy_Tree (Specification (N)), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Make_Null_Statement (Loc)))); + begin + Set_Body_To_Inline (N, New_Copy_Tree (Bod)); + Insert_After (N, Bod); + Analyze (Bod); + end; end if; end Expand_N_Subprogram_Declaration; @@ -3907,7 +4038,11 @@ package body Exp_Ch6 is ----------------------- procedure Freeze_Subprogram (N : Node_Id) is - E : constant Entity_Id := Entity (N); + Loc : constant Source_Ptr := Sloc (N); + E : constant Entity_Id := Entity (N); + Thunk_Id : Entity_Id; + Iface_Tag : Entity_Id; + New_Thunk : Node_Id; begin -- When a primitive is frozen, enter its name in the corresponding @@ -3923,7 +4058,41 @@ package body Exp_Ch6 is and then not Java_VM then Check_Overriding_Operation (E); - Insert_After (N, Fill_DT_Entry (Sloc (N), E)); + + -- Common case: Primitive subprogram + + if not Present (Abstract_Interface_Alias (E)) then + Insert_After (N, Fill_DT_Entry (Sloc (N), E)); + + -- Ada 2005 (AI-251): Primitive subprogram that covers an interface + + else + Iface_Tag := + Find_Interface_Tag + (T => Scope (DTC_Entity (Alias (E))), -- Formal Type + Iface => Scope (DTC_Entity (Abstract_Interface_Alias (E)))); + + -- Generate the thunk only if the associated tag is an interface + -- tag. The case in which the associated tag is the primary tag + -- occurs when a tagged type is a direct derivation of an + -- interface. For example: + + -- type I is interface; + -- ... + -- type T is new I with ... + + if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then + Thunk_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('T')); + + New_Thunk := Expand_Interface_Thunk (N, Thunk_Id, Iface_Tag); + + Insert_After (New_Thunk, + Fill_DT_Entry (Sloc (N), + Prim => E, + Thunk_Id => Thunk_Id)); + end if; + end if; end if; -- Mark functions that return by reference. Note that it cannot be diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 8bb0cac38db..ea82dd339f4 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -26,41 +26,49 @@ with Atree; use Atree; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Ch7; use Exp_Ch7; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; -with Fname; use Fname; with Itypes; use Itypes; -with Lib; use Lib; with Nlists; use Nlists; with Nmake; use Nmake; +with Namet; use Namet; with Opt; use Opt; +with Output; use Output; with Rtsfind; use Rtsfind; +with Sem; use Sem; with Sem_Disp; use Sem_Disp; with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; +with Ttypes; use Ttypes; with Uintp; use Uintp; package body Exp_Disp is Ada_Actions : constant array (DT_Access_Action) of RE_Id := (CW_Membership => RE_CW_Membership, + IW_Membership => RE_IW_Membership, DT_Entry_Size => RE_DT_Entry_Size, DT_Prologue_Size => RE_DT_Prologue_Size, + Get_Access_Level => RE_Get_Access_Level, Get_External_Tag => RE_Get_External_Tag, Get_Prim_Op_Address => RE_Get_Prim_Op_Address, Get_RC_Offset => RE_Get_RC_Offset, Get_Remotely_Callable => RE_Get_Remotely_Callable, Inherit_DT => RE_Inherit_DT, Inherit_TSD => RE_Inherit_TSD, + Register_Interface_Tag => RE_Register_Interface_Tag, Register_Tag => RE_Register_Tag, + Set_Access_Level => RE_Set_Access_Level, Set_Expanded_Name => RE_Set_Expanded_Name, Set_External_Tag => RE_Set_External_Tag, Set_Prim_Op_Address => RE_Set_Prim_Op_Address, @@ -70,37 +78,21 @@ package body Exp_Disp is TSD_Entry_Size => RE_TSD_Entry_Size, TSD_Prologue_Size => RE_TSD_Prologue_Size); - CPP_Actions : constant array (DT_Access_Action) of RE_Id := - (CW_Membership => RE_CPP_CW_Membership, - DT_Entry_Size => RE_CPP_DT_Entry_Size, - DT_Prologue_Size => RE_CPP_DT_Prologue_Size, - Get_External_Tag => RE_CPP_Get_External_Tag, - Get_Prim_Op_Address => RE_CPP_Get_Prim_Op_Address, - Get_RC_Offset => RE_CPP_Get_RC_Offset, - Get_Remotely_Callable => RE_CPP_Get_Remotely_Callable, - Inherit_DT => RE_CPP_Inherit_DT, - Inherit_TSD => RE_CPP_Inherit_TSD, - Register_Tag => RE_CPP_Register_Tag, - Set_Expanded_Name => RE_CPP_Set_Expanded_Name, - Set_External_Tag => RE_CPP_Set_External_Tag, - Set_Prim_Op_Address => RE_CPP_Set_Prim_Op_Address, - Set_RC_Offset => RE_CPP_Set_RC_Offset, - Set_Remotely_Callable => RE_CPP_Set_Remotely_Callable, - Set_TSD => RE_CPP_Set_TSD, - TSD_Entry_Size => RE_CPP_TSD_Entry_Size, - TSD_Prologue_Size => RE_CPP_TSD_Prologue_Size); - Action_Is_Proc : constant array (DT_Access_Action) of Boolean := (CW_Membership => False, + IW_Membership => False, DT_Entry_Size => False, DT_Prologue_Size => False, + Get_Access_Level => False, Get_External_Tag => False, Get_Prim_Op_Address => False, Get_Remotely_Callable => False, Get_RC_Offset => False, Inherit_DT => True, Inherit_TSD => True, + Register_Interface_Tag => True, Register_Tag => True, + Set_Access_Level => True, Set_Expanded_Name => True, Set_External_Tag => True, Set_Prim_Op_Address => True, @@ -112,15 +104,19 @@ package body Exp_Disp is Action_Nb_Arg : constant array (DT_Access_Action) of Int := (CW_Membership => 2, + IW_Membership => 2, DT_Entry_Size => 0, DT_Prologue_Size => 0, + Get_Access_Level => 1, Get_External_Tag => 1, Get_Prim_Op_Address => 2, Get_RC_Offset => 1, Get_Remotely_Callable => 1, Inherit_DT => 3, Inherit_TSD => 2, + Register_Interface_Tag => 2, Register_Tag => 1, + Set_Access_Level => 2, Set_Expanded_Name => 2, Set_External_Tag => 2, Set_Prim_Op_Address => 3, @@ -130,10 +126,194 @@ package body Exp_Disp is TSD_Entry_Size => 0, TSD_Prologue_Size => 0); + function Build_Anonymous_Access_Type + (Directly_Designated_Type : Entity_Id; + Related_Nod : Node_Id) return Entity_Id; + -- Returns a decorated entity corresponding with an anonymous access type. + -- Used to generate unchecked type conversion of an address. + + procedure Collect_All_Interfaces (T : Entity_Id); + -- Ada 2005 (AI-251): Collect the whole list of interfaces that are + -- directly or indirectly implemented by T. Used to compute the size + -- of the table of interfaces. + + function Default_Prim_Op_Position (Subp : Entity_Id) return Uint; + -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table + -- of the default primitive operations. + function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; -- Check if the type has a private view or if the public view appears -- in the visible part of a package spec. + ---------------------------------- + -- Build_Anonymous_Access_Type -- + ---------------------------------- + + function Build_Anonymous_Access_Type + (Directly_Designated_Type : Entity_Id; + Related_Nod : Node_Id) return Entity_Id + is + New_E : Entity_Id; + + begin + New_E := Create_Itype (Ekind => E_Anonymous_Access_Type, + Related_Nod => Related_Nod, + Scope_Id => Current_Scope); + + Set_Etype (New_E, New_E); + Init_Size_Align (New_E); + Init_Size (New_E, System_Address_Size); + Set_Directly_Designated_Type (New_E, Directly_Designated_Type); + Set_Is_First_Subtype (New_E); + + return New_E; + end Build_Anonymous_Access_Type; + + ---------------------------- + -- Collect_All_Interfaces -- + ---------------------------- + + procedure Collect_All_Interfaces (T : Entity_Id) is + + procedure Add_Interface (Iface : Entity_Id); + -- Add the interface it if is not already in the list + + procedure Collect (Typ : Entity_Id); + -- Subsidiary subprogram used to traverse the whole list + -- of directly and indirectly implemented interfaces + + ------------------- + -- Add_Interface -- + ------------------- + + procedure Add_Interface (Iface : Entity_Id) is + Elmt : Elmt_Id := First_Elmt (Abstract_Interfaces (T)); + + begin + while Present (Elmt) and then Node (Elmt) /= Iface loop + Next_Elmt (Elmt); + end loop; + + if not Present (Elmt) then + Append_Elmt (Iface, Abstract_Interfaces (T)); + end if; + end Add_Interface; + + ------------- + -- Collect -- + ------------- + + procedure Collect (Typ : Entity_Id) is + Nod : constant Node_Id := Type_Definition (Parent (Typ)); + Id : Node_Id; + Iface : Entity_Id; + Ancestor : Entity_Id; + + begin + pragma Assert (False + or else Nkind (Nod) = N_Derived_Type_Definition + or else Nkind (Nod) = N_Record_Definition); + + if Nkind (Nod) = N_Record_Definition then + return; + end if; + + -- Include the ancestor if we are generating the whole list + -- of interfaces. This is used to know the size of the table + -- that stores the tag of all the ancestor interfaces. + + Ancestor := Etype (Typ); + + if Is_Interface (Ancestor) then + Add_Interface (Ancestor); + end if; + + if Ancestor /= Typ + and then Ekind (Ancestor) /= E_Record_Type_With_Private + then + Collect (Ancestor); + end if; + + -- Traverse the graph of ancestor interfaces + + if Is_Non_Empty_List (Interface_List (Nod)) then + Id := First (Interface_List (Nod)); + + while Present (Id) loop + + Iface := Etype (Id); + + if Is_Interface (Iface) then + Add_Interface (Iface); + Collect (Iface); + end if; + + Next (Id); + end loop; + end if; + end Collect; + + -- Start of processing for Collect_All_Interfaces + + begin + Collect (T); + end Collect_All_Interfaces; + + ------------------------------ + -- Default_Prim_Op_Position -- + ------------------------------ + + function Default_Prim_Op_Position (Subp : Entity_Id) return Uint is + TSS_Name : TSS_Name_Type; + E : Entity_Id := Subp; + + begin + -- Handle overriden subprograms + + while Present (Alias (E)) loop + E := Alias (E); + end loop; + + Get_Name_String (Chars (E)); + TSS_Name := + TSS_Name_Type + (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); + + if Chars (E) = Name_uSize then + return Uint_1; + + elsif Chars (E) = Name_uAlignment then + return Uint_2; + + elsif TSS_Name = TSS_Stream_Read then + return Uint_3; + + elsif TSS_Name = TSS_Stream_Write then + return Uint_4; + + elsif TSS_Name = TSS_Stream_Input then + return Uint_5; + + elsif TSS_Name = TSS_Stream_Output then + return Uint_6; + + elsif Chars (E) = Name_Op_Eq then + return Uint_7; + + elsif Chars (E) = Name_uAssign then + return Uint_8; + + elsif TSS_Name = TSS_Deep_Adjust then + return Uint_9; + + elsif TSS_Name = TSS_Deep_Finalize then + return Uint_10; + + else + raise Program_Error; + end if; + end Default_Prim_Op_Position; + ----------------------------- -- Expand_Dispatching_Call -- ----------------------------- @@ -247,7 +427,9 @@ package body Exp_Disp is -- This capability of dispatching directly by tag is also needed by the -- implementation of AI-260 (for the generic dispatching constructors). - if Etype (Ctrl_Arg) = RTE (RE_Tag) then + if Etype (Ctrl_Arg) = RTE (RE_Tag) + or else Etype (Ctrl_Arg) = RTE (RE_Interface_Tag) + then CW_Typ := Class_Wide_Type (Controlling_Type (Subp)); elsif Is_Access_Type (Etype (Ctrl_Arg)) then @@ -270,47 +452,7 @@ package body Exp_Disp is New_Params := New_List; Param := First_Actual (Call_Node); while Present (Param) loop - - -- We assume that dispatching through the main dispatch table - -- (referenced by Tag_Component) doesn't require a displacement - -- so the expansion below is only done when dispatching on - -- another vtable pointer, in which case the first argument - -- is expanded into : - - -- typ!(Displaced_This (Address!(Param))) - - if Param = Ctrl_Arg - and then DTC_Entity (Subp) /= First_Tag_Component (Typ) - then - Append_To (New_Params, - - Unchecked_Convert_To (Etype (Param), - Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_Displaced_This), Loc), - Parameter_Associations => New_List ( - - -- Current_This - - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Reference_To (RTE (RE_Address), Loc), - Expression => Relocate_Node (Param)), - - -- Vptr - - Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr (Ctrl_Arg), - Selector_Name => - New_Reference_To (DTC_Entity (Subp), Loc)), - - -- Position - - Make_Integer_Literal (Loc, DT_Position (Subp)))))); - - else - Append_To (New_Params, Relocate_Node (Param)); - end if; - + Append_To (New_Params, Relocate_Node (Param)); Next_Actual (Param); end loop; @@ -493,7 +635,9 @@ package body Exp_Disp is -- use it directly. Otherwise, the tag must be extracted from -- the controlling object. - if Etype (Ctrl_Arg) = RTE (RE_Tag) then + if Etype (Ctrl_Arg) = RTE (RE_Tag) + or else Etype (Ctrl_Arg) = RTE (RE_Interface_Tag) + then Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); else @@ -521,37 +665,64 @@ package body Exp_Disp is Make_Integer_Literal (Loc, DT_Position (Subp))))); if Nkind (Call_Node) = N_Function_Call then - New_Call := - Make_Function_Call (Loc, - Name => New_Call_Name, - Parameter_Associations => New_Params); - -- If this is a dispatching "=", we must first compare the tags so - -- we generate: x.tag = y.tag and then x = y + -- Ada 2005 (AI-251): A dispatching "=" with an abstract interface + -- just requires the comparison of the tags. - if Subp = Eq_Prim_Op then + if Ekind (Etype (Ctrl_Arg)) = E_Class_Wide_Type + and then Is_Interface (Etype (Ctrl_Arg)) + and then Subp = Eq_Prim_Op + then Param := First_Actual (Call_Node); - New_Call := - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => New_Value (Param), - Selector_Name => - New_Reference_To - (First_Tag_Component (Typ), Loc)), - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (Typ, - New_Value (Next_Actual (Param))), - Selector_Name => - New_Reference_To - (First_Tag_Component (Typ), Loc))), + New_Call := + Make_Op_Eq (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Value (Param), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), Loc)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, + New_Value (Next_Actual (Param))), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), Loc))); - Right_Opnd => New_Call); + else + New_Call := + Make_Function_Call (Loc, + Name => New_Call_Name, + Parameter_Associations => New_Params); + + -- If this is a dispatching "=", we must first compare the tags so + -- we generate: x.tag = y.tag and then x = y + + if Subp = Eq_Prim_Op then + Param := First_Actual (Call_Node); + New_Call := + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Value (Param), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), + Loc)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Typ, + New_Value (Next_Actual (Param))), + Selector_Name => + New_Reference_To (First_Tag_Component (Typ), + Loc))), + Right_Opnd => New_Call); + end if; end if; else @@ -565,30 +736,478 @@ package body Exp_Disp is Analyze_And_Resolve (Call_Node, Call_Typ); end Expand_Dispatching_Call; + --------------------------------- + -- Expand_Interface_Conversion -- + --------------------------------- + + procedure Expand_Interface_Conversion (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Operand : constant Node_Id := Expression (N); + Operand_Typ : Entity_Id := Etype (Operand); + Target_Type : Entity_Id := Etype (N); + Iface_Tag : Entity_Id; + + begin + pragma Assert (Nkind (Operand) /= N_Attribute_Reference); + + -- Ada 2005 (AI-345): Set Operand_Typ and Handle task interfaces + + if Ekind (Operand_Typ) = E_Task_Type + or else Ekind (Operand_Typ) = E_Protected_Type + then + Operand_Typ := Corresponding_Record_Type (Operand_Typ); + end if; + + if Is_Access_Type (Target_Type) then + Target_Type := Etype (Directly_Designated_Type (Target_Type)); + + elsif Is_Class_Wide_Type (Target_Type) then + Target_Type := Etype (Target_Type); + end if; + + pragma Assert (not Is_Class_Wide_Type (Target_Type) + and then Is_Interface (Target_Type)); + + Iface_Tag := Find_Interface_Tag (Operand_Typ, Target_Type); + + pragma Assert (Iface_Tag /= Empty); + + Rewrite (N, + Unchecked_Convert_To (Etype (N), + Make_Attribute_Reference (Loc, + Prefix => Make_Selected_Component (Loc, + Prefix => Relocate_Node (Expression (N)), + Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)), + Attribute_Name => Name_Address))); + + Analyze (N); + end Expand_Interface_Conversion; + + ------------------------------ + -- Expand_Interface_Actuals -- + ------------------------------ + + procedure Expand_Interface_Actuals (Call_Node : Node_Id) is + Loc : constant Source_Ptr := Sloc (Call_Node); + Actual : Node_Id; + Actual_Typ : Entity_Id; + Conversion : Node_Id; + Formal : Entity_Id; + Formal_Typ : Entity_Id; + Subp : Entity_Id; + Nam : Name_Id; + + begin + -- This subprogram is called directly from the semantics, so we need a + -- check to see whether expansion is active before proceeding. + + if not Expander_Active then + return; + end if; + + -- Call using access to subprogram with explicit dereference + + if Nkind (Name (Call_Node)) = N_Explicit_Dereference then + Subp := Etype (Name (Call_Node)); + + -- Normal case + + else + Subp := Entity (Name (Call_Node)); + end if; + + Formal := First_Formal (Subp); + Actual := First_Actual (Call_Node); + + while Present (Formal) loop + + pragma Assert (Ekind (Etype (Etype (Formal))) + /= E_Record_Type_With_Private); + + -- Ada 2005 (AI-251): Conversion to interface to force "this" + -- displacement + + Formal_Typ := Etype (Etype (Formal)); + Actual_Typ := Etype (Actual); + + if Is_Interface (Formal_Typ) then + + Conversion := Convert_To (Formal_Typ, New_Copy_Tree (Actual)); + Rewrite (Actual, Conversion); + Analyze_And_Resolve (Actual, Formal_Typ); + + Rewrite (Actual, + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To + (Build_Anonymous_Access_Type (Formal_Typ, Call_Node), + Relocate_Node (Expression (Actual))))); + + Analyze_And_Resolve (Actual, Formal_Typ); + + -- Anonymous access type + + elsif Is_Access_Type (Formal_Typ) + and then Is_Interface (Etype + (Directly_Designated_Type + (Formal_Typ))) + and then Interface_Present_In_Ancestor + (Typ => Etype (Directly_Designated_Type + (Actual_Typ)), + Iface => Etype (Directly_Designated_Type + (Formal_Typ))) + then + + if Nkind (Actual) = N_Attribute_Reference + and then + (Attribute_Name (Actual) = Name_Access + or else Attribute_Name (Actual) = Name_Unchecked_Access) + then + Nam := Attribute_Name (Actual); + + Conversion := + Convert_To + (Etype (Directly_Designated_Type (Formal_Typ)), + Prefix (Actual)); + + Rewrite (Actual, Conversion); + + Analyze_And_Resolve (Actual, + Etype (Directly_Designated_Type (Formal_Typ))); + + Rewrite (Actual, + Unchecked_Convert_To (Formal_Typ, + Make_Attribute_Reference (Loc, + Prefix => + Relocate_Node (Prefix (Expression (Actual))), + Attribute_Name => Nam))); + + Analyze_And_Resolve (Actual, Formal_Typ); + + else + Conversion := + Convert_To (Formal_Typ, New_Copy_Tree (Actual)); + Rewrite (Actual, Conversion); + Analyze_And_Resolve (Actual, Formal_Typ); + end if; + end if; + + Next_Actual (Actual); + Next_Formal (Formal); + end loop; + end Expand_Interface_Actuals; + + ---------------------------- + -- Expand_Interface_Thunk -- + ---------------------------- + + function Expand_Interface_Thunk + (N : Node_Id; + Thunk_Id : Entity_Id; + Iface_Tag : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Actuals : constant List_Id := New_List; + Decl : constant List_Id := New_List; + Formals : constant List_Id := New_List; + Thunk_Tag : constant Node_Id := Iface_Tag; + Thunk_Alias : constant Entity_Id := Alias (Entity (N)); + Target : Entity_Id; + New_Code : Node_Id; + Formal : Node_Id; + New_Formal : Node_Id; + Decl_1 : Node_Id; + Decl_2 : Node_Id; + Subtyp_Mark : Node_Id; + + begin + + -- Traverse the list of alias to find the final target + + Target := Thunk_Alias; + + while Present (Alias (Target)) loop + Target := Alias (Target); + end loop; + + -- Duplicate the formals + + Formal := First_Formal (Thunk_Alias); + + while Present (Formal) loop + New_Formal := Copy_Separate_Tree (Parent (Formal)); + + -- Handle the case in which the subprogram covering + -- the interface has been inherited: + + -- Example: + -- type I is interface; + -- procedure P (X : in I) is abstract; + + -- type T is tagged null record; + -- procedure P (X : T); + + -- type DT is new T and I with ... + + if Is_Controlling_Formal (Formal) then + Set_Parameter_Type (New_Formal, + New_Reference_To (Etype (First_Entity (Entity (N))), Loc)); + + -- Why is this line silently commented out ??? + + -- New_Reference_To (Etype (Formal), Loc)); + end if; + + Append_To (Formals, New_Formal); + Next_Formal (Formal); + end loop; + + if Ekind (First_Formal (Thunk_Alias)) = E_In_Parameter + and then Ekind (Etype (First_Formal (Thunk_Alias))) + = E_Anonymous_Access_Type + then + + -- Generate: + + -- type T is access all <<type of the first formal>> + -- S1 := Storage_Offset!(First_formal) + -- - Storage_Offset!(First_Formal.Thunk_Tag'Position) + + -- ... and the first actual of the call is generated as T!(S1) + + Decl_2 := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('T')), + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Null_Exclusion_Present => False, + Constant_Present => False, + Subtype_Indication => + New_Reference_To + (Directly_Designated_Type + (Etype (First_Formal (Thunk_Alias))), Loc) + )); + + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Expression => + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + New_Reference_To + (Defining_Identifier (First (Formals)), Loc)), + Right_Opnd => + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To + (Defining_Identifier (First (Formals)), Loc), + Selector_Name => + New_Occurrence_Of (Thunk_Tag, Loc)), + Attribute_Name => Name_Position)))); + + Append_To (Decl, Decl_2); + Append_To (Decl, Decl_1); + + -- Reference the new first actual + + Append_To (Actuals, + Unchecked_Convert_To + (Defining_Identifier (Decl_2), + New_Reference_To (Defining_Identifier (Decl_1), Loc))); + + -- Side note: The reverse order of declarations is just to ensure + -- that the call to RE_Print is correct. + + else + -- Generate: + -- + -- S1 := Storage_Offset!(First_formal'Address) + -- - Storage_Offset!(First_Formal.Thunk_Tag'Position) + -- S2 := Tag_Ptr!(S3) + + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Expression => + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To + (Defining_Identifier (First (Formals)), Loc), + Attribute_Name => Name_Address)), + Right_Opnd => + Unchecked_Convert_To + (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + New_Reference_To + (Defining_Identifier (First (Formals)), Loc), + Selector_Name => + New_Occurrence_Of (Thunk_Tag, Loc)), + Attribute_Name => Name_Position)))); + + Decl_2 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Constant_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc), + Expression => + Unchecked_Convert_To + (RTE (RE_Addr_Ptr), + New_Reference_To (Defining_Identifier (Decl_1), Loc))); + + Append_To (Decl, Decl_1); + Append_To (Decl, Decl_2); + + -- Reference the new first actual + + Append_To (Actuals, + Unchecked_Convert_To + (Etype (First_Entity (Target)), + Make_Explicit_Dereference (Loc, + New_Reference_To (Defining_Identifier (Decl_2), Loc)))); + + end if; + + Formal := Next (First (Formals)); + while Present (Formal) loop + Append_To (Actuals, + New_Reference_To (Defining_Identifier (Formal), Loc)); + Next (Formal); + end loop; + + if Ekind (Thunk_Alias) = E_Procedure then + New_Code := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Thunk_Id, + Parameter_Specifications => Formals), + Declarations => Decl, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Target, Loc), + Parameter_Associations => Actuals)))); + + else pragma Assert (Ekind (Thunk_Alias) = E_Function); + + if not Present (Alias (Thunk_Alias)) then + Subtyp_Mark := Subtype_Mark (Parent (Thunk_Alias)); + else + -- The last element in the alias list has the correct subtype_mark + -- of the function result + + declare + E : Entity_Id := Alias (Thunk_Alias); + begin + while Present (Alias (E)) loop + E := Alias (E); + end loop; + Subtyp_Mark := Subtype_Mark (Parent (E)); + end; + end if; + + New_Code := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Thunk_Id, + Parameter_Specifications => Formals, + Subtype_Mark => New_Copy (Subtyp_Mark)), + Declarations => Decl, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Return_Statement (Loc, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Target, Loc), + Parameter_Associations => Actuals))))); + end if; + + Analyze (New_Code); + Insert_After (N, New_Code); + return New_Code; + end Expand_Interface_Thunk; + ------------- -- Fill_DT -- ------------- function Fill_DT_Entry - (Loc : Source_Ptr; - Prim : Entity_Id) - return Node_Id + (Loc : Source_Ptr; + Prim : Entity_Id; + Thunk_Id : Entity_Id := Empty) return Node_Id is - Typ : constant Entity_Id := Scope (DTC_Entity (Prim)); - DT_Ptr : constant Entity_Id := Node (First_Elmt - (Access_Disp_Table (Typ))); + Typ : constant Entity_Id := Scope (DTC_Entity (Prim)); + DT_Ptr : Entity_Id := Node (First_Elmt (Access_Disp_Table (Typ))); + Target : Entity_Id; + Tag : Entity_Id := First_Tag_Component (Typ); + Prim_Op : Entity_Id := Prim; begin + -- Ada 2005 (AI-251): If we have a thunk available then generate code + -- that saves its address in the secondary dispatch table of its + -- abstract interface; otherwise save the address of the primitive + -- subprogram in the main virtual table. + + if Thunk_Id /= Empty then + Target := Thunk_Id; + else + Target := Prim; + end if; + + -- Ada 2005 (AI-251): If the subprogram is the alias of an abstract + -- interface subprogram then find the correct dispatch table pointer + + if Present (Abstract_Interface_Alias (Prim)) then + Prim_Op := Abstract_Interface_Alias (Prim); + + DT_Ptr := Find_Interface_ADT + (T => Typ, + Iface => Scope (DTC_Entity (Prim_Op))); + + Tag := First_Tag_Component (Scope (DTC_Entity (Prim_Op))); + end if; + + pragma Assert (DT_Position (Prim_Op) <= DT_Entry_Count (Tag)); + pragma Assert (DT_Position (Prim_Op) > Uint_0); + return Make_DT_Access_Action (Typ, Action => Set_Prim_Op_Address, Args => New_List ( - New_Reference_To (DT_Ptr, Loc), -- DTptr + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To (DT_Ptr, Loc)), -- DTptr - Make_Integer_Literal (Loc, DT_Position (Prim)), -- Position + Make_Integer_Literal (Loc, DT_Position (Prim_Op)), -- Position Make_Attribute_Reference (Loc, -- Value - Prefix => New_Reference_To (Prim, Loc), + Prefix => New_Reference_To (Target, Loc), Attribute_Name => Name_Address))); end Fill_DT_Entry; @@ -614,11 +1233,9 @@ package body Exp_Disp is ------------- function Make_DT (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - - ADT_List : constant Elist_Id := New_Elmt_List; - Result : constant List_Id := New_List; - Elab_Code : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Result : constant List_Id := New_List; + Elab_Code : constant List_Id := New_List; Tname : constant Name_Id := Chars (Typ); Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); @@ -633,11 +1250,16 @@ package body Exp_Disp is Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname); No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg); + Generalized_Tag : constant Entity_Id := RTE (RE_Tag); I_Depth : Int; - Generalized_Tag : Entity_Id; Size_Expr_Node : Node_Id; Old_Tag1 : Node_Id; Old_Tag2 : Node_Id; + Num_Ifaces : Int; + Nb_Prim : Int; + TSD_Num_Entries : Int; + Typ_Copy : constant Entity_Id := New_Copy (Typ); + AI : Elmt_Id; begin if not RTE_Available (RE_Tag) then @@ -645,11 +1267,52 @@ package body Exp_Disp is return New_List; end if; - if Is_CPP_Class (Root_Type (Typ)) then - Generalized_Tag := RTE (RE_Vtable_Ptr); - else - Generalized_Tag := RTE (RE_Tag); - end if; + -- Collect the full list of directly and indirectly implemented + -- interfaces + + Set_Parent (Typ_Copy, Parent (Typ)); + Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List); + Collect_All_Interfaces (Typ_Copy); + + -- Calculate the number of entries required in the table of interfaces + + Num_Ifaces := 0; + AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); + + while Present (AI) loop + Num_Ifaces := Num_Ifaces + 1; + Next_Elmt (AI); + end loop; + + -- Count ancestors to compute the inheritance depth. For private + -- extensions, always go to the full view in order to compute the real + -- inheritance depth. + + declare + Parent_Type : Entity_Id := Typ; + P : Entity_Id; + + begin + I_Depth := 0; + + loop + P := Etype (Parent_Type); + + if Is_Private_Type (P) then + P := Full_View (Base_Type (P)); + end if; + + exit when P = Parent_Type; + + I_Depth := I_Depth + 1; + Parent_Type := P; + end loop; + end; + + TSD_Num_Entries := I_Depth + Num_Ifaces + 1; + Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); + + -- ---------------------------------------------------------------- -- Dispatch table and related entities are allocated statically @@ -681,8 +1344,7 @@ package body Exp_Disp is Left_Opnd => Make_DT_Access_Action (Typ, DT_Entry_Size, No_List), Right_Opnd => - Make_Integer_Literal (Loc, - DT_Entry_Count (First_Tag_Component (Typ))))); + Make_Integer_Literal (Loc, Nb_Prim))); Append_To (Result, Make_Object_Declaration (Loc, @@ -708,14 +1370,11 @@ package body Exp_Disp is -- Generate code to create the pointer to the dispatch table - -- DT_Ptr : Tag := Tag!(DT'Address); Ada case - -- or - -- DT_Ptr : Vtable_Ptr := Vtable_Ptr!(DT'Address); CPP case + -- DT_Ptr : Tag := Tag!(DT'Address); - -- According to the C++ ABI, the base of the vtable is located - -- after the following prologue: Offset_To_Top, Typeinfo_Ptr. - -- Hence, move the pointer to the base of the vtable down, after - -- this prologue. + -- According to the C++ ABI, the base of the vtable is located after a + -- prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move + -- down the pointer to the real base of the vtable Append_To (Result, Make_Object_Declaration (Loc, @@ -746,37 +1405,18 @@ package body Exp_Disp is -- Set Access_Disp_Table field to be the dispatch table pointer - Append_Elmt (DT_Ptr, ADT_List); - Set_Access_Disp_Table (Typ, ADT_List); - - -- Count ancestors to compute the inheritance depth. For private - -- extensions, always go to the full view in order to compute the real - -- inheritance depth. - - declare - Parent_Type : Entity_Id := Typ; - P : Entity_Id; - - begin - I_Depth := 0; - - loop - P := Etype (Parent_Type); - - if Is_Private_Type (P) then - P := Full_View (Base_Type (P)); - end if; - - exit when P = Parent_Type; + if not Present (Access_Disp_Table (Typ)) then + Set_Access_Disp_Table (Typ, New_Elmt_List); + end if; - I_Depth := I_Depth + 1; - Parent_Type := P; - end loop; - end; + Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ)); -- Generate code to create the storage for the type specific data object - - -- TSD: Storage_Array (1..TSD_Prologue_Size+(1+Idepth)*TSD_Entry_Size); + -- with enough space to store the tags of the ancestors plus the tags + -- of all the implemented interfaces (as described in a-tags.adb) + -- + -- TSD: Storage_Array + -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size); -- for TSD'Alignment use Address'Alignment Size_Expr_Node := @@ -788,10 +1428,7 @@ package body Exp_Disp is Left_Opnd => Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List), Right_Opnd => - Make_Op_Add (Loc, - Left_Opnd => Make_Integer_Literal (Loc, 1), - Right_Opnd => - Make_Integer_Literal (Loc, I_Depth)))); + Make_Integer_Literal (Loc, TSD_Num_Entries))); Append_To (Result, Make_Object_Declaration (Loc, @@ -827,6 +1464,50 @@ package body Exp_Disp is Prefix => New_Reference_To (TSD, Loc), Attribute_Name => Name_Address)))); + -- Generate: Exname : constant String := full_qualified_name (typ); + -- The type itself may be an anonymous parent type, so use the first + -- subtype to have a user-recognizable name. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Exname, + Constant_Present => True, + Object_Definition => New_Reference_To (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Full_Qualified_Name (First_Subtype (Typ))))); + + -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Expanded_Name, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Exname, Loc), + Attribute_Name => Name_Address)))); + + -- Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>); + + Append_To (Elab_Code, + Make_DT_Access_Action (Typ, + Action => Set_Access_Level, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ))))); + + -- Generate: + -- Set_Offset_To_Top (DT_Ptr, 0); + + Append_To (Elab_Code, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc), + Parameter_Associations => New_List ( + New_Reference_To (DT_Ptr, Loc), + Make_Integer_Literal (Loc, Uint_0)))); + if Typ = Etype (Typ) or else Is_CPP_Class (Etype (Typ)) then @@ -866,31 +1547,6 @@ package body Exp_Disp is Node1 => Old_Tag2, Node2 => New_Reference_To (DT_Ptr, Loc)))); - -- Generate: Exname : constant String := full_qualified_name (typ); - -- The type itself may be an anonymous parent type, so use the first - -- subtype to have a user-recognizable name. - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => Exname, - Constant_Present => True, - Object_Definition => New_Reference_To (Standard_String, Loc), - Expression => - Make_String_Literal (Loc, - Full_Qualified_Name (First_Subtype (Typ))))); - - -- Generate: Set_Expanded_Name (DT_Ptr, exname'Address); - - Append_To (Elab_Code, - Make_DT_Access_Action (Typ, - Action => Set_Expanded_Name, - Args => New_List ( - Node1 => New_Reference_To (DT_Ptr, Loc), - Node2 => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Exname, Loc), - Attribute_Name => Name_Address)))); - -- for types with no controlled components -- Generate: Set_RC_Offset (DT_Ptr, 0); -- for simple types with controlled components @@ -1022,9 +1678,179 @@ package body Exp_Disp is Condition => New_Reference_To (No_Reg, Loc), Then_Statements => Elab_Code)); + -- Ada 2005 (AI-251): Register the tag of the interfaces into + -- the table of implemented interfaces + + if Present (Abstract_Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) + then + AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); + while Present (AI) loop + + -- Generate: + -- Register_Interface (DT_Ptr, Interface'Tag); + + Append_To (Result, + Make_DT_Access_Action (Typ, + Action => Register_Interface_Tag, + Args => New_List ( + Node1 => New_Reference_To (DT_Ptr, Loc), + Node2 => New_Reference_To + (Node + (First_Elmt + (Access_Disp_Table (Node (AI)))), + Loc)))); + + Next_Elmt (AI); + end loop; + end if; + return Result; end Make_DT; + -------------------------------- + -- Make_Abstract_Interface_DT -- + -------------------------------- + + procedure Make_Abstract_Interface_DT + (AI_Tag : Entity_Id; + Acc_Disp_Tables : in out Elist_Id; + Result : out List_Id) + is + Loc : constant Source_Ptr := Sloc (AI_Tag); + Tname : constant Name_Id := Chars (AI_Tag); + Name_DT : constant Name_Id := New_External_Name (Tname, 'T'); + Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P'); + + Iface_DT : constant Node_Id := + Make_Defining_Identifier (Loc, Name_DT); + Iface_DT_Ptr : constant Node_Id := + Make_Defining_Identifier (Loc, Name_DT_Ptr); + + Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag); + Size_Expr_Node : Node_Id; + Nb_Prim : Int; + + begin + Result := New_List; + + -- Dispatch table and related entities are allocated statically + + Set_Ekind (Iface_DT, E_Variable); + Set_Is_Statically_Allocated (Iface_DT); + + Set_Ekind (Iface_DT_Ptr, E_Variable); + Set_Is_Statically_Allocated (Iface_DT_Ptr); + + -- Generate code to create the storage for the Dispatch_Table object + + -- DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size); + -- for DT'Alignment use Address'Alignment + + Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag)); + + Size_Expr_Node := + Make_Op_Add (Loc, + Left_Opnd => Make_DT_Access_Action (Etype (AI_Tag), + DT_Prologue_Size, + No_List), + Right_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => + Make_DT_Access_Action (Etype (AI_Tag), + DT_Entry_Size, + No_List), + Right_Opnd => + Make_Integer_Literal (Loc, Nb_Prim))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Iface_DT, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Size_Expr_Node)))), + + -- Initialize the signature of the interface tag. It is currently + -- a sequence of four bytes located in the unused Typeinfo_Ptr + -- field of the prologue). Its current value is the following + -- sequence: (80, Nb_Prim, 0, 80) + + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + + -- -80, 0, 0, -80 + + Choices => New_List ( + Make_Integer_Literal (Loc, Uint_5), + Make_Integer_Literal (Loc, Uint_8)), + Expression => + Make_Integer_Literal (Loc, Uint_80)), + + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Uint_2)), + Expression => + Make_Integer_Literal (Loc, Nb_Prim)), + + Make_Component_Association (Loc, + Choices => New_List ( + Make_Others_Choice (Loc)), + Expression => Make_Integer_Literal (Loc, Uint_0)))))); + + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Iface_DT, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); + + -- Generate code to create the pointer to the dispatch table + + -- Iface_DT_Ptr : Tag := Tag!(DT'Address); + + -- According to the C++ ABI, the base of the vtable is located + -- after the following prologue: Offset_To_Top, and Typeinfo_Ptr. + -- Hence, move the pointer down to the real base of the vtable. + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Iface_DT_Ptr, + Constant_Present => True, + Object_Definition => New_Reference_To (Generalized_Tag, Loc), + Expression => + Unchecked_Convert_To (Generalized_Tag, + Make_Op_Add (Loc, + Left_Opnd => + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Iface_DT, Loc), + Attribute_Name => Name_Address)), + Right_Opnd => + Make_DT_Access_Action (Etype (AI_Tag), + DT_Prologue_Size, No_List))))); + + -- Note: Offset_To_Top will be initialized by the init subprogram + + -- Set Access_Disp_Table field to be the dispatch table pointer + + if not (Present (Acc_Disp_Tables)) then + Acc_Disp_Tables := New_Elmt_List; + end if; + + Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables); + + end Make_Abstract_Interface_DT; + --------------------------- -- Make_DT_Access_Action -- --------------------------- @@ -1032,19 +1858,12 @@ package body Exp_Disp is function Make_DT_Access_Action (Typ : Entity_Id; Action : DT_Access_Action; - Args : List_Id) - return Node_Id + Args : List_Id) return Node_Id is - Action_Name : Entity_Id; + Action_Name : constant Entity_Id := RTE (Ada_Actions (Action)); Loc : Source_Ptr; begin - if Is_CPP_Class (Root_Type (Typ)) then - Action_Name := RTE (CPP_Actions (Action)); - else - Action_Name := RTE (Ada_Actions (Action)); - end if; - if No (Args) then -- This is a constant @@ -1106,15 +1925,61 @@ package body Exp_Disp is Root_Typ : constant Entity_Id := Root_Type (Typ); First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ)); The_Tag : constant Entity_Id := First_Tag_Component (Typ); + Adjusted : Boolean := False; Finalized : Boolean := False; - Parent_EC : Int; + + Count_Prim : Int; + DT_Length : Int; Nb_Prim : Int; + Parent_EC : Int; Prim : Entity_Id; Prim_Elmt : Elmt_Id; - begin + procedure Validate_Position (Prim : Entity_Id); + -- Check that the position assignated to Prim is completely safe + -- (it has not been assigned to a previously defined primitive + -- operation of Typ) + + ----------------------- + -- Validate_Position -- + ----------------------- + procedure Validate_Position (Prim : Entity_Id) is + Prim_Elmt : Elmt_Id; + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) + and then Node (Prim_Elmt) /= Prim + loop + -- Primitive operations covering abstract interfaces are + -- allocated later + + if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then + null; + + -- Predefined dispatching operations are completely safe. + -- They are allocated at fixed positions. + + elsif Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then + null; + + -- Aliased subprograms are safe + + elsif Present (Alias (Prim)) then + null; + + elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then + raise Program_Error; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end Validate_Position; + + -- Start of processing for Set_All_DT_Position + + begin -- Get Entry_Count of the parent if Parent_Typ /= Typ @@ -1246,26 +2111,218 @@ package body Exp_Disp is -- in a-tags.ad?) else - Nb_Prim := 1; - Prim_Elmt := First_Prim; + -- First stage: Set the DTC entity of all the primitive operations + -- This is required to properly read the DT_Position attribute in + -- the latter stages. + + Prim_Elmt := First_Prim; + Count_Prim := 0; while Present (Prim_Elmt) loop - Nb_Prim := Nb_Prim + 1; - Prim := Node (Prim_Elmt); - Set_DTC_Entity (Prim, The_Tag); + Count_Prim := Count_Prim + 1; + Prim := Node (Prim_Elmt); + + -- Ada 2005 (AI-251) + + if Present (Abstract_Interface_Alias (Prim)) then + Set_DTC_Entity (Prim, + Find_Interface_Tag + (T => Typ, + Iface => Scope (DTC_Entity + (Abstract_Interface_Alias (Prim))))); - if Chars (Prim) = Name_uSize then - Set_DT_Position (Prim, Uint_1); - Nb_Prim := Nb_Prim - 1; else - Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); + Set_DTC_Entity (Prim, The_Tag); end if; - if Chars (Prim) = Name_Finalize - and then - (Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) - or else not Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Prim)))) + -- Clear any previous value of the DT_Position attribute. In this + -- way we ensure that the final position of all the primitives is + -- stablished by the following stages of this algorithm. + + Set_DT_Position (Prim, No_Uint); + + Next_Elmt (Prim_Elmt); + end loop; + + declare + Fixed_Prim : array (Int range 0 .. 10 + Parent_EC + Count_Prim) + of Boolean := (others => False); + E : Entity_Id; + + begin + -- Second stage: Register fixed entries + + Nb_Prim := 10; + Prim_Elmt := First_Prim; + + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- Predefined primitives have a fixed position in all the + -- dispatch tables + + if Is_Predefined_Dispatching_Operation (Prim) then + Set_DT_Position (Prim, Default_Prim_Op_Position (Prim)); + Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True; + + -- Overriding interface primitives of an ancestor + + elsif DT_Position (Prim) = No_Uint + and then Present (Abstract_Interface_Alias (Prim)) + and then Present (DTC_Entity + (Abstract_Interface_Alias (Prim))) + and then DT_Position (Abstract_Interface_Alias (Prim)) + /= No_Uint + and then Is_Inherited_Operation (Prim) + and then Is_Ancestor (Scope + (DTC_Entity + (Abstract_Interface_Alias (Prim))), + Typ) + then + Set_DT_Position (Prim, + DT_Position (Abstract_Interface_Alias (Prim))); + Set_DT_Position (Alias (Prim), + DT_Position (Abstract_Interface_Alias (Prim))); + Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True; + + -- Overriding primitives must use the same entry as the + -- overriden primitive + + elsif DT_Position (Prim) = No_Uint + and then Present (Alias (Prim)) + and then Present (DTC_Entity (Alias (Prim))) + and then DT_Position (Alias (Prim)) /= No_Uint + and then Is_Inherited_Operation (Prim) + and then Is_Ancestor (Scope (DTC_Entity (Alias (Prim))), Typ) + then + E := Alias (Prim); + while not (Present (DTC_Entity (E)) + or else DT_Position (E) = No_Uint) + and then Present (Alias (E)) + loop + E := Alias (E); + end loop; + + pragma Assert (Present (DTC_Entity (E)) + and then + DT_Position (E) /= No_Uint); + + Set_DT_Position (Prim, DT_Position (E)); + Fixed_Prim (UI_To_Int (DT_Position (E))) := True; + + -- If this is not the last element in the chain continue + -- traversing the chain. This is required to properly + -- handling renamed primitives + + if Present (Alias (E)) then + while Present (Alias (E)) loop + E := Alias (E); + Fixed_Prim (UI_To_Int (DT_Position (E))) := True; + end loop; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + -- Third stage: Fix the position of all the new primitives + -- Entries associated with primitives covering interfaces + -- are handled in a latter round. + + Prim_Elmt := First_Prim; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- Skip primitives previously set entries + + if DT_Position (Prim) /= No_Uint then + null; + + elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then + null; + + -- Primitives covering interface primitives are + -- handled later + + elsif Present (Abstract_Interface_Alias (Prim)) then + null; + + else + -- Take the next available position in the DT + + loop + Nb_Prim := Nb_Prim + 1; + exit when not Fixed_Prim (Nb_Prim); + end loop; + + Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); + Fixed_Prim (Nb_Prim) := True; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + + -- Fourth stage: Complete the decoration of primitives covering + -- interfaces (that is, propagate the DT_Position attribute + -- from the aliased primitive) + + Prim_Elmt := First_Prim; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if DT_Position (Prim) = No_Uint + and then Present (Abstract_Interface_Alias (Prim)) then + -- Check if this entry will be placed in the primary DT + + if Etype (DTC_Entity (Abstract_Interface_Alias (Prim))) + = RTE (RE_Tag) + then + pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); + Set_DT_Position (Prim, DT_Position (Alias (Prim))); + + -- Otherwise it will be placed in the secondary DT + + else + pragma Assert + (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint); + + Set_DT_Position (Prim, + DT_Position (Abstract_Interface_Alias (Prim))); + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + -- Final stage: Ensure that the table is correct plus some further + -- verifications concerning the primitives. + + Prim_Elmt := First_Prim; + DT_Length := 0; + + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- At this point all the primitives MUST have a position + -- in the dispatch table + + if DT_Position (Prim) = No_Uint then + raise Program_Error; + end if; + + -- Calculate real size of the dispatch table + + if UI_To_Int (DT_Position (Prim)) > DT_Length then + DT_Length := UI_To_Int (DT_Position (Prim)); + end if; + + -- Ensure that the asignated position in the dispatch + -- table is correct + + Validate_Position (Prim); + + if Chars (Prim) = Name_Finalize then Finalized := True; end if; @@ -1275,17 +2332,19 @@ package body Exp_Disp is -- An abstract operation cannot be declared in the private part -- for a visible abstract type, because it could never be over- - -- ridden. For explicit declarations this is checked at the point - -- of declaration, but for inherited operations it must be done - -- when building the dispatch table. Input is excluded because + -- ridden. For explicit declarations this is checked at the + -- point of declaration, but for inherited operations it must + -- be done when building the dispatch table. Input is excluded + -- because if Is_Abstract (Typ) and then Is_Abstract (Prim) and then Present (Alias (Prim)) and then Is_Derived_Type (Typ) and then In_Private_Part (Current_Scope) - and then List_Containing (Parent (Prim)) - = Private_Declarations + and then + List_Containing (Parent (Prim)) = + Private_Declarations (Specification (Unit_Declaration_Node (Current_Scope))) and then Original_View_In_Visible_Part (Typ) then @@ -1301,12 +2360,15 @@ package body Exp_Disp is Error_Msg_NE ("abstract inherited private operation&" & " must be overridden ('R'M 3.9.3(10))", - Parent (Typ), Prim); + Parent (Typ), Prim); end if; end if; + Next_Elmt (Prim_Elmt); end loop; + -- Additional check + if Is_Controlled (Typ) then if not Finalized then Error_Msg_N @@ -1318,15 +2380,28 @@ package body Exp_Disp is end if; end if; - Set_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim)); + -- Set the final size of the Dispatch Table + + Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length)); -- The derived type must have at least as many components as its -- parent (for root types, the Etype points back to itself -- and the test should not fail) - pragma Assert ( - DT_Entry_Count (The_Tag) >= - DT_Entry_Count (First_Tag_Component (Parent_Typ))); + -- This test fails compiling the partial view of a tagged type + -- derived from an interface which defines the overriding subprogram + -- in the private part. This needs further investigation??? + + if not Has_Private_Declaration (Typ) then + pragma Assert ( + DT_Entry_Count (The_Tag) >= + DT_Entry_Count (First_Tag_Component (Parent_Typ))); + null; + end if; + end if; + + if Debug_Flag_ZZ then + Write_DT (Typ); end if; end Set_All_DT_Position; @@ -1382,4 +2457,104 @@ package body Exp_Disp is end if; end Set_Default_Constructor; + -------------- + -- Write_DT -- + -------------- + + procedure Write_DT (Typ : Entity_Id) is + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + -- Protect this procedure against wrong usage. Required because it will + -- be used directly from GDB + + if not (Typ in First_Node_Id .. Last_Node_Id) + or else not Is_Tagged_Type (Typ) + then + Write_Str ("wrong usage: write_dt must be used with tagged types"); + Write_Eol; + return; + end if; + + Write_Int (Int (Typ)); + Write_Str (": "); + Write_Name (Chars (Typ)); + + if Is_Interface (Typ) then + Write_Str (" is interface"); + end if; + + Write_Eol; + + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + Write_Str (" - "); + + -- Indicate if this primitive will be allocated in the primary + -- dispatch table or in a secondary dispatch table associated + -- with an abstract interface type + + if Present (DTC_Entity (Prim)) then + if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then + Write_Str ("[P] "); + else + Write_Str ("[s] "); + end if; + end if; + + -- Output the node of this primitive operation and its name + + Write_Int (Int (Prim)); + Write_Str (": "); + Write_Name (Chars (Prim)); + + -- Indicate if this primitive has an aliased primitive + + if Present (Alias (Prim)) then + Write_Str (" (alias = "); + Write_Int (Int (Alias (Prim))); + + -- If the DTC_Entity attribute is already set we can also output + -- the name of the interface covered by this primitive (if any) + + if Present (DTC_Entity (Alias (Prim))) + and then Is_Interface (Scope (DTC_Entity (Alias (Prim)))) + then + Write_Str (" from interface "); + Write_Name (Chars (Scope (DTC_Entity (Alias (Prim))))); + end if; + + if Present (Abstract_Interface_Alias (Prim)) then + Write_Str (", AI_Alias of "); + Write_Name (Chars (Scope (DTC_Entity + (Abstract_Interface_Alias (Prim))))); + Write_Char (':'); + Write_Int (Int (Abstract_Interface_Alias (Prim))); + end if; + + Write_Str (")"); + end if; + + -- Display the final position of this primitive in its associated + -- (primary or secondary) dispatch table + + if Present (DTC_Entity (Prim)) + and then DT_Position (Prim) /= No_Uint + then + Write_Str (" at #"); + Write_Int (UI_To_Int (DT_Position (Prim))); + end if; + + if Is_Abstract (Prim) then + Write_Str (" is abstract;"); + end if; + + Write_Eol; + + Next_Elmt (Elmt); + end loop; + end Write_DT; + end Exp_Disp; diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index d942c3f514b..a60a43d470d 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -25,22 +25,26 @@ ------------------------------------------------------------------------------ -- This package contains routines involved in tagged types and dynamic --- dispatching expansion +-- dispatching expansion. with Types; use Types; package Exp_Disp is type DT_Access_Action is (CW_Membership, + IW_Membership, DT_Entry_Size, DT_Prologue_Size, + Get_Access_Level, Get_External_Tag, Get_Prim_Op_Address, Get_RC_Offset, Get_Remotely_Callable, Inherit_DT, Inherit_TSD, + Register_Interface_Tag, Register_Tag, + Set_Access_Level, Set_Expanded_Name, Set_External_Tag, Set_Prim_Op_Address, @@ -51,17 +55,26 @@ package Exp_Disp is TSD_Prologue_Size); function Fill_DT_Entry - (Loc : Source_Ptr; - Prim : Entity_Id) - return Node_Id; + (Loc : Source_Ptr; + Prim : Entity_Id; + Thunk_Id : Entity_Id := Empty) return Node_Id; -- Generate the code necessary to fill the appropriate entry of the -- dispatch table of Prim's controlling type with Prim's address. + procedure Make_Abstract_Interface_DT + (AI_Tag : Entity_Id; + Acc_Disp_Tables : in out Elist_Id; + Result : out List_Id); + -- Ada 2005 (AI-251): Expand the declarations for the secondary Dispatch + -- Tables corresponding with an abstract interface. The reference to the + -- dispatch table is appended at the end of Acc_Disp_Tables; it will be + -- are later used to generate the corresponding initialization statement + -- (see Exp_Ch3.Build_Init_Procedure). + function Make_DT_Access_Action (Typ : Entity_Id; Action : DT_Access_Action; - Args : List_Id) - return Node_Id; + Args : List_Id) return Node_Id; -- Generate a call to one of the Dispatch Table Access Subprograms defined -- in Ada.Tags or in Interfaces.Cpp @@ -71,7 +84,7 @@ package Exp_Disp is procedure Set_All_DT_Position (Typ : Entity_Id); -- Set the DT_Position field for each primitive operation. In the CPP - -- Class case check that no pragma CPP_Virtual is missing and that the + -- Class case check that no pragma CPP_Virtual is missing and that the -- DT_Position are coherent procedure Expand_Dispatching_Call (Call_Node : Node_Id); @@ -79,6 +92,25 @@ package Exp_Disp is -- the required tag checks when appropriate. For CPP types the call is -- done through the Vtable (tag checks are not relevant) + procedure Expand_Interface_Actuals (Call_Node : Node_Id); + -- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide + -- interfaces to reference the interface tag of the actual object + + procedure Expand_Interface_Conversion (N : Node_Id); + -- Ada 2005 (AI-251): N is a type-conversion node. Reference the base of + -- the object to give access to the interface tag associated with the + -- secondary dispatch table + + function Expand_Interface_Thunk + (N : Node_Id; + Thunk_Id : Entity_Id; + Iface_Tag : Entity_Id) return Node_Id; + -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we + -- generate additional subprograms (thunks) to have a layout compatible + -- with the C++ ABI. The thunk modifies the value of the first actual of + -- the call (that is, the pointer to the object) before transferring + -- control to the target function. + procedure Set_Default_Constructor (Typ : Entity_Id); -- Typ is a CPP_Class type. Create the Init procedure of that type to -- be the default constructor (i.e. the function returning this type, @@ -88,4 +120,8 @@ package Exp_Disp is -- Return an expression that holds True if the object can be transmitted -- onto another partition according to E.4 (18) + procedure Write_DT (Typ : Entity_Id); + pragma Export (Ada, Write_DT); + -- Debugging procedure (to be called within gdb) + end Exp_Disp; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 4868dc1286e..eda4383e276 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -47,6 +47,7 @@ with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; @@ -107,6 +108,15 @@ package body Exp_Util is -- procedure of record with task components, or for a dynamically -- created task that is assigned to a selected component. + procedure Find_Interface_Tag + (T : Entity_Id; + Iface : Entity_Id; + Iface_Tag : out Entity_Id; + Iface_ADT : out Entity_Id); + -- Ada 2005 (AI-251): Subsidiary procedure to Find_Interface_ADT and + -- Find_Interface_Tag. Given a type T implementing the interface, + -- returns the corresponding Tag and Access_Disp_Table entities. + function Make_CW_Equivalent_Type (T : Entity_Id; E : Node_Id) return Entity_Id; @@ -1219,9 +1229,32 @@ package body Exp_Util is then if Is_Itype (Exp_Typ) then - -- No need to generate a new one + -- Within an initialization procedure, a selected component + -- denotes a component of the enclosing record, and it appears + -- as an actual in a call to its own initialization procedure. + -- If this component depends on the outer discriminant, we must + -- generate the proper actual subtype for it. - T := Exp_Typ; + if Nkind (Exp) = N_Selected_Component + and then Within_Init_Proc + then + declare + Decl : constant Node_Id := + Build_Actual_Subtype_Of_Component (Exp_Typ, Exp); + begin + if Present (Decl) then + Insert_Action (N, Decl); + T := Defining_Identifier (Decl); + else + T := Exp_Typ; + end if; + end; + + -- No need to generate a new one (new what???) + + else + T := Exp_Typ; + end if; else T := @@ -1261,6 +1294,145 @@ package body Exp_Util is end if; end Expand_Subtype_From_Expr; + ------------------------ + -- Find_Interface_Tag -- + ------------------------ + + procedure Find_Interface_Tag + (T : Entity_Id; + Iface : Entity_Id; + Iface_Tag : out Entity_Id; + Iface_ADT : out Entity_Id) + is + AI_Tag : Entity_Id; + ADT_Elmt : Elmt_Id; + Found : Boolean := False; + + procedure Find_AI_Tag (Typ : in Entity_Id; Found : in out Boolean); + -- This must be commented ??? + + ----------------- + -- Find_AI_Tag -- + ----------------- + + procedure Find_AI_Tag (Typ : in Entity_Id; Found : in out Boolean) is + T : Entity_Id := Typ; + Etyp : Entity_Id; -- := Etype (Typ); -- why is this commented ??? + AI_Elmt : Elmt_Id; + AI : Node_Id; + + begin + -- Check if the interface is an immediate ancestor of the type and + -- therefore shares the main tag. + + if Typ = Iface then + AI_Tag := First_Tag_Component (Typ); + ADT_Elmt := First_Elmt (Access_Disp_Table (Typ)); + Found := True; + return; + end if; + + -- Handle private types + + if Has_Private_Declaration (T) + and then Present (Full_View (T)) + then + T := Full_View (T); + end if; + + if Is_Access_Type (Typ) then + T := Directly_Designated_Type (T); + + elsif Ekind (T) = E_Protected_Type + or else Ekind (T) = E_Task_Type + then + T := Corresponding_Record_Type (T); + end if; + + Etyp := Etype (T); + + -- Climb to the root type + + if Etyp /= Typ then + Find_AI_Tag (Etyp, Found); + end if; + + -- Traverse the list of interfaces implemented by the type + + if not Found + and then Present (Abstract_Interfaces (T)) + and then not Is_Empty_Elmt_List (Abstract_Interfaces (T)) + then + -- Skip the tag associated with the primary table (if + -- already placed in the record) + + if Etype (Node (First_Elmt + (Access_Disp_Table (T)))) = RTE (RE_Tag) + then + AI_Tag := Next_Tag_Component (First_Tag_Component (T)); + ADT_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (T))); + else + AI_Tag := First_Tag_Component (T); + ADT_Elmt := First_Elmt (Access_Disp_Table (T)); + end if; + + pragma Assert (Present (AI_Tag)); + pragma Assert (Present (Node (ADT_Elmt))); + + AI_Elmt := First_Elmt (Abstract_Interfaces (T)); + while Present (AI_Elmt) loop + AI := Node (AI_Elmt); + + if AI = Iface or else Is_Ancestor (Iface, AI) then + Found := True; + return; + end if; + + AI_Tag := Next_Tag_Component (AI_Tag); + Next_Elmt (AI_Elmt); + Next_Elmt (ADT_Elmt); + end loop; + end if; + end Find_AI_Tag; + + begin + Find_AI_Tag (T, Found); + pragma Assert (Found); + + Iface_Tag := AI_Tag; + Iface_ADT := Node (ADT_Elmt); + end Find_Interface_Tag; + + ------------------------ + -- Find_Interface_Tag -- + ------------------------ + + function Find_Interface_ADT + (T : Entity_Id; + Iface : Entity_Id) return Entity_Id + is + Iface_Tag : Entity_Id := Empty; + Iface_ADT : Entity_Id := Empty; + begin + Find_Interface_Tag (T, Iface, Iface_Tag, Iface_ADT); + return Iface_ADT; + end Find_Interface_ADT; + + ------------------------ + -- Find_Interface_Tag -- + ------------------------ + + function Find_Interface_Tag + (T : Entity_Id; + Iface : Entity_Id) return Entity_Id + is + Iface_Tag : Entity_Id := Empty; + Iface_ADT : Entity_Id := Empty; + begin + Find_Interface_Tag (T, Iface, Iface_Tag, Iface_ADT); + return Iface_Tag; + end Find_Interface_Tag; + ------------------ -- Find_Prim_Op -- ------------------ @@ -1317,10 +1489,9 @@ package body Exp_Util is Par : Node_Id; begin - -- Loop to determine whether there is a component reference in - -- the left hand side if Exp appears on the left side of an - -- assignment statement. Needed to determine if form of result - -- must be a variable. + -- Loop to determine whether there is a component reference in the left + -- hand side if Exp appears on the left side of an assignment statement. + -- Needed to determine if form of result must be a variable. Par := Exp; while Present (Par) @@ -1339,15 +1510,15 @@ package body Exp_Util is end if; end loop; - -- If the expression is a selected component, it is being evaluated - -- as part of a discriminant check. If it is part of a left-hand - -- side, this is the last use of its value and it is safe to create - -- a renaming for it, rather than a temporary. In addition, if it - -- is not an addressable field, creating a temporary may be a problem - -- for gigi, or might drop the value of the assignment. Therefore, - -- if the expression is on the lhs of an assignment, remove side - -- effects without requiring a temporary, and create a renaming. - -- (See remove_side_effects for details). + -- If the expression is a selected component, it is being evaluated as + -- part of a discriminant check. If it is part of a left-hand side, this + -- is the last use of its value and it is safe to create a renaming for + -- it, rather than a temporary. In addition, if it is not an addressable + -- field, creating a temporary may be a problem for gigi, or might drop + -- the value of the assignment. Therefore, if the expression is on the + -- lhs of an assignment, remove side effects without requiring a + -- temporary, and create a renaming. (See remove_side_effects for + -- details). Remove_Side_Effects (Exp, Name_Req, Variable_Ref => not Component_In_Lhs); @@ -1423,9 +1594,9 @@ package body Exp_Util is -- If we fall off the top of the tree, then that's odd, but -- perhaps it could occur in some error situation, and the - -- safest response is simply to assume that the outcome of - -- the condition is unknown. No point in bombing during an - -- attempt to optimize things. + -- safest response is simply to assume that the outcome of the + -- condition is unknown. No point in bombing during an attempt + -- to optimize things. if No (N) then return; @@ -1448,9 +1619,9 @@ package body Exp_Util is end if; end; - -- ELSIF part. Condition is known true within the referenced - -- ELSIF, known False in any subsequent ELSIF or ELSE part, - -- and unknown before the ELSE part or after the IF statement. + -- ELSIF part. Condition is known true within the referenced ELSIF, + -- known False in any subsequent ELSIF or ELSE part, and unknown before + -- the ELSE part or after the IF statement. elsif Nkind (CV) = N_Elsif_Part then Stm := Parent (CV); @@ -1468,8 +1639,8 @@ package body Exp_Util is return; end if; - -- Again we lack the SLOC of the ELSE, so we need to climb the - -- tree to see if we are within the ELSIF part in question. + -- Again we lack the SLOC of the ELSE, so we need to climb the tree + -- to see if we are within the ELSIF part in question. declare N : Node_Id; @@ -1481,9 +1652,9 @@ package body Exp_Util is -- If we fall off the top of the tree, then that's odd, but -- perhaps it could occur in some error situation, and the - -- safest response is simply to assume that the outcome of - -- the condition is unknown. No point in bombing during an - -- attempt to optimize things. + -- safest response is simply to assume that the outcome of the + -- condition is unknown. No point in bombing during an attempt + -- to optimize things. if No (N) then return; @@ -1510,9 +1681,8 @@ package body Exp_Util is return; end if; - -- If we fall through here, then we have a reportable - -- condition, Sens is True if the condition is true and - -- False if it needs inverting. + -- If we fall through here, then we have a reportable condition, Sens is + -- True if the condition is true and False if it needs inverting. -- Deal with NOT operators, inverting sense @@ -2320,6 +2490,47 @@ package body Exp_Util is return True; end Is_All_Null_Statements; + ------------------------ + -- Is_Default_Prim_Op -- + ------------------------ + + function Is_Predefined_Dispatching_Operation + (Subp : Entity_Id) return Boolean + is + TSS_Name : TSS_Name_Type; + E : Entity_Id := Subp; + begin + pragma Assert (Is_Dispatching_Operation (Subp)); + + -- Handle overriden subprograms + + while Present (Alias (E)) loop + E := Alias (E); + end loop; + + Get_Name_String (Chars (E)); + + if Name_Len > TSS_Name_Type'Last then + TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 + .. Name_Len)); + if Chars (E) = Name_uSize + or else Chars (E) = Name_uAlignment + or else TSS_Name = TSS_Stream_Read + or else TSS_Name = TSS_Stream_Write + or else TSS_Name = TSS_Stream_Input + or else TSS_Name = TSS_Stream_Output + or else Chars (E) = Name_Op_Eq + or else Chars (E) = Name_uAssign + or else TSS_Name = TSS_Deep_Adjust + or else TSS_Name = TSS_Deep_Finalize + then + return True; + end if; + end if; + + return False; + end Is_Predefined_Dispatching_Operation; + ---------------------------------- -- Is_Possibly_Unaligned_Object -- ---------------------------------- @@ -2366,8 +2577,9 @@ package body Exp_Util is begin -- If component reference is for an array with non-static bounds, - -- then it is always aligned, we can only unaligned arrays with - -- static bounds (more accurately bounds known at compile time) + -- then it is always aligned: we can only process unaligned + -- arrays with static bounds (more accurately bounds known at + -- compile time). if Is_Array_Type (T) and then not Compile_Time_Known_Bounds (T) diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index da3b1335b7d..711949c3dc6 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -135,7 +135,7 @@ package Exp_Util is -- Actions field of the N_Compilation_Aux node for the main unit). procedure Insert_Library_Level_Actions (L : List_Id); - -- Similar, but inserts a list of actions. + -- Similar, but inserts a list of actions ----------------------- -- Other Subprograms -- @@ -145,47 +145,46 @@ package Exp_Util is -- The node N is an expression whose root-type is Boolean, and which -- represents a boolean value used as a condition (i.e. a True/False -- value). This routine handles the case of C and Fortran convention - -- boolean types, which have zero/non-zero semantics rather than the - -- normal 0/1 semantics, and also the case of an enumeration rep - -- clause that specifies a non-standard representation. On return, - -- node N always has the type Standard.Boolean, with a value that - -- is a standard Boolean values of 0/1 for False/True. This procedure - -- is used in two situations. First, the processing for a condition - -- field always calls Adjust_Condition, so that the boolean value - -- presented to the backend is a standard value. Second, for the - -- code for boolean operations such as AND, Adjust_Condition is - -- called on both operands, and then the operation is done in the - -- domain of Standard_Boolean, then Adjust_Result_Type is called - -- on the result to possibly reset the original type. This procedure + -- boolean types, which have zero/non-zero semantics rather than the normal + -- 0/1 semantics, and also the case of an enumeration rep clause that + -- specifies a non-standard representation. On return, node N always has + -- the type Standard.Boolean, with a value that is a standard Boolean + -- values of 0/1 for False/True. This procedure is used in two situations. + -- First, the processing for a condition field always calls + -- Adjust_Condition, so that the boolean value presented to the backend is + -- a standard value. Second, for the code for boolean operations such as + -- AND, Adjust_Condition is called on both operands, and then the operation + -- is done in the domain of Standard_Boolean, then Adjust_Result_Type is + -- called on the result to possibly reset the original type. This procedure -- also takes care of validity checking if Validity_Checks = Tests. procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id); -- The processing of boolean operations like AND uses the procedure - -- Adjust_Condition so that it can operate on Standard.Boolean, which - -- is the only boolean type on which the backend needs to be able to - -- implement such operators. This means that the result is also of - -- type Standard.Boolean. In general the type must be reset back to - -- the original type to get proper semantics, and that is the purpose - -- of this procedure. N is the node (of type Standard.Boolean), and - -- T is the desired type. As an optimization, this procedure leaves - -- the type as Standard.Boolean in contexts where this is permissible - -- (in particular for Condition fields, and for operands of other - -- logical operations higher up the tree). The call to this procedure - -- is completely ignored if the argument N is not of type Boolean. + -- Adjust_Condition so that it can operate on Standard.Boolean, which is + -- the only boolean type on which the backend needs to be able to implement + -- such operators. This means that the result is also of type + -- Standard.Boolean. In general the type must be reset back to the original + -- type to get proper semantics, and that is the purpose of this procedure. + -- N is the node (of type Standard.Boolean), and T is the desired type. As + -- an optimization, this procedure leaves the type as Standard.Boolean in + -- contexts where this is permissible (in particular for Condition fields, + -- and for operands of other logical operations higher up the tree). The + -- call to this procedure is completely ignored if the argument N is not of + -- type Boolean. procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id); -- Add a new freeze action for the given type. The freeze action is - -- attached to the freeze node for the type. Actions will be elaborated - -- in the order in which they are added. Note that the added node is not + -- attached to the freeze node for the type. Actions will be elaborated in + -- the order in which they are added. Note that the added node is not -- analyzed. The analyze call is found in Sem_Ch13.Expand_N_Freeze_Entity. procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id); - -- Adds the given list of freeze actions (declarations or statements) - -- for the given type. The freeze actions are attached to the freeze - -- node for the type. Actions will be elaborated in the order in which - -- they are added, and the actions within the list will be elaborated in - -- list order. Note that the added nodes are not analyzed. The analyze - -- call is found in Sem_Ch13.Expand_N_Freeze_Entity. + -- Adds the given list of freeze actions (declarations or statements) for + -- the given type. The freeze actions are attached to the freeze node for + -- the type. Actions will be elaborated in the order in which they are + -- added, and the actions within the list will be elaborated in list order. + -- Note that the added nodes are not analyzed. The analyze call is found in + -- Sem_Ch13.Expand_N_Freeze_Entity. function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id; -- Build an N_Procedure_Call_Statement calling the given runtime entity. @@ -198,55 +197,52 @@ package Exp_Util is Id_Ref : Node_Id; A_Type : Entity_Id) return List_Id; - -- Build declaration for a variable that holds an identifying string - -- to be used as a task name. Id_Ref is an identifier if the task is - -- a variable, and a selected or indexed component if the task is a - -- component of an object. If it is an indexed component, A_Type is - -- the corresponding array type. Its index types are used to build the - -- string as an image of the index values. For composite types, the - -- result includes two declarations: one for a generated function that - -- computes the image without using concatenation, and one for the - -- variable that holds the result. + -- Build declaration for a variable that holds an identifying string to be + -- used as a task name. Id_Ref is an identifier if the task is a variable, + -- and a selected or indexed component if the task is component of an + -- object. If it is an indexed component, A_Type is the corresponding array + -- type. Its index types are used to build the string as an image of the + -- index values. For composite types, the result includes two declarations: + -- one for a generated function that computes the image without using + -- concatenation, and one for the variable that holds the result. function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean; - -- This function is in charge of detecting record components that may - -- cause trouble in the back end if an attempt is made to assign the - -- component. The back end can handle such assignments with no problem - -- if the components involved are small (64-bits or less) records or - -- scalar items (including bit-packed arrays represented with modular - -- types) or are both aligned on a byte boundary (starting on a byte - -- boundary, and occupying an integral number of bytes). + -- This function is in charge of detecting record components that may cause + -- trouble in the back end if an attempt is made to assign the component. + -- The back end can handle such assignments with no problem if the + -- components involved are small (64-bits or less) records or scalar items + -- (including bit-packed arrays represented with modular types) or are both + -- aligned on a byte boundary (starting on a byte boundary, and occupying + -- an integral number of bytes). -- - -- However, problems arise for records larger than 64 bits, or for - -- arrays (other than bit-packed arrays represented with a modular - -- type) if the component starts on a non-byte boundary, or does - -- not occupy an integral number of bytes (i.e. there are some bits - -- possibly shared with fields at the start or beginning of the - -- component). The back end cannot handle loading and storing such - -- components in a single operation. + -- However, problems arise for records larger than 64 bits, or for arrays + -- (other than bit-packed arrays represented with a modular type) if the + -- component starts on a non-byte boundary, or does not occupy an integral + -- number of bytes (i.e. there are some bits possibly shared with fields at + -- the start or beginning of the component). The back end cannot handle + -- loading and storing such components in a single operation. -- -- This function is used to detect the troublesome situation. it is - -- conservative in the sense that it produces True unless it knows - -- for sure that the component is safe (as outlined in the first - -- paragraph above). The code generation for record and array - -- assignment checks for trouble using this function, and if so - -- the assignment is generated component-wise, which the back end - -- is required to handle correctly. + -- conservative in the sense that it produces True unless it knows for sure + -- that the component is safe (as outlined in the first paragraph above). + -- The code generation for record and array assignment checks for trouble + -- using this function, and if so the assignment is generated + -- component-wise, which the back end is required to handle correctly. -- - -- Note that in GNAT 3, the back end will reject such components - -- anyway, so the hard work in checking for this case is wasted - -- in GNAT 3, but it's harmless, so it is easier to do it in - -- all cases, rather than conditionalize it in GNAT 5 or beyond. + -- Note that in GNAT 3, the back end will reject such components anyway, so + -- the hard work in checking for this case is wasted in GNAT 3, but it's + -- harmless, so it is easier to do it in all cases, rather than + -- conditionalize it in GNAT 5 or beyond. procedure Convert_To_Actual_Subtype (Exp : Node_Id); - -- The Etype of an expression is the nominal type of the expression, - -- not the actual subtype. Often these are the same, but not always. - -- For example, a reference to a formal of unconstrained type has the - -- unconstrained type as its Etype, but the actual subtype is obtained - -- by applying the actual bounds. This routine is given an expression, - -- Exp, and (if necessary), replaces it using Rewrite, with a conversion - -- to the actual subtype, building the actual subtype if necessary. If - -- the expression is already of the requested type, then it is unchanged. + -- The Etype of an expression is the nominal type of the expression, not + -- the actual subtype. Often these are the same, but not always. For + -- example, a reference to a formal of unconstrained type has the + -- unconstrained type as its Etype, but the actual subtype is obtained by + -- applying the actual bounds. This routine is given an expression, Exp, + -- and (if necessary), replaces it using Rewrite, with a conversion to the + -- actual subtype, building the actual subtype if necessary. If the + -- expression is already of the requested type, then it is unchanged. function Current_Sem_Unit_Declarations return List_Id; -- Return the a place where it is fine to insert declarations for the @@ -258,20 +254,20 @@ package Exp_Util is function Duplicate_Subexpr (Exp : Node_Id; Name_Req : Boolean := False) return Node_Id; - -- Given the node for a subexpression, this function makes a logical - -- copy of the subexpression, and returns it. This is intended for use - -- when the expansion of an expression needs to repeat part of it. For - -- example, replacing a**2 by a*a requires two references to a which - -- may be a complex subexpression. Duplicate_Subexpr guarantees not - -- to duplicate side effects. If necessary, it generates actions to - -- save the expression value in a temporary, inserting these actions - -- into the tree using Insert_Actions with Exp as the insertion location. - -- The original expression and the returned result then become references - -- to this saved value. Exp must be analyzed on entry. On return, Exp - -- is analyzed, but the caller is responsible for analyzing the returned - -- copy after it is attached to the tree. The Name_Req flag is set to - -- ensure that the result is suitable for use in a context requiring a - -- name (e.g. the prefix of an attribute reference). + -- Given the node for a subexpression, this function makes a logical copy + -- of the subexpression, and returns it. This is intended for use when the + -- expansion of an expression needs to repeat part of it. For example, + -- replacing a**2 by a*a requires two references to a which may be a + -- complex subexpression. Duplicate_Subexpr guarantees not to duplicate + -- side effects. If necessary, it generates actions to save the expression + -- value in a temporary, inserting these actions into the tree using + -- Insert_Actions with Exp as the insertion location. The original + -- expression and the returned result then become references to this saved + -- value. Exp must be analyzed on entry. On return, Exp is analyzed, but + -- the caller is responsible for analyzing the returned copy after it is + -- attached to the tree. The Name_Req flag is set to ensure that the result + -- is suitable for use in a context requiring name (e.g. the prefix of an + -- attribute reference). -- -- Note that if there are any run time checks in Exp, these same checks -- will be duplicated in the returned duplicated expression. The two @@ -289,13 +285,13 @@ package Exp_Util is function Duplicate_Subexpr_Move_Checks (Exp : Node_Id; Name_Req : Boolean := False) return Node_Id; - -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks - -- is called on Exp after the duplication is complete, so that the - -- original expression does not include checks. In this case the result - -- returned (the duplicated expression) will retain the original checks. - -- This is appropriate for use when the duplicated expression is sure - -- to be elaborated before the original expression Exp, so that there - -- is no need to repeat the checks. + -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is + -- called on Exp after the duplication is complete, so that the original + -- expression does not include checks. In this case the result returned + -- (the duplicated expression) will retain the original checks. This is + -- appropriate for use when the duplicated expression is sure to be + -- elaborated before the original expression Exp, so that there is no need + -- to repeat the checks. procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id); -- This procedure ensures that type referenced by Typ is defined. For the @@ -309,15 +305,15 @@ package Exp_Util is -- Rewrites Cond with the expression: Cond and then Cond1. If Cond is -- Empty, then simply returns Cond1 (this allows the use of Empty to -- initialize a series of checks evolved by this routine, with a final - -- result of Empty indicating that no checks were required). The Sloc - -- field of the constructed N_And_Then node is copied from Cond1. + -- result of Empty indicating that no checks were required). The Sloc field + -- of the constructed N_And_Then node is copied from Cond1. procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id); - -- Rewrites Cond with the expression: Cond or else Cond1. If Cond is - -- Empty, then simply returns Cond1 (this allows the use of Empty to - -- initialize a series of checks evolved by this routine, with a final - -- result of Empty indicating that no checks were required). The Sloc - -- field of the constructed N_Or_Else node is copied from Cond1. + -- Rewrites Cond with the expression: Cond or else Cond1. If Cond is Empty, + -- then simply returns Cond1 (this allows the use of Empty to initialize a + -- series of checks evolved by this routine, with a final result of Empty + -- indicating that no checks were required). The Sloc field of the + -- constructed N_Or_Else node is copied from Cond1. procedure Expand_Subtype_From_Expr (N : Node_Id; @@ -328,6 +324,18 @@ package Exp_Util is -- declarations and/or allocations when the type is indefinite (including -- class-wide). + function Find_Interface_ADT + (T : Entity_Id; + Iface : Entity_Id) return Entity_Id; + -- Ada 2005 (AI-251): Given a type T implementing the interface Iface, + -- return the Access_Disp_Table value of the interface. + + function Find_Interface_Tag + (T : Entity_Id; + Iface : Entity_Id) return Entity_Id; + -- Ada 2005 (AI-251): Given a type T implementing the interface Iface, + -- return the record component containing the tag of Iface. + function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id; -- Find the first primitive operation of type T whose name is 'Name'. -- This function allows the use of a primitive operation which is not @@ -362,73 +370,76 @@ package Exp_Util is (Var : Node_Id; Op : out Node_Kind; Val : out Node_Id); - -- This routine processes the Current_Value field of the variable Var. - -- If the Current_Value field is null or if it represents a known value, - -- then on return Cond is set to N_Empty, and Val is set to Empty. + -- This routine processes the Current_Value field of the variable Var. If + -- the Current_Value field is null or if it represents a known value, then + -- on return Cond is set to N_Empty, and Val is set to Empty. -- - -- The other case is when Current_Value points to an N_If_Statement - -- or an N_Elsif_Part (while statement). Such a setting only occurs - -- if the condition of an IF or ELSIF is of the form X op Y, where X - -- is the variable in question, Y is a compile-time known value, and - -- op is one of the six possible relational operators. + -- The other case is when Current_Value points to an N_If_Statement or an + -- N_Elsif_Part (while statement). Such a setting only occurs if the + -- condition of an IF or ELSIF is of the form X op Y, where is the variable + -- in question, Y is a compile-time known value, and op is one of the six + -- possible relational operators. -- - -- In this case, Get_Current_Condition digs out the condition, and - -- then checks if the condition is known false, known true, or not - -- known at all. In the first two cases, Get_Current_Condition will - -- return with Op set to the appropriate conditional operator (inverted - -- if the condition is known false), and Val set to the constant value. - -- If the condition is not known, then Cond and Val are set for the - -- empty case (N_Empty and Empty). + -- In this case, Get_Current_Condition digs out the condition, and then + -- checks if the condition is known false, known true, or not known at all. + -- In the first two cases, Get_Current_Condition will return with Op set to + -- the appropriate conditional operator (inverted if the condition is known + -- false), and Val set to the constant value. If the condition is not + -- known, then Cond and Val are set for the empty case (N_Empty and Empty). -- -- The check for whether the condition is true/false unknown depends -- on the case: -- - -- For an IF, the condition is known true in the THEN part, known - -- false in any ELSIF or ELSE part, and not known outside the IF - -- statement in question. + -- For an IF, the condition is known true in the THEN part, known false + -- in any ELSIF or ELSE part, and not known outside the IF statement in + -- question. -- - -- For an ELSIF, the condition is known true in the ELSIF part, - -- known FALSE in any subsequent ELSIF, or ELSE part, and not - -- known before the ELSIF, or after the end of the IF statement. + -- For an ELSIF, the condition is known true in the ELSIF part, known + -- FALSE in any subsequent ELSIF, or ELSE part, and not known before the + -- ELSIF, or after the end of the IF statement. -- - -- The caller can use this result to determine the value (for the - -- case of N_Op_Eq), or to determine the result of some other test - -- in other cases (e.g. no access check required if N_Op_Ne Null). + -- The caller can use this result to determine the value (for the case of + -- N_Op_Eq), or to determine the result of some other test in other cases + -- (e.g. no access check required if N_Op_Ne Null). function Homonym_Number (Subp : Entity_Id) return Nat; -- Here subp is the entity for a subprogram. This routine returns the - -- homonym number used to disambiguate overloaded subprograms in the - -- same scope (the number is used as part of constructed names to make - -- sure that they are unique). The number is the ordinal position on - -- the Homonym chain, counting only entries in the curren scope. If - -- an entity is not overloaded, the returned number will be one. + -- homonym number used to disambiguate overloaded subprograms in the same + -- scope (the number is used as part of constructed names to make sure that + -- they are unique). The number is the ordinal position on the Homonym + -- chain, counting only entries in the curren scope. If an entity is not + -- overloaded, the returned number will be one. function Inside_Init_Proc return Boolean; -- Returns True if current scope is within an init proc function In_Unconditional_Context (Node : Node_Id) return Boolean; - -- Node is the node for a statement or a component of a statement. - -- This function deteermines if the statement appears in a context - -- that is unconditionally executed, i.e. it is not within a loop - -- or a conditional or a case statement etc. + -- Node is the node for a statement or a component of a statement. This + -- function deteermines if the statement appears in a context that is + -- unconditionally executed, i.e. it is not within a loop or a conditional + -- or a case statement etc. function Is_All_Null_Statements (L : List_Id) return Boolean; - -- Return True if all the items of the list are N_Null_Statement - -- nodes. False otherwise. True for an empty list. It is an error - -- to call this routine with No_List as the argument. + -- Return True if all the items of the list are N_Null_Statement nodes. + -- False otherwise. True for an empty list. It is an error to call this + -- routine with No_List as the argument. + + function Is_Predefined_Dispatching_Operation + (Subp : Entity_Id) return Boolean; + -- Ada 2005 (AI-251): Determines if Subp is a predefined primitive + -- operation. function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean; - -- Determine whether the node P is a reference to a bit packed - -- array, i.e. whether the designated object is a component of - -- a bit packed array, or a subcomponent of such a component. - -- If so, then all subscripts in P are evaluated with a call - -- to Force_Evaluation, and True is returned. Otherwise False - -- is returned, and P is not affected. + -- Determine whether the node P is a reference to a bit packed array, i.e. + -- whether the designated object is a component of a bit packed array, or a + -- subcomponent of such a component. If so, then all subscripts in P are + -- evaluated with a call to Force_Evaluation, and True is returned. + -- Otherwise False is returned, and P is not affected. function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean; - -- Determine whether the node P is a reference to a bit packed - -- slice, i.e. whether the designated object is bit packed slice - -- or a component of a bit packed slice. Return True if so. + -- Determine whether the node P is a reference to a bit packed slice, i.e. + -- whether the designated object is bit packed slice or a component of a + -- bit packed slice. Return True if so. function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean; -- Determine whether the node P is a slice of an array where the slice @@ -436,31 +447,30 @@ package Exp_Util is -- is not compatible with the type. Return True if so. function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean; - -- Node N is an object reference. This function returns True if it - -- is possible that the object may not be aligned according to the - -- normal default alignment requirement for its type (e.g. if it - -- appears in a packed record, or as part of a component that has - -- a component clause. + -- Node N is an object reference. This function returns True if it is + -- possible that the object may not be aligned according to the normal + -- default alignment requirement for its type (e.g. if it appears in a + -- packed record, or as part of a component that has a component clause. function Is_Renamed_Object (N : Node_Id) return Boolean; - -- Returns True if the node N is a renamed object. An expression - -- is considered to be a renamed object if either it is the Name - -- of an object renaming declaration, or is the prefix of a name - -- which is a renamed object. For example, in: + -- Returns True if the node N is a renamed object. An expression is + -- considered to be a renamed object if either it is the Name of an object + -- renaming declaration, or is the prefix of a name which is a renamed + -- object. For example, in: -- -- x : r renames a (1 .. 2) (1); -- - -- We consider that a (1 .. 2) is a renamed object since it is the - -- prefix of the name in the renaming declaration. + -- We consider that a (1 .. 2) is a renamed object since it is the prefix + -- of the name in the renaming declaration. function Is_Untagged_Derivation (T : Entity_Id) return Boolean; -- Returns true if type T is not tagged and is a derived type, -- or is a private type whose completion is such a type. procedure Kill_Dead_Code (N : Node_Id); - -- N represents a node for a section of code that is known to be - -- dead. The node is deleted, and any exception handler references - -- and warning messages relating to this code are removed. + -- N represents a node for a section of code that is known to be dead. The + -- node is deleted, and any exception handler references and warning + -- messages relating to this code are removed. procedure Kill_Dead_Code (L : List_Id); -- Like the above procedure, but applies to every element in the given @@ -485,31 +495,30 @@ package Exp_Util is -- a classwide type. function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean; - -- Determines if the given type, Typ, may require a large temporary - -- of the kind that causes back-end trouble if stack checking is enabled. - -- The result is True only the size of the type is known at compile time - -- and large, where large is defined heuristically by the body of this - -- routine. The purpose of this routine is to help avoid generating - -- troublesome temporaries that interfere with stack checking mechanism. - -- Note that the caller has to check whether stack checking is actually - -- enabled in order to guide the expansion (typically of a function call). + -- Determines if the given type, Typ, may require a large temporary of the + -- kind that causes back-end trouble if stack checking is enabled. The + -- result is True only the size of the type is known at compile time and + -- large, where large is defined heuristically by the body of this routine. + -- The purpose of this routine is to help avoid generating troublesome + -- temporaries that interfere with stack checking mechanism. Note that the + -- caller has to check whether stack checking is actually enabled in order + -- to guide the expansion (typically of a function call). procedure Remove_Side_Effects (Exp : Node_Id; Name_Req : Boolean := False; Variable_Ref : Boolean := False); - -- Given the node for a subexpression, this function replaces the node - -- if necessary by an equivalent subexpression that is guaranteed to be - -- side effect free. This is done by extracting any actions that could - -- cause side effects, and inserting them using Insert_Actions into the - -- tree to which Exp is attached. Exp must be analyzed and resolved - -- before the call and is analyzed and resolved on return. The Name_Req - -- may only be set to True if Exp has the form of a name, and the - -- effect is to guarantee that any replacement maintains the form of a - -- name. If Variable_Ref is set to TRUE, a variable is considered as a - -- side effect (used in implementing Force_Evaluation). Note: after a - -- call to Remove_Side_Effects, it is safe to call New_Copy_Tree to - -- obtain a copy of the resulting expression. + -- Given the node for a subexpression, this function replaces the node if + -- necessary by an equivalent subexpression that is guaranteed to be side + -- effect free. This is done by extracting any actions that could cause + -- side effects, and inserting them using Insert_Actions into the tree to + -- which Exp is attached. Exp must be analyzed and resolved before the call + -- and is analyzed and resolved on return. The Name_Req may only be set to + -- True if Exp has the form of a name, and the effect is to guarantee that + -- any replacement maintains the form of name. If Variable_Ref is set to + -- TRUE, a variable is considered as side effect (used in implementing + -- Force_Evaluation). Note: after call to Remove_Side_Effects, it is safe + -- to call New_Copy_Tree to obtain a copy of the resulting expression. function Represented_As_Scalar (T : Entity_Id) return Boolean; -- Returns True iff the implementation of this type in code generation @@ -517,22 +526,22 @@ package Exp_Util is -- packed arrays which are represented by a scalar (modular) type. function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean; - -- Given the node for an N_Unchecked_Type_Conversion, return True - -- if this is an unchecked conversion that Gigi can handle directly. - -- Otherwise return False if it is one for which the front end must - -- provide a temporary. Note that the node need not be analyzed, and - -- thus the Etype field may not be set, but in that case it must be - -- the case that the Subtype_Mark field of the node is set/analyzed. + -- Given the node for an N_Unchecked_Type_Conversion, return True if this + -- is an unchecked conversion that Gigi can handle directly. Otherwise + -- return False if it is one for which the front end must provide a + -- temporary. Note that the node need not be analyzed, and thus the Etype + -- field may not be set, but in that case it must be the case that the + -- Subtype_Mark field of the node is set/analyzed. procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id); - -- N is the node for a subprogram or generic body, and Spec_Id - -- is the entity for the corresponding spec. If an elaboration - -- entity is defined, then this procedure generates an assignment - -- statement to set it True, immediately after the body is elaborated. - -- However, no assignment is generated in the case of library level - -- procedures, since the setting of the flag in this case is generated - -- in the binder. We do that so that we can detect cases where this is - -- the only elaboration action that is required. + -- N is the node for a subprogram or generic body, and Spec_Id is the + -- entity for the corresponding spec. If an elaboration entity is defined, + -- then this procedure generates an assignment statement to set it True, + -- immediately after the body is elaborated. However, no assignment is + -- generated in the case of library level procedures, since the setting of + -- the flag in this case is generated in the binder. We do that so that we + -- can detect cases where this is the only elaboration action that is + -- required. function Target_Has_Fixed_Ops (Left_Typ : Entity_Id; @@ -545,20 +554,20 @@ package Exp_Util is function Type_May_Have_Bit_Aligned_Components (Typ : Entity_Id) return Boolean; - -- Determines if Typ is a composite type that has within it (looking - -- down recursively at any subcomponents), a record type which has a - -- component that may be bit aligned (see Possible_Bit_Aligned_Component). - -- The result is conservative, in that a result of False is decisive. - -- A result of True means that such a component may or may not be present. + -- Determines if Typ is a composite type that has within it (looking down + -- recursively at any subcomponents), a record type which has component + -- that may be bit aligned (see Possible_Bit_Aligned_Component). The result + -- is conservative, in that a result of False is decisive. A result of True + -- means that such a component may or may not be present. procedure Wrap_Cleanup_Procedure (N : Node_Id); - -- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer - -- call at the start of the statement sequence, and an Abort_Undefer call - -- at the end of the statement sequence. All cleanup routines (i.e. those - -- that are called from "at end" handlers) must defer abort on entry and - -- undefer abort on exit. Note that it is assumed that the code for the - -- procedure does not contain any return statements which would allow the - -- flow of control to escape doing the undefer call. + -- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer call + -- at the start of the statement sequence, and an Abort_Undefer call at the + -- end of the statement sequence. All cleanup routines (i.e. those that are + -- called from "at end" handlers) must defer abort on entry and undefer + -- abort on exit. Note that it is assumed that the code for the procedure + -- does not contain any return statements which would allow the flow of + -- control to escape doing the undefer call. private pragma Inline (Force_Evaluation); diff --git a/gcc/ada/i-cpp.adb b/gcc/ada/i-cpp.adb index ca872c2544d..85efcea6fcd 100644 --- a/gcc/ada/i-cpp.adb +++ b/gcc/ada/i-cpp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -31,357 +31,7 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Tags; use Ada.Tags; -with System; use System; -with System.Storage_Elements; use System.Storage_Elements; +-- Dummy body to deal with bootstrap issues (there used to be a real body) package body Interfaces.CPP is - --- Structure of the Dispatch Table - --- +-----------------------+ --- | Offset_To_Top | --- +-----------------------+ --- | Typeinfo_Ptr/TSD_Ptr |----> Type Specific Data --- Tag ---> +-----------------------+ +-------------------+ --- | table of | | inheritance depth | --- : primitive ops : +-------------------+ --- | pointers | | expanded name | --- +-----------------------+ +-------------------+ --- | external tag | --- +-------------------+ --- | Hash table link | --- +-------------------+ --- | Remotely Callable | --- +-------------------+ --- | Rec Ctrler offset | --- +-------------------+ --- | table of | --- : ancestor : --- | tags | --- +-------------------+ - - -- The declarations below need (extensive) comments ??? - - subtype Cstring is String (Positive); - type Cstring_Ptr is access all Cstring; - type Tag_Table is array (Natural range <>) of Vtable_Ptr; - pragma Suppress_Initialization (Tag_Table); - - type Type_Specific_Data is record - Idepth : Natural; - Expanded_Name : Cstring_Ptr; - External_Tag : Cstring_Ptr; - HT_Link : Tag; - Ancestor_Tags : Tag_Table (Natural); - end record; - - type Vtable_Entry is record - Pfn : System.Address; - end record; - - type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry; - - type VTable is record - -- Offset_To_Top : Integer; - -- Typeinfo_Ptr : System.Address; -- TSD is currently also here??? - Prims_Ptr : Vtable_Entry_Array (Positive); - end record; - -- Note: See comment in a-tags.adb explaining why the components - -- Offset_To_Top and Typeinfo_Ptr have been commented out. - -- ----------------------------------------------------------------------- - -- The size of the Prims_Ptr array actually depends on the tagged type to - -- which it applies. For each tagged type, the expander computes the - -- actual array size, allocates the Dispatch_Table record accordingly, and - -- generates code that displaces the base of the record after the - -- Typeinfo_Ptr component. For this reason the first two components have - -- been commented in the previous declaration. The access to these - -- components is done by means of local functions. - - --------------------------- - -- Unchecked Conversions -- - --------------------------- - - type Int_Ptr is access Integer; - - function To_Int_Ptr is - new Unchecked_Conversion (System.Address, Int_Ptr); - - function To_Cstring_Ptr is - new Unchecked_Conversion (Address, Cstring_Ptr); - - function To_Address is - new Unchecked_Conversion (Cstring_Ptr, Address); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Length (Str : Cstring_Ptr) return Natural; - -- Length of string represented by the given pointer (treating the string - -- as a C-style string, which is Nul terminated). - - function Offset_To_Top (T : Vtable_Ptr) return Integer; - -- Returns the current value of the offset_to_top component available in - -- the prologue of the dispatch table. - - function Typeinfo_Ptr (T : Vtable_Ptr) return System.Address; - -- Returns the current value of the typeinfo_ptr component available in - -- the prologue of the dispatch table. - - pragma Unreferenced (Offset_To_Top); - pragma Unreferenced (Typeinfo_Ptr); - -- These functions will be used for full compatibility with the C++ ABI - - ----------------------- - -- CPP_CW_Membership -- - ----------------------- - - function CPP_CW_Membership - (Obj_Tag : Vtable_Ptr; - Typ_Tag : Vtable_Ptr) return Boolean - is - Pos : constant Integer := TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth; - begin - return Pos >= 0 and then TSD (Obj_Tag).Ancestor_Tags (Pos) = Typ_Tag; - end CPP_CW_Membership; - - -------------------------- - -- CPP_Get_External_Tag -- - -------------------------- - - function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is - begin - return To_Address (TSD (T).External_Tag); - end CPP_Get_External_Tag; - - ------------------------- - -- CPP_Get_Prim_Op_Address -- - ------------------------- - - function CPP_Get_Prim_Op_Address - (T : Vtable_Ptr; - Position : Positive) return Address - is - begin - return T.Prims_Ptr (Position).Pfn; - end CPP_Get_Prim_Op_Address; - - ----------------------- - -- CPP_Get_RC_Offset -- - ----------------------- - - function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is - pragma Warnings (Off, T); - begin - return 0; - end CPP_Get_RC_Offset; - - ------------------------------- - -- CPP_Get_Remotely_Callable -- - ------------------------------- - - function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is - pragma Warnings (Off, T); - begin - return True; - end CPP_Get_Remotely_Callable; - - -------------------- - -- CPP_Inherit_DT -- - -------------------- - - procedure CPP_Inherit_DT - (Old_T : Vtable_Ptr; - New_T : Vtable_Ptr; - Entry_Count : Natural) - is - begin - if Old_T /= null then - New_T.Prims_Ptr (1 .. Entry_Count) - := Old_T.Prims_Ptr (1 .. Entry_Count); - end if; - end CPP_Inherit_DT; - - --------------------- - -- CPP_Inherit_TSD -- - --------------------- - - procedure CPP_Inherit_TSD - (Old_Tag : Vtable_Ptr; - New_Tag : Vtable_Ptr) - is - New_TSD_Ptr : constant Type_Specific_Data_Ptr := TSD (New_Tag); - Old_TSD_Ptr : Type_Specific_Data_Ptr; - - begin - if Old_Tag /= null then - Old_TSD_Ptr := TSD (Old_Tag); - New_TSD_Ptr.Idepth := Old_TSD_Ptr.Idepth + 1; - New_TSD_Ptr.Ancestor_Tags (1 .. New_TSD_Ptr.Idepth) := - Old_TSD_Ptr.Ancestor_Tags (0 .. Old_TSD_Ptr.Idepth); - else - New_TSD_Ptr.Idepth := 0; - end if; - - New_TSD_Ptr.Ancestor_Tags (0) := New_Tag; - end CPP_Inherit_TSD; - - --------------------------- - -- CPP_Set_Expanded_Name -- - --------------------------- - - procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is - begin - TSD (T).Expanded_Name := To_Cstring_Ptr (Value); - end CPP_Set_Expanded_Name; - - -------------------------- - -- CPP_Set_External_Tag -- - -------------------------- - - procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is - begin - TSD (T).External_Tag := To_Cstring_Ptr (Value); - end CPP_Set_External_Tag; - - ----------------------------- - -- CPP_Set_Prim_Op_Address -- - ----------------------------- - - procedure CPP_Set_Prim_Op_Address - (T : Vtable_Ptr; - Position : Positive; - Value : Address) - is - begin - T.Prims_Ptr (Position).Pfn := Value; - end CPP_Set_Prim_Op_Address; - - ----------------------- - -- CPP_Set_RC_Offset -- - ----------------------- - - procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is - pragma Warnings (Off, T); - pragma Warnings (Off, Value); - begin - null; - end CPP_Set_RC_Offset; - - ------------------------------- - -- CPP_Set_Remotely_Callable -- - ------------------------------- - - procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is - pragma Warnings (Off, T); - pragma Warnings (Off, Value); - begin - null; - end CPP_Set_Remotely_Callable; - - ----------------- - -- CPP_Set_TSD -- - ----------------- - - procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is - use type System.Storage_Elements.Storage_Offset; - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - CPP_DT_Typeinfo_Ptr_Size); - begin - TSD_Ptr.all := Value; - end CPP_Set_TSD; - - -------------------- - -- Displaced_This -- - -------------------- - - function Displaced_This - (Current_This : System.Address; - Vptr : Vtable_Ptr; - Position : Positive) - return System.Address - is - pragma Warnings (Off, Vptr); - pragma Warnings (Off, Position); - - begin - return Current_This; - - -- why is the following here commented out ??? - -- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1); - end Displaced_This; - - ------------------- - -- Expanded_Name -- - ------------------- - - function Expanded_Name (T : Vtable_Ptr) return String is - Result : constant Cstring_Ptr := TSD (T).Expanded_Name; - begin - return Result (1 .. Length (Result)); - end Expanded_Name; - - ------------------ - -- External_Tag -- - ------------------ - - function External_Tag (T : Vtable_Ptr) return String is - Result : constant Cstring_Ptr := TSD (T).External_Tag; - begin - return Result (1 .. Length (Result)); - end External_Tag; - - ------------ - -- Length -- - ------------ - - function Length (Str : Cstring_Ptr) return Natural is - Len : Integer := 1; - - begin - while Str (Len) /= ASCII.Nul loop - Len := Len + 1; - end loop; - - return Len - 1; - end Length; - - ------------------ - -- Offset_To_Top -- - ------------------ - - function Offset_To_Top (T : Vtable_Ptr) return Integer is - use type System.Storage_Elements.Storage_Offset; - - TSD_Ptr : constant Int_Ptr - := To_Int_Ptr (To_Address (T) - CPP_DT_Prologue_Size); - begin - return TSD_Ptr.all; - end Offset_To_Top; - - ------------------ - -- Typeinfo_Ptr -- - ------------------ - - function Typeinfo_Ptr (T : Vtable_Ptr) return System.Address is - use type System.Storage_Elements.Storage_Offset; - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - CPP_DT_Typeinfo_Ptr_Size); - begin - return TSD_Ptr.all; - end Typeinfo_Ptr; - - --------- - -- TSD -- - --------- - - function TSD (T : Vtable_Ptr) return Type_Specific_Data_Ptr is - use type System.Storage_Elements.Storage_Offset; - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - CPP_DT_Typeinfo_Ptr_Size); - begin - return To_Type_Specific_Data_Ptr (TSD_Ptr.all); - end TSD; - end Interfaces.CPP; diff --git a/gcc/ada/i-cpp.ads b/gcc/ada/i-cpp.ads index 99922cf56ee..6dbed5f481f 100644 --- a/gcc/ada/i-cpp.ads +++ b/gcc/ada/i-cpp.ads @@ -1,12 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUNTIME COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- -- I N T E R F A C E S . C P P -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -31,168 +31,21 @@ -- -- ------------------------------------------------------------------------------ --- Definitions for interfacing to C++ classes - --- This package corresponds to Ada.Tags but applied to tagged types which are --- are imported from C++ and correspond exactly to a C++ Class. The code that --- the GNAT front end generates does not know about the structure of the C++ --- dispatch table (Vtable) but always accesses it through the procedural --- interface defined in this package, thus the implementation of this package --- (the body) can be customized to another C++ compiler without any change in --- the compiler code itself as long as this procedural interface is respected. --- Note that Ada.Tags defines a very similar procedural interface to the --- regular Ada Dispatch Table. - -with System; -with System.Storage_Elements; -with Unchecked_Conversion; +-- Missing package comment ??? +with Ada.Tags; package Interfaces.CPP is +pragma Elaborate_Body; +-- We have a dummy body to deal with bootstrap path issues - type Vtable_Ptr is private; - - function Expanded_Name (T : Vtable_Ptr) return String; - function External_Tag (T : Vtable_Ptr) return String; - -private - package S renames System; - package SSE renames System.Storage_Elements; - - type Vtable; - type Vtable_Ptr is access all Vtable; - - type Type_Specific_Data; - type Type_Specific_Data_Ptr is access all Type_Specific_Data; - - -- These subprograms are in the private part. They are never accessed - -- directly except from compiler generated code, which has access to - -- private components of packages via the Rtsfind interface. - - procedure CPP_Set_Prim_Op_Address - (T : Vtable_Ptr; - Position : Positive; - Value : S.Address); - -- Given a pointer to a dispatch Table (T) and a position in the - -- dispatch Table put the address of the virtual function in it - -- (used for overriding) - - function CPP_Get_Prim_Op_Address - (T : Vtable_Ptr; - Position : Positive) - return S.Address; - -- Given a pointer to a dispatch Table (T) and a position in the DT - -- this function returns the address of the virtual function stored - -- in it (used for dispatching calls) - - procedure CPP_Set_TSD (T : Vtable_Ptr; Value : S.Address); - -- Given a pointer T to a dispatch Table, stores the address of the - -- record containing the Type Specific Data generated by GNAT - - CPP_DT_Prologue_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (2 * (Standard'Address_Size / S.Storage_Unit)); - -- Size of the first part of the dispatch table - - CPP_DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (Standard'Address_Size / System.Storage_Unit); - -- Size of the Typeinfo_Ptr field of the Dispatch Table. - - CPP_DT_Entry_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (1 * (Standard'Address_Size / S.Storage_Unit)); - -- Size of each primitive operation entry in the Dispatch Table. - - CPP_TSD_Prologue_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (4 * (Standard'Address_Size / S.Storage_Unit)); - -- Size of the first part of the type specific data - - CPP_TSD_Entry_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (1 * (Standard'Address_Size / S.Storage_Unit)); - -- Size of each ancestor tag entry in the TSD - - procedure CPP_Inherit_DT - (Old_T : Vtable_Ptr; - New_T : Vtable_Ptr; - Entry_Count : Natural); - -- Entry point used to initialize the DT of a type knowing the - -- tag of the direct ancestor and the number of primitive ops that are - -- inherited (Entry_Count). - - procedure CPP_Inherit_TSD - (Old_Tag : Vtable_Ptr; - New_Tag : Vtable_Ptr); - -- Entry point used to initialize the TSD of a type knowing the - -- TSD of the direct ancestor. - - function CPP_CW_Membership (Obj_Tag, Typ_Tag : Vtable_Ptr) return Boolean; - -- Given the tag of an object and the tag associated to a type, return - -- true if Obj is in Typ'Class. - - procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : S.Address); - -- Set the address of the string containing the external tag - -- in the Dispatch table - - function CPP_Get_External_Tag (T : Vtable_Ptr) return S.Address; - -- Retrieve the address of a null terminated string containing - -- the external name - - procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : S.Address); - -- Set the address of the string containing the expanded name - -- in the Dispatch table - - procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean); - -- Since the notions of spec/body distinction and categorized packages - -- do not exist in C, this procedure will do nothing - - function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean; - -- This function will always return True for the reason explained above - - procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset); - -- Sets the Offset of the implicit record controller when the object - -- has controlled components. Set to O otherwise. - - function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset; - -- Return the Offset of the implicit record controller when the object - -- has controlled components. O otherwise. - - function Displaced_This - (Current_This : S.Address; - Vptr : Vtable_Ptr; - Position : Positive) - return S.Address; - -- Compute the displacement on the "this" pointer in order to be - -- compatible with MI. - -- (used for virtual function calls) - - function TSD (T : Vtable_Ptr) return Type_Specific_Data_Ptr; - -- Given a pointer T to a dispatch Table, retreives the address of the - -- record containing the Type Specific Data generated by GNAT - - type Addr_Ptr is access System.Address; - - function To_Address is - new Unchecked_Conversion (Vtable_Ptr, System.Address); + subtype Vtable_Ptr is Ada.Tags.Tag; - function To_Addr_Ptr is - new Unchecked_Conversion (System.Address, Addr_Ptr); + -- These need commenting (this is not an RM package!) - function To_Type_Specific_Data_Ptr is - new Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); + function Expanded_Name (T : Vtable_Ptr) return String + renames Ada.Tags.Expanded_Name; - pragma Inline (CPP_Set_Prim_Op_Address); - pragma Inline (CPP_Get_Prim_Op_Address); - pragma Inline (CPP_Set_TSD); - pragma Inline (CPP_Inherit_DT); - pragma Inline (CPP_CW_Membership); - pragma Inline (CPP_Set_External_Tag); - pragma Inline (CPP_Get_External_Tag); - pragma Inline (CPP_Set_Expanded_Name); - pragma Inline (CPP_Set_Remotely_Callable); - pragma Inline (CPP_Get_Remotely_Callable); - pragma Inline (Displaced_This); - pragma Inline (TSD); + function External_Tag (T : Vtable_Ptr) return String + renames Ada.Tags.External_Tag; end Interfaces.CPP; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 0c02ff7d035..b86058801ce 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -175,11 +175,12 @@ package body Ch3 is if Token = Tok_Identifier then - -- Ada 2005 (AI-284): Compiling in Ada95 mode we notify - -- that interface, overriding, and synchronized are - -- new reserved words + -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE, + -- OVERRIDING, and SYNCHRONIZED are new reserved words. - if Ada_Version = Ada_95 then + if Ada_Version = Ada_95 + and then Warn_On_Ada_2005_Compatibility + then if Token_Name = Name_Overriding or else Token_Name = Name_Synchronized or else (Token_Name = Name_Interface @@ -235,7 +236,8 @@ package body Ch3 is -- PRIVATE_EXTENSION_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is - -- [abstract] new ancestor_SUBTYPE_INDICATION with private; + -- [abstract] new ancestor_SUBTYPE_INDICATION + -- [and INTERFACE_LIST] with private; -- TYPE_DEFINITION ::= -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION @@ -702,6 +704,7 @@ package body Ch3 is Typedef_Node := P_Interface_Type_Definition (Is_Synchronized => True); + Abstract_Present := True; case Saved_Token is when Tok_Task => @@ -1120,6 +1123,8 @@ package body Ch3 is -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- ACCESS_DEFINITION [:= EXPRESSION]; + -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; -- NUMBER_DECLARATION ::= @@ -1414,8 +1419,21 @@ package body Ch3 is Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); - Set_Object_Definition (Decl_Node, - P_Subtype_Indication (Not_Null_Present)); + if Token = Tok_Access then + if Ada_Version < Ada_05 then + Error_Msg_SP + ("generalized use of anonymous access types " & + "is an Ada 2005 extension"); + Error_Msg_SP + ("\unit must be compiled with -gnat05 switch"); + end if; + + Set_Object_Definition + (Decl_Node, P_Access_Definition (Not_Null_Present)); + else + Set_Object_Definition + (Decl_Node, P_Subtype_Indication (Not_Null_Present)); + end if; end if; if Token = Tok_Renames then @@ -1461,8 +1479,24 @@ package body Ch3 is else Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); - Set_Object_Definition (Decl_Node, - P_Subtype_Indication (Not_Null_Present)); + + -- Access definition (AI-406) or subtype indication. + + if Token = Tok_Access then + if Ada_Version < Ada_05 then + Error_Msg_SP + ("generalized use of anonymous access types " & + "is an Ada 2005 extension"); + Error_Msg_SP + ("\unit must be compiled with -gnat05 switch"); + end if; + + Set_Object_Definition + (Decl_Node, P_Access_Definition (Not_Null_Present)); + else + Set_Object_Definition + (Decl_Node, P_Subtype_Indication (Not_Null_Present)); + end if; end if; -- Array case @@ -1471,13 +1505,15 @@ package body Ch3 is Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); Set_Object_Definition (Decl_Node, P_Array_Type_Definition); - -- Ada 2005 (AI-254) + -- Ada 2005 (AI-254, AI-406) elsif Token = Tok_Not then -- OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]; + -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- ACCESS_DEFINITION [:= EXPRESSION]; -- OBJECT_RENAMING_DECLARATION ::= -- ... @@ -1496,16 +1532,18 @@ package body Ch3 is Acc_Node := P_Access_Definition (Not_Null_Present); if Token /= Tok_Renames then - Error_Msg_SC ("RENAMES expected"); - raise Error_Resync; - end if; + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Object_Definition (Decl_Node, Acc_Node); + goto init; - Scan; -- past renames - No_List; - Decl_Node := - New_Node (N_Object_Renaming_Declaration, Ident_Sloc); - Set_Access_Definition (Decl_Node, Acc_Node); - Set_Name (Decl_Node, P_Name); + else + Scan; -- past renames + No_List; + Decl_Node := + New_Node (N_Object_Renaming_Declaration, Ident_Sloc); + Set_Access_Definition (Decl_Node, Acc_Node); + Set_Name (Decl_Node, P_Name); + end if; else Type_Node := P_Subtype_Mark; @@ -1551,17 +1589,21 @@ package body Ch3 is Acc_Node := P_Access_Definition (Null_Exclusion_Present => False); + -- Object declaration with access definition, or renaming. + if Token /= Tok_Renames then - Error_Msg_SC ("RENAMES expected"); - raise Error_Resync; - end if; + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Object_Definition (Decl_Node, Acc_Node); + goto init; -- ??? is this really needed goes here anyway - Scan; -- past renames - No_List; - Decl_Node := - New_Node (N_Object_Renaming_Declaration, Ident_Sloc); - Set_Access_Definition (Decl_Node, Acc_Node); - Set_Name (Decl_Node, P_Name); + else + Scan; -- past renames + No_List; + Decl_Node := + New_Node (N_Object_Renaming_Declaration, Ident_Sloc); + Set_Access_Definition (Decl_Node, Acc_Node); + Set_Name (Decl_Node, P_Name); + end if; -- Subtype indication case @@ -1600,6 +1642,7 @@ package body Ch3 is -- Scan out initialization, allowed only for object declaration + <<init>> -- is this really needed ??? Init_Loc := Token_Ptr; Init_Expr := Init_Expr_Opt; @@ -1765,7 +1808,8 @@ package body Ch3 is Make_Private_Extension_Declaration (No_Location, Defining_Identifier => Empty, Subtype_Indication => Subtype_Indication (Typedef_Node), - Abstract_Present => Abstract_Present (Typedef_Node)); + Abstract_Present => Abstract_Present (Typedef_Node), + Interface_List => Interface_List (Typedef_Node)); Delete_Node (Typedef_Node); return Typedecl_Node; @@ -3823,6 +3867,20 @@ package body Ch3 is Check_Bad_Layout; P_Identifier_Declarations (Decls, Done, In_Spec); + -- Ada2005: A subprogram declaration can start with "not" or + -- "overriding". In older versions, "overriding" is handled + -- like an identifier, with the appropriate warning. + + when Tok_Not => + Check_Bad_Layout; + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); + Done := False; + + when Tok_Overriding => + Check_Bad_Layout; + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); + Done := False; + when Tok_Package => Check_Bad_Layout; Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 1697b359640..1908af5ca63 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -484,10 +484,14 @@ package Rtsfind is RE_Stream_Access, -- Ada.Streams.Stream_IO + RE_Addr_Ptr, -- Ada.Tags RE_CW_Membership, -- Ada.Tags + RE_IW_Membership, -- Ada.Tags + RE_Descendant_Tag, -- Ada.Tags RE_DT_Entry_Size, -- Ada.Tags RE_DT_Prologue_Size, -- Ada.Tags RE_External_Tag, -- Ada.Tags + RE_Get_Access_Level, -- Ada.Tags RE_Get_External_Tag, -- Ada.Tags RE_Get_Prim_Op_Address, -- Ada.Tags RE_Get_RC_Offset, -- Ada.Tags @@ -495,9 +499,13 @@ package Rtsfind is RE_Inherit_DT, -- Ada.Tags RE_Inherit_TSD, -- Ada.Tags RE_Internal_Tag, -- Ada.Tags + RE_Is_Descendant_At_Same_Level, -- Ada.Tags + RE_Register_Interface_Tag, -- Ada.Tags RE_Register_Tag, -- Ada.Tags + RE_Set_Access_Level, -- Ada.Tags RE_Set_Expanded_Name, -- Ada.Tags RE_Set_External_Tag, -- Ada.Tags + RE_Set_Offset_To_Top, -- Ada.Tags RE_Set_Prim_Op_Address, -- Ada.Tags RE_Set_RC_Offset, -- Ada.Tags RE_Set_Remotely_Callable, -- Ada.Tags @@ -505,6 +513,7 @@ package Rtsfind is RE_Tag_Error, -- Ada.Tags RE_TSD_Entry_Size, -- Ada.Tags RE_TSD_Prologue_Size, -- Ada.Tags + RE_Interface_Tag, -- Ada.Tags RE_Tag, -- Ada.Tags RE_Address_Array, -- Ada.Tags @@ -1582,10 +1591,14 @@ package Rtsfind is RE_Stream_Access => Ada_Streams_Stream_IO, + RE_Addr_Ptr => Ada_Tags, RE_CW_Membership => Ada_Tags, + RE_IW_Membership => Ada_Tags, + RE_Descendant_Tag => Ada_Tags, RE_DT_Entry_Size => Ada_Tags, RE_DT_Prologue_Size => Ada_Tags, RE_External_Tag => Ada_Tags, + RE_Get_Access_Level => Ada_Tags, RE_Get_External_Tag => Ada_Tags, RE_Get_Prim_Op_Address => Ada_Tags, RE_Get_RC_Offset => Ada_Tags, @@ -1593,9 +1606,13 @@ package Rtsfind is RE_Inherit_DT => Ada_Tags, RE_Inherit_TSD => Ada_Tags, RE_Internal_Tag => Ada_Tags, + RE_Is_Descendant_At_Same_Level => Ada_Tags, + RE_Register_Interface_Tag => Ada_Tags, RE_Register_Tag => Ada_Tags, + RE_Set_Access_Level => Ada_Tags, RE_Set_Expanded_Name => Ada_Tags, RE_Set_External_Tag => Ada_Tags, + RE_Set_Offset_To_Top => Ada_Tags, RE_Set_Prim_Op_Address => Ada_Tags, RE_Set_RC_Offset => Ada_Tags, RE_Set_Remotely_Callable => Ada_Tags, @@ -1603,6 +1620,7 @@ package Rtsfind is RE_Tag_Error => Ada_Tags, RE_TSD_Entry_Size => Ada_Tags, RE_TSD_Prologue_Size => Ada_Tags, + RE_Interface_Tag => Ada_Tags, RE_Tag => Ada_Tags, RE_Address_Array => Ada_Tags, diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 661ac7651bc..fd4392aa931 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -690,12 +690,13 @@ package body Sem_Ch12 is -- parent at the end of the instantiation (see Remove_Parent). type Instance_Env is record - Ada_Version : Ada_Version_Type; - Instantiated_Parent : Assoc; - Exchanged_Views : Elist_Id; - Hidden_Entities : Elist_Id; - Current_Sem_Unit : Unit_Number_Type; - Parent_Unit_Visible : Boolean := False; + Ada_Version : Ada_Version_Type; + Ada_Version_Explicit : Ada_Version_Type; + Instantiated_Parent : Assoc; + Exchanged_Views : Elist_Id; + Hidden_Entities : Elist_Id; + Current_Sem_Unit : Unit_Number_Type; + Parent_Unit_Visible : Boolean := False; end record; package Instance_Envs is new Table.Table ( @@ -1696,6 +1697,8 @@ package body Sem_Ch12 is end if; Formal := New_Copy (Pack_Id); + Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); + New_N := Copy_Generic_Node (Original_Node (Gen_Decl), Empty, Instantiating => True); @@ -2620,17 +2623,30 @@ package body Sem_Ch12 is -- generic is not a child unit of another generic, to avoid scope -- problems and the reinstallation of parent instances. - if Front_End_Inlining - and then Expander_Active + if Expander_Active and then (not Is_Child_Unit (Gen_Unit) or else not Is_Generic_Unit (Scope (Gen_Unit))) - and then (Is_In_Main_Unit (N) - or else In_Main_Context (Current_Scope)) - and then Nkind (Parent (N)) /= N_Compilation_Unit and then Might_Inline_Subp and then not Is_Actual_Pack then - Inline_Now := True; + if Front_End_Inlining + and then (Is_In_Main_Unit (N) + or else In_Main_Context (Current_Scope)) + and then Nkind (Parent (N)) /= N_Compilation_Unit + then + Inline_Now := True; + + -- In configurable_run_time mode we force the inlining of + -- predefined subprogram marked Inline_Always, to minimize + -- the use of the run-time library. + + elsif Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Gen_Decl))) + and then Configurable_Run_Time_Mode + and then Nkind (Parent (N)) /= N_Compilation_Unit + then + Inline_Now := True; + end if; end if; Needs_Body := @@ -2641,7 +2657,6 @@ package body Sem_Ch12 is or else Might_Inline_Subp) and then not Is_Actual_Pack and then not Inline_Now - and then (Operating_Mode = Generate_Code or else (Operating_Mode = Check_Semantics and then ASIS_Mode)); @@ -2657,12 +2672,11 @@ package body Sem_Ch12 is end if; -- If the current context is generic, and the package being - -- instantiated is declared within a formal package, there - -- is no body to instantiate until the enclosing generic is - -- instantiated, and there is an actual for the formal - -- package. If the formal package has parameters, we build a - -- regular package instance for it, that preceeds the original - -- formal package declaration. + -- instantiated is declared within a formal package, there is no + -- body to instantiate until the enclosing generic is instantiated + -- and there is an actual for the formal package. If the formal + -- package has parameters, we build regular package instance for + -- it, that preceeds the original formal package declaration. if In_Open_Scopes (Scope (Scope (Gen_Unit))) then declare @@ -2683,9 +2697,9 @@ package body Sem_Ch12 is end if; end; - -- If we are generating the calling stubs from the instantiation - -- of a generic RCI package, we will not use the body of the - -- generic package. + -- If we are generating the calling stubs from the instantiation of + -- a generic RCI package, we will not use the body of the generic + -- package. if Distribution_Stub_Mode = Generate_Caller_Stub_Body and then Is_Compilation_Unit (Defining_Entity (N)) @@ -2829,7 +2843,8 @@ package body Sem_Ch12 is end if; end if; - -- There is a problem with inlining here. + -- There is a problem with inlining here + -- More comments needed??? what problem Set_Unit (Parent (N), Act_Decl); Set_Parent_Spec (Act_Decl, Parent_Spec (N)); @@ -3500,6 +3515,30 @@ package body Sem_Ch12 is Check_Elab_Instantiation (N); end if; + if Is_Dispatching_Operation (Act_Decl_Id) + and then Ada_Version >= Ada_05 + then + declare + Formal : Entity_Id; + + begin + Formal := First_Formal (Act_Decl_Id); + while Present (Formal) loop + if Ekind (Etype (Formal)) = E_Anonymous_Access_Type + and then Is_Controlling_Formal (Formal) + and then not Can_Never_Be_Null (Formal) + then + Error_Msg_NE ("access parameter& is controlling,", + N, Formal); + Error_Msg_NE ("\corresponding parameter of & must be" + & " explicitly null-excluding", N, Gen_Id); + end if; + + Next_Formal (Formal); + end loop; + end; + end if; + Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); -- Subject to change, pending on if other pragmas are inherited ??? @@ -3507,7 +3546,6 @@ package body Sem_Ch12 is Validate_Categorization_Dependency (N, Act_Decl_Id); if not Is_Intrinsic_Subprogram (Act_Decl_Id) then - if not Generic_Separately_Compiled (Gen_Unit) then Inherit_Context (Gen_Decl, N); end if; @@ -3521,7 +3559,7 @@ package body Sem_Ch12 is or else Is_Inlined (Act_Decl_Id)) and then (Operating_Mode = Generate_Code or else (Operating_Mode = Check_Semantics - and then ASIS_Mode)) + and then ASIS_Mode)) and then (Expander_Active or else ASIS_Mode) and then not ABE_Is_Certain (N) and then not Is_Eliminated (Act_Decl_Id) @@ -3764,6 +3802,7 @@ package body Sem_Ch12 is (E1, E2 : Entity_Id) return Boolean is Ent : Entity_Id; + begin Ent := E2; while Present (Ent) loop @@ -5814,12 +5853,13 @@ package body Sem_Ch12 is Saved : Instance_Env; begin - Saved.Ada_Version := Ada_Version; - Saved.Instantiated_Parent := Current_Instantiated_Parent; - Saved.Exchanged_Views := Exchanged_Views; - Saved.Hidden_Entities := Hidden_Entities; - Saved.Current_Sem_Unit := Current_Sem_Unit; - Saved.Parent_Unit_Visible := Parent_Unit_Visible; + Saved.Ada_Version := Ada_Version; + Saved.Ada_Version_Explicit := Ada_Version_Explicit; + Saved.Instantiated_Parent := Current_Instantiated_Parent; + Saved.Exchanged_Views := Exchanged_Views; + Saved.Hidden_Entities := Hidden_Entities; + Saved.Current_Sem_Unit := Current_Sem_Unit; + Saved.Parent_Unit_Visible := Parent_Unit_Visible; Instance_Envs.Increment_Last; Instance_Envs.Table (Instance_Envs.Last) := Saved; @@ -6976,6 +7016,22 @@ package body Sem_Ch12 is Nam := Make_Identifier (Loc, Chars (Formal_Sub)); end if; + elsif Nkind (Specification (Formal)) = N_Procedure_Specification + and then Null_Present (Specification (Formal)) + then + -- Generate null body for procedure, for use in the instance + + Decl_Node := + Make_Subprogram_Body (Loc, + Specification => New_Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Make_Null_Statement (Loc)))); + + Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec)); + return Decl_Node; + else Error_Msg_Sloc := Sloc (Scope (Analyzed_S)); Error_Msg_NE @@ -8172,7 +8228,18 @@ package body Sem_Ch12 is Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T))); end if; - if not Is_Ancestor (Base_Type (Ancestor), Act_T) then + -- Ada 2005 (AI-251) + + if Ada_Version >= Ada_05 + and then Is_Interface (Ancestor) + then + if not Interface_Present_In_Ancestor (Act_T, Ancestor) then + Error_Msg_NE + ("(Ada 2005) expected type implementing & in instantiation", + Actual, Ancestor); + end if; + + elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then Error_Msg_NE ("expect type derived from & in instantiation", Actual, First_Subtype (Ancestor)); @@ -9061,6 +9128,7 @@ package body Sem_Ch12 is begin Ada_Version := Saved.Ada_Version; + Ada_Version_Explicit := Saved.Ada_Version_Explicit; if No (Current_Instantiated_Parent.Act_Id) then @@ -10060,16 +10128,18 @@ package body Sem_Ch12 is (Gen_Unit : Entity_Id; Act_Unit : Entity_Id) is - begin -- Regardless of the current mode, predefined units are analyzed in -- the most current Ada mode, and earlier version Ada checks do not -- apply to predefined units. + -- Why is this not using the routine Opt.Set_Opt_Config_Switches ??? + if Is_Internal_File_Name (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), Renamings_Included => True) then Ada_Version := Ada_Version_Type'Last; + Ada_Version_Explicit := Ada_Version_Explicit_Config; end if; Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 609871aa1c8..7ca349c337d 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -76,6 +76,12 @@ package body Sem_Ch3 is -- Local Subprograms -- ----------------------- + procedure Add_Interface_Tag_Components + (N : Node_Id; Typ : Entity_Id); + -- Ada 2005 (AI-251): Add the tag components corresponding to all the + -- abstract interface types implemented by a record type or a derived + -- record type. + procedure Build_Derived_Type (N : Node_Id; Parent_Type : Entity_Id; @@ -164,6 +170,23 @@ package body Sem_Ch3 is -- False is for an implicit derived full type for a type derived from a -- private type (see Build_Derived_Type). + procedure Collect_Interfaces + (N : Node_Id; + Derived_Type : Entity_Id); + -- Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type. + -- Collect the list of interfaces that are not already implemented by the + -- ancestors. This is the list of interfaces for which we must provide + -- additional tag components. + + procedure Complete_Subprograms_Derivation + (Partial_View : Entity_Id; + Derived_Type : Entity_Id); + -- Ada 2005 (AI-251): Used to complete type derivation of private tagged + -- types implementing interfaces. In this case some interface primitives + -- may have been overriden with the partial-view and, instead of + -- re-calculating them, they are included in the list of primitive + -- operations of the full-view. + function Inherit_Components (N : Node_Id; Parent_Base : Entity_Id; @@ -485,6 +508,12 @@ package body Sem_Ch3 is -- the appropriate semantic fields. If the full view of the parent is -- a record type, build constrained components of subtype. + procedure Derive_Interface_Subprograms + (Derived_Type : Entity_Id); + -- Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type. + -- Traverse the list of implemented interfaces and derive all their + -- subprograms. + procedure Derived_Standard_Character (N : Node_Id; Parent_Type : Entity_Id; @@ -503,10 +532,6 @@ package body Sem_Ch3 is -- defined in the N_Full_Type_Declaration node N, that is T is the -- derived type. - function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id; - -- Given a subtype indication S (which is really an N_Subtype_Indication - -- node or a plain N_Identifier), find the type of the subtype mark. - procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Insert each literal in symbol table, as an overloadable identifier -- Each enumeration type is mapped into a sequence of integers, and @@ -677,6 +702,21 @@ package body Sem_Ch3 is Error_Msg_N ("task entries cannot have access parameters", N); end if; + -- Ada 2005: for an object declaration, the corresponding anonymous + -- type is declared in the current scope. For access formals, access + -- components, and access discriminants, the scope is that of the + -- enclosing declaration, as set above. + + if Nkind (Related_Nod) = N_Object_Declaration then + Set_Scope (Anon_Type, Current_Scope); + end if; + + if All_Present (N) + and then Ada_Version >= Ada_05 + then + Error_Msg_N ("ALL is not permitted for anonymous access types", N); + end if; + -- Ada 2005 (AI-254): In case of anonymous access to subprograms -- call the corresponding semantic routine @@ -731,13 +771,13 @@ package body Sem_Ch3 is Set_Is_Access_Constant (Anon_Type, Constant_Present (N)); - -- The context is either a subprogram declaration or an access - -- discriminant, in a private or a full type declaration. In the case - -- of a subprogram, If the designated type is incomplete, the operation - -- will be a primitive operation of the full type, to be updated - -- subsequently. If the type is imported through a limited with clause, - -- it is not a primitive operation of the type (which is declared - -- elsewhere in some other scope). + -- The context is either a subprogram declaration, object declaration, + -- or an access discriminant, in a private or a full type declaration. + -- In the case of a subprogram, if the designated type is incomplete, + -- the operation will be a primitive operation of the full type, to be + -- updated subsequently. If the type is imported through a limited_with + -- clause, the subprogram is not a primitive operation of the type + -- (which is declared elsewhere in some other scope). if Ekind (Desig_Type) = E_Incomplete_Type and then not From_With_Type (Desig_Type) @@ -763,8 +803,42 @@ package body Sem_Ch3 is Desig_Type : constant Entity_Id := Create_Itype (E_Subprogram_Type, Parent (T_Def)); + D_Ityp : Node_Id := Associated_Node_For_Itype (Desig_Type); begin + -- Associate the Itype node with the inner full-type declaration + -- or subprogram spec. This is required to handle nested anonymous + -- declarations. For example: + + -- procedure P + -- (X : access procedure + -- (Y : access procedure + -- (Z : access T))) + + while Nkind (D_Ityp) /= N_Full_Type_Declaration + and then Nkind (D_Ityp) /= N_Procedure_Specification + and then Nkind (D_Ityp) /= N_Function_Specification + and then Nkind (D_Ityp) /= N_Object_Renaming_Declaration + and then Nkind (D_Ityp) /= N_Formal_Type_Declaration + loop + D_Ityp := Parent (D_Ityp); + pragma Assert (D_Ityp /= Empty); + end loop; + + Set_Associated_Node_For_Itype (Desig_Type, D_Ityp); + + if Nkind (D_Ityp) = N_Procedure_Specification + or else Nkind (D_Ityp) = N_Function_Specification + then + Set_Scope (Desig_Type, Scope (Defining_Unit_Name (D_Ityp))); + + elsif Nkind (D_Ityp) = N_Full_Type_Declaration + or else Nkind (D_Ityp) = N_Object_Renaming_Declaration + or else Nkind (D_Ityp) = N_Formal_Type_Declaration + then + Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp))); + end if; + if Nkind (T_Def) = N_Access_Function_Definition then Analyze (Subtype_Mark (T_Def)); Set_Etype (Desig_Type, Entity (Subtype_Mark (T_Def))); @@ -940,6 +1014,143 @@ package body Sem_Ch3 is Set_Is_Access_Constant (T, Constant_Present (Def)); end Access_Type_Declaration; + ---------------------------------- + -- Add_Interface_Tag_Components -- + ---------------------------------- + + procedure Add_Interface_Tag_Components + (N : Node_Id; + Typ : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Elmt : Elmt_Id; + Ext : Node_Id; + L : List_Id; + Last_Tag : Node_Id; + Comp : Node_Id; + + procedure Add_Tag (Iface : Entity_Id); + -- Comment required ??? + + ------------- + -- Add_Tag -- + ------------- + + procedure Add_Tag (Iface : Entity_Id) is + Def : Node_Id; + Tag : Entity_Id; + Decl : Node_Id; + + begin + pragma Assert (Is_Tagged_Type (Iface) + and then Is_Interface (Iface)); + + Def := + Make_Component_Definition (Loc, + Aliased_Present => True, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Interface_Tag), Loc)); + + Tag := Make_Defining_Identifier (Loc, New_Internal_Name ('V')); + + Decl := + Make_Component_Declaration (Loc, + Defining_Identifier => Tag, + Component_Definition => Def); + + Analyze_Component_Declaration (Decl); + + Set_Analyzed (Decl); + Set_Ekind (Tag, E_Component); + Set_Is_Limited_Record (Tag); + Set_Is_Tag (Tag); + Init_Component_Location (Tag); + + pragma Assert (Is_Frozen (Iface)); + + Set_DT_Entry_Count (Tag, + DT_Entry_Count (First_Entity (Iface))); + + if not Present (Last_Tag) then + Prepend (Decl, L); + else + Insert_After (Last_Tag, Decl); + end if; + + Last_Tag := Decl; + end Add_Tag; + + -- Start of procesing for Add_Interface_Tag_Components + + begin + if Ekind (Typ) /= E_Record_Type + or else not Present (Abstract_Interfaces (Typ)) + or else Is_Empty_Elmt_List (Abstract_Interfaces (Typ)) + then + return; + end if; + + if Present (Abstract_Interfaces (Typ)) then + + -- Find the current last tag + + if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then + Ext := Record_Extension_Part (Type_Definition (N)); + else + pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition); + Ext := Type_Definition (N); + end if; + + Last_Tag := Empty; + + if not (Present (Component_List (Ext))) then + Set_Null_Present (Ext, False); + L := New_List; + Set_Component_List (Ext, + Make_Component_List (Loc, + Component_Items => L, + Null_Present => False)); + else + if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then + L := Component_Items + (Component_List + (Record_Extension_Part + (Type_Definition (N)))); + else + L := Component_Items + (Component_List + (Type_Definition (N))); + end if; + + -- Find the last tag component + + Comp := First (L); + + while Present (Comp) loop + if Is_Tag (Defining_Identifier (Comp)) then + Last_Tag := Comp; + end if; + + Next (Comp); + end loop; + end if; + + -- At this point L references the list of components and Last_Tag + -- references the current last tag (if any). Now we add the tag + -- corresponding with all the interfaces that are not implemented + -- by the parent. + + pragma Assert (Present + (First_Elmt (Abstract_Interfaces (Typ)))); + + Elmt := First_Elmt (Abstract_Interfaces (Typ)); + while Present (Elmt) loop + Add_Tag (Node (Elmt)); + Next_Elmt (Elmt); + end loop; + end if; + end Add_Interface_Tag_Components; + ----------------------------------- -- Analyze_Component_Declaration -- ----------------------------------- @@ -1023,12 +1234,7 @@ package body Sem_Ch3 is T := Access_Definition (Related_Nod => N, N => Access_Definition (Component_Definition (N))); - - -- Ada 2005 (AI-230): In case of components that are anonymous - -- access types the level of accessibility depends on the enclosing - -- type declaration - - Set_Scope (T, Current_Scope); -- Ada 2005 (AI-230) + Set_Is_Local_Anonymous_Access (T); -- Ada 2005 (AI-254) @@ -1044,10 +1250,10 @@ package body Sem_Ch3 is -- If the subtype is a constrained subtype of the enclosing record, -- (which must have a partial view) the back-end does not handle - -- properly the recursion. Rewrite the component declaration with - -- an explicit subtype indication, which is acceptable to Gigi. We - -- can copy the tree directly because side effects have already been - -- removed from discriminant constraints. + -- properly the recursion. Rewrite the component declaration with an + -- explicit subtype indication, which is acceptable to Gigi. We can copy + -- the tree directly because side effects have already been removed from + -- discriminant constraints. if Ekind (T) = E_Access_Subtype and then Is_Entity_Name (Subtype_Indication (Component_Definition (N))) @@ -1127,9 +1333,8 @@ package body Sem_Ch3 is Null_Exclusion_Static_Checks (N); end if; - -- If this component is private (or depends on a private type), - -- flag the record type to indicate that some operations are not - -- available. + -- If this component is private (or depends on a private type), flag the + -- record type to indicate that some operations are not available. P := Private_Component (T); @@ -1742,7 +1947,13 @@ package body Sem_Ch3 is -- Protected objects with interrupt handlers must be at library level - if Has_Interrupt_Handler (T) then + -- Ada 2005: this test is not needed (and the corresponding clause + -- in the RM is removed) because accessibility checks are sufficient + -- to make handlers not at the library level illegal. + + if Has_Interrupt_Handler (T) + and then Ada_Version < Ada_05 + then Error_Msg_N ("interrupt object can only be declared at library level", Id); end if; @@ -2265,6 +2476,26 @@ package body Sem_Ch3 is Parent_Base : Entity_Id; begin + -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor + -- interfaces + + if Is_Non_Empty_List (Interface_List (N)) then + declare + I : Node_Id := First (Interface_List (N)); + T : Entity_Id; + begin + while Present (I) loop + T := Find_Type_Of_Subtype_Indic (I); + + if not Is_Interface (T) then + Error_Msg_NE ("(Ada 2005) & must be an interface", I, T); + end if; + + Next (I); + end loop; + end; + end if; + Generate_Definition (T); Enter_Name (T); @@ -3065,6 +3296,7 @@ package body Sem_Ch3 is Element_Type := Access_Definition (Related_Nod => Related_Id, N => Access_Definition (Component_Def)); + Set_Is_Local_Anonymous_Access (Element_Type); -- Ada 2005 (AI-230): In case of components that are anonymous -- access types the level of accessibility depends on the enclosing @@ -3218,7 +3450,7 @@ package body Sem_Ch3 is elsif Is_Abstract (Element_Type) then Error_Msg_N - ("The type of a component cannot be abstract", + ("the type of a component cannot be abstract", Subtype_Indication (Component_Def)); end if; @@ -4931,15 +5163,15 @@ package body Sem_Ch3 is Last_Discrim : Entity_Id; Constrs : Elist_Id; - Discs : Elist_Id := New_Elmt_List; + Discs : Elist_Id := New_Elmt_List; -- An empty Discs list means that there were no constraints in the -- subtype indication or that there was an error processing it. - Assoc_List : Elist_Id; - New_Discrs : Elist_Id; - New_Base : Entity_Id; - New_Decl : Node_Id; - New_Indic : Node_Id; + Assoc_List : Elist_Id; + New_Discrs : Elist_Id; + New_Base : Entity_Id; + New_Decl : Node_Id; + New_Indic : Node_Id; Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type); Discriminant_Specs : constant Boolean := @@ -4947,12 +5179,14 @@ package body Sem_Ch3 is Private_Extension : constant Boolean := (Nkind (N) = N_Private_Extension_Declaration); - Constraint_Present : Boolean; - Inherit_Discrims : Boolean := False; - - Save_Etype : Entity_Id; - Save_Discr_Constr : Elist_Id; - Save_Next_Entity : Entity_Id; + Constraint_Present : Boolean; + Has_Interfaces : Boolean := False; + Inherit_Discrims : Boolean := False; + Last_Inherited_Prim_Op : Elmt_Id; + Tagged_Partial_View : Entity_Id; + Save_Etype : Entity_Id; + Save_Discr_Constr : Elist_Id; + Save_Next_Entity : Entity_Id; begin if Ekind (Parent_Type) = E_Record_Type_With_Private @@ -5193,7 +5427,54 @@ package body Sem_Ch3 is Freeze_Before (N, Parent_Type); end if; - if Type_Access_Level (Derived_Type) /= Type_Access_Level (Parent_Type) + -- In Ada 2005 (AI-344), the restriction that a derived tagged type + -- cannot be declared at a deeper level than its parent type is + -- removed. The check on derivation within a generic body is also + -- relaxed, but there's a restriction that a derived tagged type + -- cannot be declared in a generic body if it's derived directly + -- or indirectly from a formal type of that generic. + + if Ada_Version >= Ada_05 then + if Present (Enclosing_Generic_Body (Derived_Type)) then + declare + Ancestor_Type : Entity_Id := Parent_Type; + + begin + -- Check to see if any ancestor of the derived type is a + -- formal type. + + while not Is_Generic_Type (Ancestor_Type) + and then Etype (Ancestor_Type) /= Ancestor_Type + loop + Ancestor_Type := Etype (Ancestor_Type); + end loop; + + -- If the derived type does have a formal type as an + -- ancestor, then it's an error if the derived type is + -- declared within the body of the generic unit that + -- declares the formal type in its generic formal part. It's + -- sufficient to check whether the ancestor type is declared + -- inside the same generic body as the derived type (such as + -- within a nested generic spec), in which case the + -- derivation is legal. If the formal type is declared + -- outside of that generic body, then it's guaranteed that + -- the derived type is declared within the generic body of + -- the generic unit declaring the formal type. + + if Is_Generic_Type (Ancestor_Type) + and then Enclosing_Generic_Body (Ancestor_Type) /= + Enclosing_Generic_Body (Derived_Type) + then + Error_Msg_NE + ("parent type of& must not be descendant of formal type" + & " of an enclosing generic body", + Indic, Derived_Type); + end if; + end; + end if; + + elsif Type_Access_Level (Derived_Type) /= + Type_Access_Level (Parent_Type) and then not Is_Generic_Type (Derived_Type) then if Is_Controlled (Parent_Type) then @@ -5223,6 +5504,29 @@ package body Sem_Ch3 is end if; end if; + -- Ada 2005 (AI-251) + + if Ada_Version = Ada_05 + and then Is_Tagged + then + + -- "The declaration of a specific descendant of an interface type + -- freezes the interface type" (RM 13.14). + + declare + Iface : Node_Id; + begin + if Is_Non_Empty_List (Interface_List (Type_Def)) then + Iface := First (Interface_List (Type_Def)); + + while Present (Iface) loop + Freeze_Before (N, Etype (Iface)); + Next (Iface); + end loop; + end if; + end; + end if; + -- STEP 1b : preliminary cleanup of the full view of private types -- If the type is already marked as having discriminants, then it's the @@ -5424,6 +5728,17 @@ package body Sem_Ch3 is Set_Is_Tagged_Type (Derived_Type, Is_Tagged); Set_Stored_Constraint (Derived_Type, No_Elist); + -- Ada 2005 (AI-251): Private type-declarations can implement interfaces + -- but cannot be interfaces + + if not Private_Extension + and then Ekind (Derived_Type) /= E_Private_Type + and then Ekind (Derived_Type) /= E_Limited_Private_Type + then + Set_Is_Interface (Derived_Type, Interface_Present (Type_Def)); + Set_Abstract_Interfaces (Derived_Type, No_Elist); + end if; + -- Fields inherited from the Parent_Type Set_Discard_Names @@ -5507,6 +5822,143 @@ package body Sem_Ch3 is (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs)); end if; + -- Ada 2005 (AI-251): Look for the partial view of tagged types + -- declared in the private part. This will be used 1) to check that + -- the set of interfaces in both views is equal, and 2) to complete + -- the derivation of subprograms covering interfaces. + + Tagged_Partial_View := Empty; + + if Has_Private_Declaration (Derived_Type) then + Tagged_Partial_View := Next_Entity (Derived_Type); + loop + exit when Has_Private_Declaration (Tagged_Partial_View) + and then Full_View (Tagged_Partial_View) = Derived_Type; + + Next_Entity (Tagged_Partial_View); + end loop; + end if; + + -- Ada 2005 (AI-251): Collect the whole list of implemented + -- interfaces. + + if Ada_Version >= Ada_05 then + Set_Abstract_Interfaces (Derived_Type, New_Elmt_List); + + if Nkind (N) = N_Private_Extension_Declaration then + Collect_Interfaces (N, Derived_Type); + else + Collect_Interfaces (Type_Definition (N), Derived_Type); + end if; + + -- Check that the full view and the partial view agree + -- in the set of implemented interfaces + + if Has_Private_Declaration (Derived_Type) + and then Present (Abstract_Interfaces (Derived_Type)) + and then not Is_Empty_Elmt_List + (Abstract_Interfaces (Derived_Type)) + then + declare + N_Partial : constant Node_Id := Parent (Tagged_Partial_View); + N_Full : constant Node_Id := Parent (Derived_Type); + + Iface_Partial : Entity_Id; + Iface_Full : Entity_Id; + Num_Ifaces_Partial : Natural := 0; + Num_Ifaces_Full : Natural := 0; + Same_Interfaces : Boolean := True; + + begin + -- Count the interfaces implemented by the partial view + + if not Is_Empty_List (Interface_List (N_Partial)) then + Iface_Partial := First (Interface_List (N_Partial)); + + while Present (Iface_Partial) loop + Num_Ifaces_Partial := Num_Ifaces_Partial + 1; + Next (Iface_Partial); + end loop; + end if; + + -- Take into account the case in which the partial + -- view is a directly derived from an interface + + if Is_Interface (Etype + (Defining_Identifier (N_Partial))) + then + Num_Ifaces_Partial := Num_Ifaces_Partial + 1; + end if; + + -- Count the interfaces implemented by the full view + + if not Is_Empty_List (Interface_List + (Type_Definition (N_Full))) + then + Iface_Full := First (Interface_List + (Type_Definition (N_Full))); + + while Present (Iface_Full) loop + Num_Ifaces_Full := Num_Ifaces_Full + 1; + Next (Iface_Full); + end loop; + end if; + + -- Take into account the case in which the full + -- view is a directly derived from an interface + + if Is_Interface (Etype + (Defining_Identifier (N_Full))) + then + Num_Ifaces_Full := Num_Ifaces_Full + 1; + end if; + + if Num_Ifaces_Full > 0 + and then Num_Ifaces_Full = Num_Ifaces_Partial + then + + -- Check that the full-view and the private-view have + -- the same list of interfaces + + Iface_Full := First (Interface_List + (Type_Definition (N_Full))); + + while Present (Iface_Full) loop + Iface_Partial := First (Interface_List (N_Partial)); + + while Present (Iface_Partial) + and then Etype (Iface_Partial) /= Etype (Iface_Full) + loop + Next (Iface_Partial); + end loop; + + -- If not found we check if the partial view is a + -- direct derivation of the interface. + + if not Present (Iface_Partial) + and then + Etype (Tagged_Partial_View) /= Etype (Iface_Full) + then + Same_Interfaces := False; + exit; + end if; + + Next (Iface_Full); + end loop; + end if; + + if Num_Ifaces_Partial /= Num_Ifaces_Full + or else not Same_Interfaces + then + Error_Msg_N + ("(Ada 2005) full declaration and private declaration" + & " must have the same list of interfaces", + Derived_Type); + end if; + end; + end if; + end if; + else Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base)); Set_Has_Non_Standard_Rep @@ -5596,6 +6048,13 @@ package body Sem_Ch3 is Expand_Record_Extension (Derived_Type, Type_Def); + -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the + -- implemented interfaces if we are in expansion mode + + if Expander_Active then + Add_Interface_Tag_Components (N, Derived_Type); + end if; + -- Analyze the record extension Record_Type_Definition @@ -5613,8 +6072,140 @@ package body Sem_Ch3 is -- derived freeze if necessary. Set_Has_Delayed_Freeze (Derived_Type); + if Derive_Subps then Derive_Subprograms (Parent_Type, Derived_Type); + + -- Ada 2005 (AI-251): Check if this tagged type implements abstract + -- interfaces + + Has_Interfaces := False; + + if Is_Tagged_Type (Derived_Type) then + declare + E : Entity_Id; + + begin + E := Derived_Type; + loop + if Is_Interface (E) + or else (Present (Abstract_Interfaces (E)) + and then + not Is_Empty_Elmt_List (Abstract_Interfaces (E))) + then + Has_Interfaces := True; + exit; + end if; + + exit when Etype (E) = E + + -- Protect the frontend against wrong source + + or else Etype (E) = Derived_Type; + + E := Etype (E); + end loop; + end; + end if; + + -- Ada 2005 (AI-251): Keep separate the management of tagged types + -- implementing interfaces + + if Is_Tagged_Type (Derived_Type) + and then Has_Interfaces + then + -- Complete the decoration of private tagged types + + if Present (Tagged_Partial_View) then + Complete_Subprograms_Derivation + (Partial_View => Tagged_Partial_View, + Derived_Type => Derived_Type); + end if; + + -- Ada 2005 (AI-251): Derive the interface subprograms of all the + -- implemented interfaces and check if some of the subprograms + -- inherited from the ancestor cover some interface subprogram. + + if not Present (Tagged_Partial_View) then + declare + Subp_Elmt : Elmt_Id := First_Elmt + (Primitive_Operations + (Derived_Type)); + Iface_Subp_Elmt : Elmt_Id; + Subp : Entity_Id; + Iface_Subp : Entity_Id; + Is_Interface_Subp : Boolean; + + begin + -- Ada 2005 (AI-251): Remember the entity corresponding to + -- the last inherited primitive operation. This is required + -- to check if some of the inherited subprograms covers some + -- of the new interfaces. + + Last_Inherited_Prim_Op := No_Elmt; + + while Present (Subp_Elmt) loop + Last_Inherited_Prim_Op := Subp_Elmt; + Next_Elmt (Subp_Elmt); + end loop; + + -- Ada 2005 (AI-251): Derive subprograms in abstract + -- interfaces + + Derive_Interface_Subprograms (Derived_Type); + + -- Ada 2005 (AI-251): Check if some of the inherited + -- subprograms cover some of the new interfaces. + + if Present (Last_Inherited_Prim_Op) then + Iface_Subp_Elmt := Next_Elmt (Last_Inherited_Prim_Op); + while Present (Iface_Subp_Elmt) loop + Subp_Elmt := First_Elmt (Primitive_Operations + (Derived_Type)); + while Subp_Elmt /= Last_Inherited_Prim_Op loop + Subp := Node (Subp_Elmt); + Iface_Subp := Node (Iface_Subp_Elmt); + + Is_Interface_Subp := + Present (Alias (Subp)) + and then Present (DTC_Entity (Alias (Subp))) + and then Is_Interface (Scope + (DTC_Entity + (Alias (Subp)))); + + if Chars (Subp) = Chars (Iface_Subp) + and then not Is_Interface_Subp + and then not Is_Abstract (Subp) + and then Type_Conformant (Iface_Subp, Subp) + then + Check_Dispatching_Operation + (Subp => Subp, + Old_Subp => Iface_Subp); + + -- Traverse the list of aliased subprograms + + declare + E : Entity_Id := Alias (Subp); + begin + while Present (Alias (E)) loop + E := Alias (E); + end loop; + Set_Alias (Subp, E); + end; + + Set_Has_Delayed_Freeze (Subp); + exit; + end if; + + Next_Elmt (Subp_Elmt); + end loop; + + Next_Elmt (Iface_Subp_Elmt); + end loop; + end if; + end; + end if; + end if; end if; -- If we have a private extension which defines a constrained derived @@ -6424,6 +7015,16 @@ package body Sem_Ch3 is Error_Msg_NE ("type must be declared abstract or & overridden", T, Subp); + + -- Ada 2005 (AI-345): Protected or task type implementing + -- abstract interfaces + + elsif Is_Concurrent_Record_Type (T) + and then Present (Abstract_Interfaces (T)) + then + Error_Msg_NE + ("interface subprogram & must be overridden", + T, Subp); end if; else Error_Msg_NE @@ -6475,6 +7076,11 @@ package body Sem_Ch3 is -- ??? Also need to check components of record extensions, but not -- components of protected types (which are always limited). + -- Ada 2005: AI-363 relaxes this rule, to allow heap objects + -- of such types to be unconstrained. This is safe because it is + -- illegal to create access subtypes to such types with explicit + -- discriminant constraints. + if not Is_Limited_Type (T) then if Ekind (T) = E_Record_Type then C := First_Component (T); @@ -6483,6 +7089,7 @@ package body Sem_Ch3 is and then Has_Discriminants (Etype (C)) and then not Is_Constrained (Etype (C)) and then not In_Instance + and then Ada_Version < Ada_05 then Error_Msg_N ("aliased component must be constrained ('R'M 3.6(11))", @@ -6880,6 +7487,67 @@ package body Sem_Ch3 is Resolve (Bound, Standard_Float); end Check_Real_Bound; + ------------------------ + -- Collect_Interfaces -- + ------------------------ + + procedure Collect_Interfaces (N : Node_Id; Derived_Type : Entity_Id) is + I : Node_Id; + + procedure Add_Interface (Iface : Entity_Id); + + procedure Add_Interface (Iface : Entity_Id) is + Elmt : Elmt_Id := First_Elmt (Abstract_Interfaces (Derived_Type)); + + begin + while Present (Elmt) and then Node (Elmt) /= Iface loop + Next_Elmt (Elmt); + end loop; + + if not Present (Elmt) then + Append_Elmt (Node => Iface, + To => Abstract_Interfaces (Derived_Type)); + end if; + end Add_Interface; + + begin + pragma Assert (False + or else Nkind (N) = N_Derived_Type_Definition + or else Nkind (N) = N_Record_Definition + or else Nkind (N) = N_Private_Extension_Declaration); + + -- Traverse the graph of ancestor interfaces + + if Is_Non_Empty_List (Interface_List (N)) then + I := First (Interface_List (N)); + + while Present (I) loop + + -- Protect against wrong usages. Example: + -- type I is interface; + -- type O is tagged null record; + -- type Wrong is new I and O with null record; + + if Is_Interface (Etype (I)) then + + -- Do not add the interface when the derived type already + -- implements this interface + + if not Interface_Present_In_Ancestor (Derived_Type, + Etype (I)) + then + Collect_Interfaces + (Type_Definition (Parent (Etype (I))), + Derived_Type); + Add_Interface (Etype (I)); + end if; + end if; + + Next (I); + end loop; + end if; + end Collect_Interfaces; + ------------------------------ -- Complete_Private_Subtype -- ------------------------------ @@ -7091,6 +7759,77 @@ package body Sem_Ch3 is end if; end Complete_Private_Subtype; + ------------------------------------- + -- Complete_Subprograms_Derivation -- + ------------------------------------- + + procedure Complete_Subprograms_Derivation + (Partial_View : Entity_Id; + Derived_Type : Entity_Id) + is + Result : constant Elist_Id := New_Elmt_List; + Elmt_P : Elmt_Id := No_Elmt; + Elmt_D : Elmt_Id; + Found : Boolean; + Prim_Op : Entity_Id; + E : Entity_Id; + + begin + if Is_Tagged_Type (Partial_View) then + Elmt_P := First_Elmt (Primitive_Operations (Partial_View)); + end if; + + -- Inherit primitives declared with the partial-view + + while Present (Elmt_P) loop + Prim_Op := Node (Elmt_P); + Found := False; + Elmt_D := First_Elmt (Primitive_Operations (Derived_Type)); + while Present (Elmt_D) loop + if Node (Elmt_D) = Prim_Op then + Found := True; + exit; + end if; + + Next_Elmt (Elmt_D); + end loop; + + if not Found then + Append_Elmt (Prim_Op, Result); + + -- Search for entries associated with abstract interfaces that + -- have been covered by this primitive + + Elmt_D := First_Elmt (Primitive_Operations (Derived_Type)); + while Present (Elmt_D) loop + E := Node (Elmt_D); + + if Chars (E) = Chars (Prim_Op) + and then Is_Abstract (E) + and then Present (Alias (E)) + and then Present (DTC_Entity (Alias (E))) + and then Is_Interface (Scope (DTC_Entity (Alias (E)))) + then + Remove_Elmt (Primitive_Operations (Derived_Type), Elmt_D); + end if; + + Next_Elmt (Elmt_D); + end loop; + end if; + + Next_Elmt (Elmt_P); + end loop; + + -- Append the entities of the full-view to the list of primitives + -- of derived_type + + Elmt_D := First_Elmt (Result); + while Present (Elmt_D) loop + Append_Elmt (Node (Elmt_D), Primitive_Operations (Derived_Type)); + Next_Elmt (Elmt_D); + end loop; + end Complete_Subprograms_Derivation; + ---------------------------- -- Constant_Redeclaration -- ---------------------------- @@ -7190,9 +7929,18 @@ package body Sem_Ch3 is then Enter_Name (Id); - -- Verify that types of both declarations match + -- Verify that types of both declarations match, or else that both types + -- are anonymous access types whose designated subtypes statically match + -- (as allowed in Ada 2005 by AI-385). - elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) then + elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) + and then + (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type + or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type + or else not Subtypes_Statically_Match + (Designated_Type (Etype (Prev)), + Designated_Type (Etype (New_T)))) + then Error_Msg_Sloc := Sloc (Prev); Error_Msg_N ("type does not match declaration#", N); Set_Full_View (Prev, Id); @@ -7257,6 +8005,24 @@ package body Sem_Ch3 is Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod); Constraint_OK : Boolean := True; + function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; + -- Simple predicate to test for defaulted discriminants + -- Shouldn't this be in sem_util??? + + --------------------------------- + -- Has_Defaulted_Discriminants -- + --------------------------------- + + function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is + begin + return Has_Discriminants (Typ) + and then Present (First_Discriminant (Typ)) + and then Present + (Discriminant_Default_Value (First_Discriminant (Typ))); + end Has_Defaulted_Discriminants; + + -- Start of processing for Constrain_Access + begin if Is_Array_Type (Desig_Type) then Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P'); @@ -7296,6 +8062,9 @@ package body Sem_Ch3 is -- a derivation from a private type) has no discriminants. -- (Defect Report 8652/0008, Technical Corrigendum 1, checked -- by ACATS B371001). + -- Rule updated for Ada 2005: the private type is said to have + -- a constrained partial view, given that objects of the type + -- can be declared. declare Pack : constant Node_Id := @@ -7324,8 +8093,9 @@ package body Sem_Ch3 is then if No (Discriminant_Specifications (Decl)) then Error_Msg_N - ("cannot constrain general access type " & - "if designated type has unconstrained view", S); + ("cannot constrain general access type if " & + "designated type has constrained partial view", + S); end if; exit; @@ -7376,6 +8146,31 @@ package body Sem_Ch3 is Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T)); Conditional_Delay (Def_Id, T); + + -- AI-363 : Subtypes of general access types whose designated + -- types have default discriminants are disallowed. In instances, + -- the rule has to be checked against the actual, of which T is + -- the subtype. In a generic body, the rule is checked assuming + -- that the actual type has defaulted discriminants. + + if Ada_Version >= Ada_05 then + if Ekind (Base_Type (T)) = E_General_Access_Type + and then Has_Defaulted_Discriminants (Desig_Type) + then + Error_Msg_N + ("access subype of general access type not allowed", S); + Error_Msg_N ("\ when discriminants have defaults", S); + + elsif Is_Access_Type (T) + and then Is_Generic_Type (Desig_Type) + and then Has_Discriminants (Desig_Type) + and then In_Package_Body (Current_Scope) + then + Error_Msg_N ("access subtype not allowed in generic body", S); + Error_Msg_N + ("\ wben designated type is a discriminated formal", S); + end if; + end if; end Constrain_Access; --------------------- @@ -7461,6 +8256,8 @@ package body Sem_Ch3 is if Constraint_OK then Set_First_Index (Def_Id, First (Constraints (C))); + else + Set_First_Index (Def_Id, First_Index (T)); end if; Set_Is_Constrained (Def_Id, True); @@ -9047,6 +9844,58 @@ package body Sem_Ch3 is Set_Is_Constrained (T); end Decimal_Fixed_Point_Type_Declaration; + --------------------------------- + -- Derive_Interface_Subprogram -- + --------------------------------- + + procedure Derive_Interface_Subprograms (Derived_Type : Entity_Id) is + + procedure Do_Derivation (T : Entity_Id); + -- This inner subprograms is used to climb to the ancestors. + -- It is needed to add the derivations to the Derived_Type. + + procedure Do_Derivation (T : Entity_Id) is + Etyp : constant Entity_Id := Etype (T); + AI : Elmt_Id; + + begin + if Etyp /= T + and then Is_Interface (Etyp) + then + Do_Derivation (Etyp); + end if; + + if Present (Abstract_Interfaces (T)) + and then not Is_Empty_Elmt_List (Abstract_Interfaces (T)) + then + AI := First_Elmt (Abstract_Interfaces (T)); + + while Present (AI) loop + Derive_Subprograms + (Parent_Type => Node (AI), + Derived_Type => Derived_Type, + Is_Interface_Derivation => True); + + Next_Elmt (AI); + end loop; + end if; + end Do_Derivation; + + begin + Do_Derivation (Derived_Type); + + -- At this point the list of primitive operations of Derived_Type + -- contains the entities corresponding to all the subprograms of all the + -- implemented interfaces. If N interfaces have subprograms with the + -- same profile we have N entities in this list because each one must be + -- allocated in its corresponding virtual table. + + -- Its alias attribute references its original interface subprogram. + -- When overriden, the alias attribute is later saved in the + -- Abstract_Interface_Alias attribute. + + end Derive_Interface_Subprograms; + ----------------------- -- Derive_Subprogram -- ----------------------- @@ -9430,9 +10279,10 @@ package body Sem_Ch3 is ------------------------ procedure Derive_Subprograms - (Parent_Type : Entity_Id; - Derived_Type : Entity_Id; - Generic_Actual : Entity_Id := Empty) + (Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Generic_Actual : Entity_Id := Empty; + Is_Interface_Derivation : Boolean := False) is Op_List : constant Elist_Id := Collect_Primitive_Operations (Parent_Type); @@ -9468,7 +10318,13 @@ package body Sem_Ch3 is Subp := Node (Elmt); if Ekind (Subp) /= E_Enumeration_Literal then - if No (Generic_Actual) then + if Is_Interface_Derivation then + if not Is_Predefined_Dispatching_Operation (Subp) then + Derive_Subprogram + (New_Subp, Subp, Derived_Type, Parent_Base); + end if; + + elsif No (Generic_Actual) then Derive_Subprogram (New_Subp, Subp, Derived_Type, Parent_Base); @@ -9567,6 +10423,7 @@ package body Sem_Ch3 is Is_Completion : Boolean) is Def : constant Node_Id := Type_Definition (N); + Iface_Def : Node_Id; Indic : constant Node_Id := Subtype_Indication (Def); Extension : constant Node_Id := Record_Extension_Part (Def); Parent_Type : Entity_Id; @@ -9608,6 +10465,92 @@ package body Sem_Ch3 is begin Parent_Type := Find_Type_Of_Subtype_Indic (Indic); + -- Ada 2005 (AI-251): In case of interface derivation check that the + -- parent is also an interface. + + if Interface_Present (Def) then + if not Is_Interface (Parent_Type) then + Error_Msg_NE ("(Ada 2005) & must be an interface", + Indic, Parent_Type); + + else + Iface_Def := Type_Definition (Parent (Parent_Type)); + + -- Ada 2005 (AI-251): Limited interfaces can only inherit from + -- other limited interfaces. + + if Limited_Present (Def) then + if Limited_Present (Iface_Def) then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) limited interface cannot" & + " inherit from protected interface", Indic); + + elsif Synchronized_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) limited interface cannot" & + " inherit from synchronized interface", Indic); + + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) limited interface cannot" & + " inherit from task interface", Indic); + + else + Error_Msg_N ("(Ada 2005) limited interface cannot" & + " inherit from non-limited interface", Indic); + end if; + + -- Ada 2005 (AI-345): Non-limited interfaces can only inherit + -- from non-limited or limited interfaces. + + elsif not Protected_Present (Def) + and then not Synchronized_Present (Def) + and then not Task_Present (Def) + then + if Limited_Present (Iface_Def) then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) non-limited interface cannot" & + " inherit from protected interface", Indic); + + elsif Synchronized_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) non-limited interface cannot" & + " inherit from synchronized interface", Indic); + + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) non-limited interface cannot" & + " inherit from task interface", Indic); + + else + null; + end if; + end if; + end if; + end if; + + -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor + -- interfaces + + if Is_Tagged_Type (Parent_Type) + and then Is_Non_Empty_List (Interface_List (Def)) + then + declare + I : Node_Id := First (Interface_List (Def)); + T : Entity_Id; + begin + while Present (I) loop + T := Find_Type_Of_Subtype_Indic (I); + + if not Is_Interface (T) then + Error_Msg_NE ("(Ada 2005) & must be an interface", I, T); + end if; + + Next (I); + end loop; + end; + end if; + if Parent_Type = Any_Type or else Etype (Parent_Type) = Any_Type or else (Is_Class_Wide_Type (Parent_Type) @@ -10009,6 +10952,14 @@ package body Sem_Ch3 is ("completion of nonlimited type cannot be limited", N); end if; + -- Ada 2005 (AI-251): Private extension declaration of a + -- task type. This case arises with tasks implementing interfaces + + elsif Nkind (N) = N_Task_Type_Declaration + or else Nkind (N) = N_Protected_Type_Declaration + then + null; + elsif Nkind (N) /= N_Full_Type_Declaration or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition then @@ -10078,6 +11029,8 @@ package body Sem_Ch3 is if Is_Type (Prev) and then (Is_Tagged_Type (Prev) or else Present (Class_Wide_Type (Prev))) + and then (Nkind (N) /= N_Task_Type_Declaration + and then Nkind (N) /= N_Protected_Type_Declaration) then -- The full declaration is either a tagged record or an -- extension otherwise this is an error @@ -10183,11 +11136,19 @@ package body Sem_Ch3 is and then No (Expression (P)) then null; - else Insert_Actions (Obj_Def, Freeze_Entity (T, Sloc (P))); end if; + -- Ada 2005 AI-406: the object definition in an object declaration + -- can be an access definition. + + elsif Def_Kind = N_Access_Definition then + T := Access_Definition (Related_Nod, Obj_Def); + Set_Is_Local_Anonymous_Access (T); + + -- comment here, what cases ??? + else T := Process_Subtype (Obj_Def, Related_Nod); end if; @@ -10850,7 +11811,17 @@ package body Sem_Ch3 is Component := First_Entity (Parent_Base); while Present (Component) loop - if Ekind (Component) /= E_Component + + -- Ada 2005 (AI-251): Do not inherit tags corresponding with the + -- interfaces of the parent + + if Ekind (Component) = E_Component + and then Is_Tag (Component) + and then Etype (Component) = RTE (RE_Interface_Tag) + then + null; + + elsif Ekind (Component) /= E_Component or else Chars (Component) = Name_uParent then null; @@ -11812,6 +12783,18 @@ package body Sem_Ch3 is if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then Discr_Type := Access_Definition (N, Discriminant_Type (Discr)); + -- Ada 2005 (AI-230): Access discriminants are now allowed for + -- nonlimited types, and are treated like other components of + -- anonymous access types in terms of accessibility. + + if not Is_Concurrent_Type (Current_Scope) + and then not Is_Concurrent_Record_Type (Current_Scope) + and then not Is_Limited_Record (Current_Scope) + and then Ekind (Current_Scope) /= E_Limited_Private_Type + then + Set_Is_Local_Anonymous_Access (Discr_Type); + end if; + -- Ada 2005 (AI-254) if Present (Access_To_Subprogram_Definition @@ -11981,6 +12964,34 @@ package body Sem_Ch3 is Full_Parent : Entity_Id; Full_Indic : Node_Id; + function Find_Interface_In_Descendant + (Typ : Entity_Id) return Entity_Id; + -- Find an implemented interface in the derivation chain of Typ + + ---------------------------------- + -- Find_Interface_In_Descendant -- + ---------------------------------- + + function Find_Interface_In_Descendant + (Typ : Entity_Id) return Entity_Id + is + T : Entity_Id; + + begin + T := Typ; + while T /= Etype (T) loop + if Is_Interface (Etype (T)) then + return Etype (T); + end if; + + T := Etype (T); + end loop; + + return Empty; + end Find_Interface_In_Descendant; + + -- Start of processing for Process_Full_View + begin -- First some sanity checks that must be done after semantic -- decoration of the full view and thus cannot be placed with other @@ -12017,6 +13028,54 @@ package body Sem_Ch3 is Error_Msg_N ("generic type cannot have a completion", Full_T); end if; + -- Ada 2005 (AI-396): A full view shall be a descendant of an + -- interface type if and only if the corresponding partial view + -- (if any) is also a descendant of the interface type, or if + -- the partial view is untagged. + + if Ada_Version >= Ada_05 + and then Is_Tagged_Type (Full_T) + then + declare + Iface : Entity_Id; + Iface_Def : Node_Id; + + begin + Iface := Find_Interface_In_Descendant (Full_T); + + if Present (Iface) then + Iface_Def := Type_Definition (Parent (Iface)); + end if; + + -- The full view derives from an interface descendant, but the + -- partial view does not share the same tagged type. + + if Present (Iface) + and then Is_Tagged_Type (Priv_T) + and then Etype (Full_T) /= Etype (Priv_T) + then + Error_Msg_N ("(Ada 2005) tagged partial view cannot be " & + "completed by a type that implements an " & + "interface", Priv_T); + end if; + + -- The full view derives from a limited, protected, + -- synchronized or task interface descendant, but the + -- partial view is not labeled as limited. + + if Present (Iface) + and then (Limited_Present (Iface_Def) + or Protected_Present (Iface_Def) + or Synchronized_Present (Iface_Def) + or Task_Present (Iface_Def)) + and then not Limited_Present (Parent (Priv_T)) + then + Error_Msg_N ("(Ada 2005) non-limited private type cannot be " & + "completed by a limited type", Priv_T); + end if; + end; + end if; + if Is_Tagged_Type (Priv_T) and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration and then Is_Derived_Type (Full_T) @@ -12044,9 +13103,24 @@ package body Sem_Ch3 is return; elsif not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) then - Error_Msg_N - ("parent of full type must descend from parent" - & " of private extension", Full_Indic); + + -- Ada 2005 (AI-251): No error needed if the immediate + -- ancestor of the partial view is an interface + -- + -- Example: + -- + -- type PT1 is new I1 with private; + -- private + -- type PT1 is new T and I1 with null record; + + if Is_Interface (Base_Type (Priv_Parent)) then + null; + + else + Error_Msg_N + ("parent of full type must descend from parent" + & " of private extension", Full_Indic); + end if; -- Check the rules of 7.3(10): if the private extension inherits -- known discriminants, then the full type must also inherit those @@ -12124,7 +13198,7 @@ package body Sem_Ch3 is then Error_Msg_N ("full view must define a constrained type if partial view" - & " has no discriminants", Full_T); + & " has no discriminants", Full_T); end if; -- ??????? Do we implement the following properly ????? @@ -12144,6 +13218,22 @@ package body Sem_Ch3 is end if; end if; + -- Ada 2005 AI-363: if the full view has discriminants with + -- defaults, it is illegal to declare constrained access subtypes + -- whose designated type is the current type. This allows objects + -- of the type that are declared in the heap to be unconstrained. + + if not Has_Unknown_Discriminants (Priv_T) + and then not Has_Discriminants (Priv_T) + and then Has_Discriminants (Full_T) + and then + Present + (Discriminant_Default_Value (First_Discriminant (Full_T))) + then + Set_Has_Constrained_Partial_View (Full_T); + Set_Has_Constrained_Partial_View (Priv_T); + end if; + -- Create a full declaration for all its subtypes recorded in -- Private_Dependents and swap them similarly to the base type. These -- are subtypes that have been define before the full declaration of @@ -12748,7 +13838,7 @@ package body Sem_Ch3 is Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); - -- Set Ekind of orphan itype, to prevent cascaded errors. + -- Set Ekind of orphan itype, to prevent cascaded errors if Present (Def_Id) then Set_Ekind (Def_Id, Ekind (Any_Type)); @@ -12848,46 +13938,390 @@ package body Sem_Ch3 is N : Node_Id; Prev : Entity_Id) is - Def : constant Node_Id := Type_Definition (N); + Loc : constant Source_Ptr := Sloc (N); + Def : constant Node_Id := Type_Definition (N); + Inc_T : Entity_Id := Empty; Is_Tagged : Boolean; Tag_Comp : Entity_Id; - begin - -- The flag Is_Tagged_Type might have already been set by Find_Type_Name - -- if it detected an error for declaration T. This arises in the case of - -- private tagged types where the full view omits the word tagged. + procedure Check_Anonymous_Access_Types (Comp_List : Node_Id); + -- Ada 2005 AI-382: an access component in a record declaration can + -- refer to the enclosing record, in which case it denotes the type + -- itself, and not the current instance of the type. We create an + -- anonymous access type for the component, and flag it as an access + -- to a component, so that accessibility checks are properly performed + -- on it. The declaration of the access type is placed ahead of that + -- of the record, to prevent circular order-of-elaboration issues in + -- gigi. We create an incomplete type for the record declaration, which + -- is the designated type of the anonymous access. + + procedure Make_Incomplete_Type_Declaration; + -- If the record type contains components that include an access to the + -- current record, create an incomplete type declaration for the record, + -- to be used as the designated type of the anonymous access. This is + -- done only once, and only if there is no previous partial view of the + -- type. - Is_Tagged := - Tagged_Present (Def) - or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T)); + ---------------------------------- + -- Check_Anonymous_Access_Types -- + ---------------------------------- - -- Records constitute a scope for the component declarations within. - -- The scope is created prior to the processing of these declarations. - -- Discriminants are processed first, so that they are visible when - -- processing the other components. The Ekind of the record type itself - -- is set to E_Record_Type (subtypes appear as E_Record_Subtype). + procedure Check_Anonymous_Access_Types (Comp_List : Node_Id) is + Anon_Access : Entity_Id; + Acc_Def : Node_Id; + Comp : Node_Id; + Decl : Node_Id; + Type_Def : Node_Id; - -- Enter record scope + function Mentions_T (Acc_Def : Node_Id) return Boolean; + -- Check whether an access definition includes a reference to + -- the enclosing record type. The reference can be a subtype + -- mark in the access definition itself, or a 'Class attribute + -- reference, or recursively a reference appearing in a parameter + -- type in an access_to_subprogram definition. - New_Scope (T); + ---------------- + -- Mentions_T -- + ---------------- + + function Mentions_T (Acc_Def : Node_Id) return Boolean is + Subt : Node_Id; + + begin + if No (Access_To_Subprogram_Definition (Acc_Def)) then + Subt := Subtype_Mark (Acc_Def); + + if Nkind (Subt) = N_Identifier then + return Chars (Subt) = Chars (T); + elsif Nkind (Subt) = N_Attribute_Reference + and then Attribute_Name (Subt) = Name_Class + then + return (Chars (Prefix (Subt))) = Chars (T); + else + return False; + end if; + + else + -- Component is an access_to_subprogram: examine its formals + + declare + Param_Spec : Node_Id; + + begin + Param_Spec := + First + (Parameter_Specifications + (Access_To_Subprogram_Definition (Acc_Def))); + while Present (Param_Spec) loop + if Nkind (Parameter_Type (Param_Spec)) + = N_Access_Definition + and then Mentions_T (Parameter_Type (Param_Spec)) + then + return True; + end if; + + Next (Param_Spec); + end loop; + + return False; + end; + end if; + end Mentions_T; + + -- Start of processing for Check_Anonymous_Access_Types + + begin + if No (Comp_List) then + return; + end if; + + Comp := First (Component_Items (Comp_List)); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Declaration + and then + Present (Access_Definition (Component_Definition (Comp))) + and then + Mentions_T (Access_Definition (Component_Definition (Comp))) + then + Acc_Def := + Access_To_Subprogram_Definition + (Access_Definition (Component_Definition (Comp))); + + Make_Incomplete_Type_Declaration; + Anon_Access := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + + -- Create a declaration for the anonymous access type: either + -- an access_to_object or an access_to_subprogram. + + if Present (Acc_Def) then + if Nkind (Acc_Def) = N_Access_Function_Definition then + Type_Def := + Make_Access_Function_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def), + Subtype_Mark => Subtype_Mark (Acc_Def)); + else + Type_Def := + Make_Access_Procedure_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def)); + end if; + + else + Type_Def := + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + Relocate_Node + (Subtype_Mark + (Access_Definition + (Component_Definition (Comp))))); + end if; + + Decl := Make_Full_Type_Declaration (Loc, + Defining_Identifier => Anon_Access, + Type_Definition => Type_Def); + + Insert_Before (N, Decl); + Analyze (Decl); + + Set_Access_Definition (Component_Definition (Comp), Empty); + Set_Subtype_Indication (Component_Definition (Comp), + New_Occurrence_Of (Anon_Access, Loc)); + Set_Ekind (Anon_Access, E_Anonymous_Access_Type); + Set_Is_Local_Anonymous_Access (Anon_Access); + end if; + + Next (Comp); + end loop; + + if Present (Variant_Part (Comp_List)) then + declare + V : Node_Id; + begin + V := First_Non_Pragma (Variants (Variant_Part (Comp_List))); + while Present (V) loop + Check_Anonymous_Access_Types (Component_List (V)); + Next_Non_Pragma (V); + end loop; + end; + end if; + end Check_Anonymous_Access_Types; + + -------------------------------------- + -- Make_Incomplete_Type_Declaration -- + -------------------------------------- + + procedure Make_Incomplete_Type_Declaration is + Decl : Node_Id; + H : Entity_Id; + + begin + -- If there is a previous partial view, no need to create a new one. + + if Prev /= T then + return; + + elsif No (Inc_T) then + Inc_T := Make_Defining_Identifier (Loc, Chars (T)); + Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); + + -- Type has already been inserted into the current scope. + -- Remove it, and add incomplete declaration for type, so + -- that subsequent anonymous access types can use it. + + H := Current_Entity (T); + + if H = T then + Set_Name_Entity_Id (Chars (T), Empty); + else + while Present (H) + and then Homonym (H) /= T + loop + H := Homonym (T); + end loop; + + Set_Homonym (H, Homonym (T)); + end if; + + Insert_Before (N, Decl); + Analyze (Decl); + Set_Full_View (Inc_T, T); + + if Tagged_Present (Def) then + Make_Class_Wide_Type (Inc_T); + Set_Class_Wide_Type (T, Class_Wide_Type (Inc_T)); + end if; + end if; + end Make_Incomplete_Type_Declaration; + + -- Start of processing for Record_Type_Declaration + begin -- These flags must be initialized before calling Process_Discriminants -- because this routine makes use of them. - Set_Is_Tagged_Type (T, Is_Tagged); - Set_Is_Limited_Record (T, Limited_Present (Def)); + Set_Ekind (T, E_Record_Type); + Set_Etype (T, T); + Init_Size_Align (T); + Set_Abstract_Interfaces (T, No_Elist); + Set_Stored_Constraint (T, No_Elist); + + -- Normal case - -- Type is abstract if full declaration carries keyword, or if - -- previous partial view did. + if Ada_Version < Ada_05 + or else not Interface_Present (Def) + then + -- The flag Is_Tagged_Type might have already been set by + -- Find_Type_Name if it detected an error for declaration T. This + -- arises in the case of private tagged types where the full view + -- omits the word tagged. - Set_Is_Abstract (T, Is_Abstract (T) or else Abstract_Present (Def)); + Is_Tagged := + Tagged_Present (Def) + or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T)); - Set_Ekind (T, E_Record_Type); - Set_Etype (T, T); - Init_Size_Align (T); + Set_Is_Tagged_Type (T, Is_Tagged); + Set_Is_Limited_Record (T, Limited_Present (Def)); - Set_Stored_Constraint (T, No_Elist); + -- Type is abstract if full declaration carries keyword, or if + -- previous partial view did. + + Set_Is_Abstract (T, Is_Abstract (T) + or else Abstract_Present (Def)); + + else + Is_Tagged := True; + Set_Is_Tagged_Type (T); + + Set_Is_Limited_Record (T, Limited_Present (Def) + or else Task_Present (Def) + or else Protected_Present (Def)); + + -- Type is abstract if full declaration carries keyword, or if + -- previous partial view did. + + Set_Is_Abstract (T); + Set_Is_Interface (T); + end if; + + -- First pass: if there are self-referential access components, + -- create the required anonymous access type declarations, and if + -- need be an incomplete type declaration for T itself. + + Check_Anonymous_Access_Types (Component_List (Def)); + + -- Ada 2005 (AI-251): Complete the initialization of attributes + -- associated with abstract interfaces and decorate the names in the + -- list of ancestor interfaces (if any). + + if Ada_Version >= Ada_05 + and then Present (Interface_List (Def)) + then + declare + Iface : Node_Id; + Iface_Def : Node_Id; + Iface_Typ : Entity_Id; + begin + Iface := First (Interface_List (Def)); + + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + Iface_Def := Type_Definition (Parent (Iface_Typ)); + + if not Is_Interface (Iface_Typ) then + Error_Msg_NE ("(Ada 2005) & must be an interface", + Iface, Iface_Typ); + + else + -- "The declaration of a specific descendant of an + -- interface type freezes the interface type" RM 13.14 + + Freeze_Before (N, Iface_Typ); + + -- Ada 2005 (AI-345): Protected interfaces can only + -- inherit from limited, synchronized or protected + -- interfaces. + + if Protected_Present (Def) then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Protected_Present (Iface_Def) + then + null; + + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) protected interface cannot" + & " inherit from task interface", Iface); + + else + Error_Msg_N ("(Ada 2005) protected interface cannot" + & " inherit from non-limited interface", Iface); + end if; + + -- Ada 2005 (AI-345): Synchronized interfaces can only + -- inherit from limited and synchronized. + + elsif Synchronized_Present (Def) then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) synchronized interface " & + "cannot inherit from protected interface", Iface); + + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) synchronized interface " & + "cannot inherit from task interface", Iface); + + else + Error_Msg_N ("(Ada 2005) synchronized interface " & + "cannot inherit from non-limited interface", + Iface); + end if; + + -- Ada 2005 (AI-345): Task interfaces can only inherit + -- from limited, synchronized or task interfaces. + + elsif Task_Present (Def) then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Task_Present (Iface_Def) + then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) task interface cannot" & + " inherit from protected interface", Iface); + + else + Error_Msg_N ("(Ada 2005) task interface cannot" & + " inherit from non-limited interface", Iface); + end if; + end if; + end if; + + Next (Iface); + end loop; + + Set_Abstract_Interfaces (T, New_Elmt_List); + Collect_Interfaces (Type_Definition (N), T); + end; + end if; + + -- Records constitute a scope for the component declarations within. + -- The scope is created prior to the processing of these declarations. + -- Discriminants are processed first, so that they are visible when + -- processing the other components. The Ekind of the record type itself + -- is set to E_Record_Type (subtypes appear as E_Record_Subtype). + + -- Enter record scope + + New_Scope (T); -- If an incomplete or private type declaration was already given for -- the type, then this scope already exists, and the discriminants have @@ -12912,11 +14346,17 @@ package body Sem_Ch3 is Enter_Name (Tag_Comp); Set_Is_Tag (Tag_Comp); + Set_Is_Aliased (Tag_Comp); Set_Ekind (Tag_Comp, E_Component); Set_Etype (Tag_Comp, RTE (RE_Tag)); Set_DT_Entry_Count (Tag_Comp, No_Uint); Set_Original_Record_Component (Tag_Comp, Tag_Comp); Init_Component_Location (Tag_Comp); + + -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the + -- implemented interfaces + + Add_Interface_Tag_Components (N, T); end if; Make_Class_Wide_Type (T); @@ -12940,6 +14380,17 @@ package body Sem_Ch3 is -- Exit from record scope End_Scope; + + if Expander_Active + and then Is_Tagged + and then not Is_Empty_List (Interface_List (Def)) + then + -- Ada 2005 (AI-251): Derive the interface subprograms of all the + -- implemented interfaces and check if some of the subprograms + -- inherited from the ancestor cover some interface subprogram. + + Derive_Interface_Subprograms (T); + end if; end Record_Type_Declaration; ---------------------------- diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 88035b8a1f4..1cf52cbfa58 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -390,7 +390,8 @@ package body Sem_Ch4 is else declare - Def_Id : Entity_Id; + Def_Id : Entity_Id; + Base_Typ : Entity_Id; begin -- If the allocator includes a N_Subtype_Indication then a @@ -410,10 +411,11 @@ package body Sem_Ch4 is -- access-to-composite type, but the constraint is ignored. Find_Type (Subtype_Mark (E)); + Base_Typ := Entity (Subtype_Mark (E)); - if Is_Elementary_Type (Entity (Subtype_Mark (E))) then + if Is_Elementary_Type (Base_Typ) then if not (Ada_Version = Ada_83 - and then Is_Access_Type (Entity (Subtype_Mark (E)))) + and then Is_Access_Type (Base_Typ)) then Error_Msg_N ("constraint not allowed here", E); @@ -431,6 +433,17 @@ package body Sem_Ch4 is Rewrite (E, New_Copy_Tree (Subtype_Mark (E))); Analyze_Allocator (N); return; + + -- Ada 2005, AI-363: if the designated type has a constrained + -- partial view, it cannot receive a discriminant constraint, + -- and the allocated object is unconstrained. + + elsif Ada_Version >= Ada_05 + and then Has_Constrained_Partial_View (Base_Typ) + then + Error_Msg_N + ("constraint no allowed when type " & + "has a constrained partial view", Constraint (E)); end if; if Expander_Active then @@ -670,9 +683,18 @@ package body Sem_Ch4 is if Ekind (Etype (Nam)) = E_Subprogram_Type then Nam_Ent := Etype (Nam); + -- If the prefix is an access_to_subprogram, this may be an indirect + -- call. This is the case if the name in the call is not an entity + -- name, or if it is a function name in the context of a procedure + -- call. In this latter case, we have a call to a parameterless + -- function that returns a pointer_to_procedure which is the entity + -- being called. + elsif Is_Access_Type (Etype (Nam)) and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type - and then not Name_Denotes_Function + and then + (not Name_Denotes_Function + or else Nkind (N) = N_Procedure_Call_Statement) then Nam_Ent := Designated_Type (Etype (Nam)); Insert_Explicit_Dereference (Nam); @@ -1969,6 +1991,9 @@ package body Sem_Ch4 is Is_Indexed := Try_Indexed_Call (N, Nam, Designated_Type (Subp_Type)); + -- The prefix can also be a parameterless function that returns an + -- access to subprogram. in which case this is an indirect call. + elsif Is_Access_Type (Subp_Type) and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type then @@ -2099,6 +2124,23 @@ package body Sem_Ch4 is end if; if Report and not Is_Indexed then + + -- Ada 2005 (AI-251): Complete the error notification + -- to help new Ada 2005 users + + if Is_Class_Wide_Type (Etype (Formal)) + and then Is_Interface (Etype (Etype (Formal))) + and then not Interface_Present_In_Ancestor + (Typ => Etype (Actual), + Iface => Etype (Etype (Formal))) + then + Error_Msg_Name_1 := Chars (Actual); + Error_Msg_Name_2 := Chars (Etype (Etype (Formal))); + Error_Msg_NE + ("(Ada 2005) % does not implement interface %", + Actual, Etype (Etype (Formal))); + end if; + Wrong_Type (Actual, Etype (Formal)); if Nkind (Actual) = N_Op_Eq @@ -4892,6 +4934,30 @@ package body Sem_Ch4 is end if; + -- Before analysis, the function call appears as an + -- indexed component. + + elsif Nkind (Parent_Node) = N_Indexed_Component then + Node_To_Replace := Parent_Node; + + declare + Actual : Node_Id; + New_Act : Node_Id; + begin + Actual := First (Expressions (Parent_Node)); + while Present (Actual) loop + New_Act := New_Copy_Tree (Actual); + Analyze (New_Act); + Append (New_Act, Actuals); + Next (Actual); + end loop; + end; + + Call_Node := + Make_Function_Call (Loc, + Name => New_Copy_Tree (Subprog), + Parameter_Associations => Actuals); + -- Parameterless call else @@ -4901,7 +4967,6 @@ package body Sem_Ch4 is Make_Function_Call (Loc, Name => New_Copy_Tree (Subprog), Parameter_Associations => Actuals); - end if; end Transform_Object_Operation; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 024a6cb1c24..b3bb22275c4 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -122,13 +122,14 @@ package body Sem_Ch6 is -- against a formal access-to-subprogram type so Get_Instance_Of must -- be called. - procedure Check_Overriding_Operation - (N : Node_Id; - Subp : Entity_Id); - -- Check that a subprogram with a pragma Overriding or Optional_Overriding - -- is legal. This check is performed here rather than in Sem_Prag because - -- the pragma must follow immediately the declaration, and can be treated - -- as part of the declaration itself, as described in AI-218. + procedure Check_Overriding_Indicator + (Subp : Entity_Id; + Does_Override : Boolean); + -- Verify the consistency of an overriding_indicator given for subprogram + -- declaration, body, renaming, or instantiation. The flag Does_Override + -- is set if the scope into which we are introducing the subprogram + -- contains a type-conformant subprogram that becomes hidden by the new + -- subprogram. procedure Check_Subprogram_Order (N : Node_Id); -- N is the N_Subprogram_Body node for a subprogram. This routine applies @@ -514,6 +515,14 @@ package body Sem_Ch6 is Analyze (P); + -- If this is a call of the form Obj.Op, the call may have been + -- analyzed and possibly rewritten into a block, in which case + -- we are done. + + if Analyzed (N) then + return; + end if; + -- If error analyzing prefix, then set Any_Type as result and return if Etype (P) = Any_Type then @@ -678,7 +687,7 @@ package body Sem_Ch6 is -- Anything else is an error else - Error_Msg_N ("Invalid procedure or entry call", N); + Error_Msg_N ("invalid procedure or entry call", N); end if; end Analyze_Procedure_Call; @@ -836,6 +845,16 @@ package body Sem_Ch6 is -- If front-end inlining is enabled, look ahead to recognize a pragma -- that may appear after the body. + procedure Verify_Overriding_Indicator; + -- If there was a previous spec, the entity has been entered in the + -- current scope previously. If the body itself carries an overriding + -- indicator, check that it is consistent with the known status of the + -- entity. + + ---------------------------- + -- Check_Following_Pragma -- + ---------------------------- + procedure Check_Following_Pragma is Prag : Node_Id; @@ -860,6 +879,27 @@ package body Sem_Ch6 is end if; end Check_Following_Pragma; + --------------------------------- + -- Verify_Overriding_Indicator -- + --------------------------------- + + procedure Verify_Overriding_Indicator is + begin + if Must_Override (Body_Spec) + and then not Is_Overriding_Operation (Spec_Id) + then + Error_Msg_NE + ("subprogram& is not overriding", Body_Spec, Spec_Id); + + elsif Must_Not_Override (Body_Spec) + and then Is_Overriding_Operation (Spec_Id) + then + Error_Msg_NE + ("subprogram& overrides inherited operation", + Body_Spec, Spec_Id); + end if; + end Verify_Overriding_Indicator; + -- Start of processing for Analyze_Subprogram_Body begin @@ -1065,6 +1105,7 @@ package body Sem_Ch6 is elsif Present (Spec_Id) then Spec_Decl := Unit_Declaration_Node (Spec_Id); + Verify_Overriding_Indicator; end if; -- Place subprogram on scope stack, and make formals visible. If there @@ -1072,6 +1113,11 @@ package body Sem_Ch6 is if Present (Spec_Id) then Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False); + + if Is_Child_Unit (Spec_Id) then + Generate_Reference (Spec_Id, Scope (Spec_Id), 'k', False); + end if; + if Style_Check then Style.Check_Identifier (Body_Id, Spec_Id); end if; @@ -1136,6 +1182,27 @@ package body Sem_Ch6 is if Nkind (N) /= N_Subprogram_Body_Stub then Set_Corresponding_Spec (N, Spec_Id); + + -- Ada 2005 (AI-345): Restore the correct Etype: here we undo the + -- work done by Analyze_Subprogram_Specification to allow the + -- overriding of task, protected and interface primitives. + + if Comes_From_Source (Spec_Id) + and then Present (First_Entity (Spec_Id)) + and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type + and then Is_Tagged_Type (Etype (First_Entity (Spec_Id))) + and then Present (Abstract_Interfaces + (Etype (First_Entity (Spec_Id)))) + and then Present (Corresponding_Concurrent_Type + (Etype (First_Entity (Spec_Id)))) + then + Set_Etype (First_Entity (Spec_Id), + Corresponding_Concurrent_Type + (Etype (First_Entity (Spec_Id)))); + end if; + + -- Comment needed here, since this is not Ada 2005 stuff! ??? + Install_Formals (Spec_Id); Last_Formal := Last_Entity (Spec_Id); New_Scope (Spec_Id); @@ -1500,15 +1567,27 @@ package body Sem_Ch6 is if Nkind (Parent (N)) = N_Compilation_Unit then Set_Body_Required (Parent (N), True); + + if Ada_Version >= Ada_05 + and then Nkind (Specification (N)) = N_Procedure_Specification + and then Null_Present (Specification (N)) + then + Error_Msg_N + ("null procedure cannot be declared at library level", N); + end if; end if; Generate_Reference_To_Formals (Designator); Check_Eliminated (Designator); - if Comes_From_Source (N) - and then Is_List_Member (N) + -- Ada 2005: if procedure is declared with "is null" qualifier, + -- it requires no body. + + if Nkind (Specification (N)) = N_Procedure_Specification + and then Null_Present (Specification (N)) then - Check_Overriding_Operation (N, Designator); + Set_Has_Completion (Designator); + Set_Is_Inlined (Designator); end if; end Analyze_Subprogram_Declaration; @@ -1524,6 +1603,39 @@ package body Sem_Ch6 is Designator : constant Entity_Id := Defining_Entity (N); Formals : constant List_Id := Parameter_Specifications (N); + function Has_Interface_Formals (T : List_Id) return Boolean; + -- Ada 2005 (AI-251): Returns true if some non class-wide interface + -- formal is found. + + --------------------------- + -- Has_Interface_Formals -- + --------------------------- + + function Has_Interface_Formals (T : List_Id) return Boolean is + Param_Spec : Node_Id; + Formal : Entity_Id; + + begin + Param_Spec := First (T); + + while Present (Param_Spec) loop + Formal := Defining_Identifier (Param_Spec); + + if Is_Class_Wide_Type (Etype (Formal)) then + null; + + elsif Is_Interface (Etype (Formal)) then + return True; + end if; + + Next (Param_Spec); + end loop; + + return False; + end Has_Interface_Formals; + + -- Start of processing for Analyze_Subprogram_Specification + begin Generate_Definition (Designator); @@ -1544,6 +1656,30 @@ package body Sem_Ch6 is if Present (Formals) then New_Scope (Designator); Process_Formals (Formals, N); + + -- Ada 2005 (AI-345): Allow overriding primitives of protected + -- interfaces by means of normal subprograms. For this purpose + -- temporarily use the corresponding record type as the etype + -- of the first formal. + + if Ada_Version >= Ada_05 + and then Comes_From_Source (Designator) + and then Present (First_Entity (Designator)) + and then (Ekind (Etype (First_Entity (Designator))) + = E_Protected_Type + or else + Ekind (Etype (First_Entity (Designator))) + = E_Task_Type) + and then Present (Corresponding_Record_Type + (Etype (First_Entity (Designator)))) + and then Present (Abstract_Interfaces + (Corresponding_Record_Type + (Etype (First_Entity (Designator))))) + then + Set_Etype (First_Entity (Designator), + Corresponding_Record_Type (Etype (First_Entity (Designator)))); + end if; + End_Scope; elsif Nkind (N) = N_Function_Specification then @@ -1571,6 +1707,20 @@ package body Sem_Ch6 is end if; end if; + if Ada_Version >= Ada_05 + and then Comes_From_Source (N) + and then Nkind (Parent (N)) /= N_Abstract_Subprogram_Declaration + and then (Nkind (N) /= N_Procedure_Specification + or else + not Null_Present (N)) + and then Has_Interface_Formals (Formals) + then + Error_Msg_Name_1 := Chars (Defining_Unit_Name + (Specification (Parent (N)))); + Error_Msg_N + ("(Ada 2005) interface subprogram % must be abstract or null", N); + end if; + return Designator; end Analyze_Subprogram_Specification; @@ -1638,7 +1788,8 @@ package body Sem_Ch6 is then Conv := Current_Entity (Id); - elsif Nkind (Id) = N_Selected_Component + elsif (Nkind (Id) = N_Selected_Component + or else Nkind (Id) = N_Expanded_Name) and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion then Conv := Current_Entity (Selector_Name (Id)); @@ -1647,9 +1798,9 @@ package body Sem_Ch6 is return False; end if; - return - Present (Conv) - and then Scope (Conv) = Standard_Standard + return Present (Conv) + and then Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Conv))) and then Is_Intrinsic_Subprogram (Conv); end Is_Unchecked_Conversion; @@ -2572,100 +2723,49 @@ package body Sem_Ch6 is end Check_Mode_Conformant; -------------------------------- - -- Check_Overriding_Operation -- + -- Check_Overriding_Indicator -- -------------------------------- - procedure Check_Overriding_Operation - (N : Node_Id; - Subp : Entity_Id) + procedure Check_Overriding_Indicator + (Subp : Entity_Id; + Does_Override : Boolean) is - Arg1 : Node_Id; - Decl : Node_Id; - Has_Pragma : Boolean := False; + Decl : Node_Id; + Spec : Node_Id; begin - -- See whether there is an overriding pragma immediately following - -- the declaration. Intervening pragmas, such as Inline, are allowed. - - Decl := Next (N); - while Present (Decl) - and then Nkind (Decl) = N_Pragma - loop - if Chars (Decl) = Name_Overriding - or else Chars (Decl) = Name_Optional_Overriding - then - -- For now disable the use of these pragmas, until the ARG - -- finalizes the design of this feature. - - Error_Msg_N ("?unrecognized pragma", Decl); - - if not Is_Overriding_Operation (Subp) then - - -- Before emitting an error message, check whether this - -- may override an operation that is not yet visible, as - -- in the case of a derivation of a private operation in - -- a child unit. Such an operation is introduced with a - -- different name, but its alias is the parent operation. - - declare - E : Entity_Id; - - begin - E := First_Entity (Current_Scope); - - while Present (E) loop - if Ekind (E) = Ekind (Subp) - and then not Comes_From_Source (E) - and then Present (Alias (E)) - and then Chars (Alias (E)) = Chars (Subp) - and then In_Open_Scopes (Scope (Alias (E))) - then - exit; - else - Next_Entity (E); - end if; - end loop; - - if No (E) then - Error_Msg_NE - ("& must override an inherited operation", - Decl, Subp); - end if; - end; - end if; + if Ekind (Subp) = E_Enumeration_Literal then - -- Verify syntax of pragma + -- No overriding indicator for literals - Arg1 := First (Pragma_Argument_Associations (Decl)); - - if Present (Arg1) then - if not Is_Entity_Name (Expression (Arg1)) then - Error_Msg_N ("pragma applies to local subprogram", Decl); + return; - elsif Chars (Expression (Arg1)) /= Chars (Subp) then - Error_Msg_N - ("pragma must apply to preceding subprogram", Decl); + else + Decl := Unit_Declaration_Node (Subp); + end if; - elsif Present (Next (Arg1)) then - Error_Msg_N ("illegal pragma format", Decl); - end if; - end if; + if Nkind (Decl) = N_Subprogram_Declaration + or else Nkind (Decl) = N_Subprogram_Body + or else Nkind (Decl) = N_Subprogram_Renaming_Declaration + or else Nkind (Decl) = N_Subprogram_Body_Stub + then + Spec := Specification (Decl); + else + return; + end if; - Set_Analyzed (Decl); - Has_Pragma := True; - exit; + if not Does_Override then + if Must_Override (Spec) then + Error_Msg_NE ("subprogram& is not overriding", Spec, Subp); end if; - Next (Decl); - end loop; - - if not Has_Pragma - and then Explicit_Overriding - and then Is_Overriding_Operation (Subp) - then - Error_Msg_NE ("Missing overriding pragma for&", Subp, Subp); + else + if Must_Not_Override (Spec) then + Error_Msg_NE + ("subprogram& overrides inherited operation", Spec, Subp); + end if; end if; - end Check_Overriding_Operation; + end Check_Overriding_Indicator; ------------------- -- Check_Returns -- @@ -3142,6 +3242,8 @@ package body Sem_Ch6 is end if; end Base_Types_Match; + -- Start of processing for Conforming_Types + begin -- The context is an instance association for a formal -- access-to-subprogram type; the formal parameter types require @@ -3182,7 +3284,8 @@ package body Sem_Ch6 is or else Subtypes_Statically_Match (Type_1, Full_View (Type_2)); end if; - -- Ada 2005 (AI-254): Detect anonymous access to subprogram types + -- Ada 2005 (AI-254): Anonymous access to subprogram types must be + -- treated recursively because they carry a signature. Are_Anonymous_Access_To_Subprogram_Types := @@ -3264,10 +3367,23 @@ package body Sem_Ch6 is Etype (Base_Type (Desig_2)), Ctype); elsif Are_Anonymous_Access_To_Subprogram_Types then - return Ctype = Type_Conformant - or else + if Ada_Version < Ada_05 then + return Ctype = Type_Conformant + or else Subtypes_Statically_Match (Desig_1, Desig_2); + -- We must check the conformance of the signatures themselves + + else + declare + Conformant : Boolean; + begin + Check_Conformance + (Desig_1, Desig_2, Ctype, False, Conformant); + return Conformant; + end; + end if; + else return Base_Type (Desig_1) = Base_Type (Desig_2) and then (Ctype = Type_Conformant @@ -4438,12 +4554,18 @@ package body Sem_Ch6 is (S : Entity_Id; Derived_Type : Entity_Id := Empty) is + Does_Override : Boolean := False; + -- Set if the current scope has an operation that is type-conformant + -- with S, and becomes hidden by S. + E : Entity_Id; -- Entity that S overrides Prev_Vis : Entity_Id := Empty; -- Needs comment ??? + Is_Alias_Interface : Boolean := False; + function Is_Private_Declaration (E : Entity_Id) return Boolean; -- Check that E is declared in the private part of the current package, -- or in the package body, where it may hide a previous declaration. @@ -4522,8 +4644,17 @@ package body Sem_Ch6 is and then Is_Abstract (S) and then (not Is_Overriding or else not Is_Abstract (E)) then - Error_Msg_N ("abstract subprograms must be visible " - & "('R'M 3.9.3(10))!", S); + if not Is_Interface (T) then + Error_Msg_N ("abstract subprograms must be visible " + & "('R'M 3.9.3(10))!", S); + + -- Ada 2005 (AI-251) + + else + Error_Msg_N ("primitive subprograms of interface types " + & "declared in a visible part, must be declared in " + & "the visible part ('R'M 3.9.4)!", S); + end if; elsif Ekind (S) = E_Function and then Is_Tagged_Type (T) @@ -4650,6 +4781,15 @@ package body Sem_Ch6 is Check_Dispatching_Operation (S, Empty); Maybe_Primitive_Operation; + -- Ada 2005 (AI-397): Subprograms in the context of protected + -- types have their overriding indicators checked in Sem_Ch9. + + if Ekind (S) not in Subprogram_Kind + or else Ekind (Scope (S)) /= E_Protected_Type + then + Check_Overriding_Indicator (S, False); + end if; + -- If there is a homonym that is not overloadable, then we have an -- error, except for the special cases checked explicitly below. @@ -4673,6 +4813,7 @@ package body Sem_Ch6 is Enter_Overloaded_Entity (S); Set_Homonym (S, Homonym (E)); Check_Dispatching_Operation (S, Empty); + Check_Overriding_Indicator (S, False); -- If the subprogram is implicit it is hidden by the previous -- declaration. However if it is dispatching, it must appear in the @@ -4706,6 +4847,12 @@ package body Sem_Ch6 is -- E exists and is overloadable else + Is_Alias_Interface := + Present (Alias (S)) + and then Is_Dispatching_Operation (Alias (S)) + and then Present (DTC_Entity (Alias (S))) + and then Is_Interface (Scope (DTC_Entity (Alias (S)))); + -- Loop through E and its homonyms to determine if any of them is -- the candidate for overriding by S. @@ -4718,8 +4865,13 @@ package body Sem_Ch6 is -- Check if we have type conformance - elsif Type_Conformant (E, S) then + -- Ada 2005 (AI-251): In case of overriding an interface + -- subprogram it is not an error that the old and new entities + -- have the same profile, and hence we skip this code. + elsif not Is_Alias_Interface + and then Type_Conformant (E, S) + then -- If the old and new entities have the same profile and one -- is not the body of the other, then this is an error, unless -- one of them is implicitly declared. @@ -4762,6 +4914,11 @@ package body Sem_Ch6 is -- the existing declaration, which is overriding. Set_Is_Overriding_Operation (E); + + if Comes_From_Source (E) then + Check_Overriding_Indicator (E, True); + end if; + return; -- Within an instance, the renaming declarations for @@ -4805,6 +4962,8 @@ package body Sem_Ch6 is -- replaced in the list of primitive operations of its type -- (see Override_Dispatching_Operation). + Does_Override := True; + declare Prev : Entity_Id; @@ -4912,6 +5071,7 @@ package body Sem_Ch6 is Enter_Overloaded_Entity (S); Set_Is_Overriding_Operation (S); + Check_Overriding_Indicator (S, True); if Is_Dispatching_Operation (E) then @@ -4921,7 +5081,41 @@ package body Sem_Ch6 is Set_Convention (S, Convention (E)); - Check_Dispatching_Operation (S, E); + -- AI-251: If the subprogram implements an interface, + -- check if this subprogram covers other interface + -- subprograms available in the same scope. + + if Present (Alias (E)) + and then Ekind (Alias (E)) /= E_Operator + and then Present (DTC_Entity (Alias (E))) + and then Is_Interface (Scope (DTC_Entity + (Alias (E)))) + then + Check_Dispatching_Operation (S, E); + + declare + E1 : Entity_Id; + + begin + E1 := Homonym (E); + while Present (E1) loop + if Present (Alias (E1)) + and then Ekind (Alias (E1)) /= E_Operator + and then Present (DTC_Entity (Alias (E1))) + and then Is_Interface + (Scope (DTC_Entity (Alias (E1)))) + and then Type_Conformant (E1, S) + then + Check_Dispatching_Operation (S, E1); + end if; + + E1 := Homonym (E1); + end loop; + end; + else + Check_Dispatching_Operation (S, E); + end if; + else Check_Dispatching_Operation (S, Empty); end if; @@ -4978,6 +5172,7 @@ package body Sem_Ch6 is Enter_Overloaded_Entity (S); Maybe_Primitive_Operation; + Check_Overriding_Indicator (S, Does_Override); -- If S is a derived operation for an untagged type then by -- definition it's not a dispatching operation (even if the parent diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 06060ab9ff0..71b42f7e1f6 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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,6 +30,7 @@ with Einfo; use Einfo; with Errout; use Errout; with Exp_Ch9; with Elists; use Elists; +with Freeze; use Freeze; with Itypes; use Itypes; with Lib.Xref; use Lib.Xref; with Nlists; use Nlists; @@ -67,6 +68,11 @@ package body Sem_Ch9 is -- count the entries (checking the static requirement), and compare with -- the given maximum. + procedure Check_Overriding_Indicator (Def : Node_Id); + -- Ada 2005 (AI-397): Check the overriding indicator of entries and + -- subprograms of protected or task types. Def is the definition of + -- the protected or task type. + function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id; -- Find entity in corresponding task or protected declaration. Use full -- view if first declaration was for an incomplete type. @@ -1024,6 +1030,7 @@ package body Sem_Ch9 is Check_Max_Entries (N, Max_Protected_Entries); Process_End_Label (N, 'e', Current_Scope); + Check_Overriding_Indicator (N); end Analyze_Protected_Definition; ---------------------------- @@ -1031,9 +1038,12 @@ package body Sem_Ch9 is ---------------------------- procedure Analyze_Protected_Type (N : Node_Id) is - E : Entity_Id; - T : Entity_Id; - Def_Id : constant Entity_Id := Defining_Identifier (N); + E : Entity_Id; + T : Entity_Id; + Def_Id : constant Entity_Id := Defining_Identifier (N); + Iface : Node_Id; + Iface_Def : Node_Id; + Iface_Typ : Entity_Id; begin if No_Run_Time_Mode then @@ -1052,13 +1062,56 @@ package body Sem_Ch9 is end if; Set_Ekind (T, E_Protected_Type); + Set_Is_First_Subtype (T, True); Init_Size_Align (T); Set_Etype (T, T); - Set_Is_First_Subtype (T, True); Set_Has_Delayed_Freeze (T, True); Set_Stored_Constraint (T, No_Elist); New_Scope (T); + -- Ada 2005 (AI-345) + + if Present (Interface_List (N)) then + Iface := First (Interface_List (N)); + + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + Iface_Def := Type_Definition (Parent (Iface_Typ)); + + if not Is_Interface (Iface_Typ) then + Error_Msg_NE ("(Ada 2005) & must be an interface", + Iface, Iface_Typ); + + else + -- Ada 2005 (AI-251): "The declaration of a specific + -- descendant of an interface type freezes the interface + -- type" RM 13.14 + + Freeze_Before (N, Etype (Iface)); + + -- Ada 2005 (AI-345): Protected types can only implement + -- limited, synchronized or protected interfaces. + + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Protected_Present (Iface_Def) + then + null; + + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) protected type cannot implement a " + & "task interface", Iface); + + else + Error_Msg_N ("(Ada 2005) protected type cannot implement a " + & "non-limited interface", Iface); + end if; + end if; + + Next (Iface); + end loop; + end if; + if Present (Discriminant_Specifications (N)) then if Has_Discriminants (T) then @@ -1071,6 +1124,8 @@ package body Sem_Ch9 is end if; end if; + Set_Is_Constrained (T, not Has_Discriminants (T)); + Analyze (Protected_Definition (N)); -- Protected types with entries are controlled (because of the @@ -1119,9 +1174,9 @@ package body Sem_Ch9 is --------------------- procedure Analyze_Requeue (N : Node_Id) is + Count : Natural := 0; Entry_Name : Node_Id := Name (N); Entry_Id : Entity_Id; - Found : Boolean; I : Interp_Index; It : Interp; Enclosing : Entity_Id; @@ -1200,29 +1255,37 @@ package body Sem_Ch9 is if Is_Overloaded (Entry_Name) then Get_First_Interp (Entry_Name, I, It); - Found := False; Entry_Id := Empty; while Present (It.Nam) loop if No (First_Formal (It.Nam)) or else Subtype_Conformant (Enclosing, It.Nam) then - if not Found then - Found := True; + + -- Ada 2005 (AI-345): Since protected and task types have + -- primitive entry wrappers, we only consider source entries. + + if Comes_From_Source (It.Nam) then + Count := Count + 1; Entry_Id := It.Nam; else - Error_Msg_N ("ambiguous entry name in requeue", N); - return; + Remove_Interp (I); end if; end if; Get_Next_Interp (I, It); end loop; - if not Found then - Error_Msg_N ("no entry matches context", N); + if Count = 0 then + Error_Msg_N ("no entry matches context", N); + return; + + elsif Count > 1 then + Error_Msg_N ("ambiguous entry name in requeue", N); return; + else + Set_Is_Overloaded (Entry_Name, False); Set_Entity (Entry_Name, Entry_Id); end if; @@ -1361,7 +1424,7 @@ package body Sem_Ch9 is elsif Nkind (Alt) = N_Terminate_Alternative then if Terminate_Present then - Error_Msg_N ("Only one terminate alternative allowed", N); + Error_Msg_N ("only one terminate alternative allowed", N); else Terminate_Present := True; Check_Restriction (No_Terminate_Alternatives, N); @@ -1462,11 +1525,16 @@ package body Sem_Ch9 is T_Decl := Make_Protected_Type_Declaration (Loc, Defining_Identifier => T, - Protected_Definition => Relocate_Node (Protected_Definition (N))); + Protected_Definition => Relocate_Node (Protected_Definition (N)), + Interface_List => Interface_List (N)); + + -- Ada 2005 (AI-399): Mark the object as aliased. Required to use + -- the attribute 'access O_Decl := Make_Object_Declaration (Loc, Defining_Identifier => O_Name, + Aliased_Present => Ada_Version >= Ada_05, Object_Definition => Make_Identifier (Loc, Chars (T))); Rewrite (N, T_Decl); @@ -1489,7 +1557,6 @@ package body Sem_Ch9 is -- expanded twice, with disastrous result. Analyze_Protected_Type (N); - end Analyze_Single_Protected; ------------------------- @@ -1518,11 +1585,16 @@ package body Sem_Ch9 is T_Decl := Make_Task_Type_Declaration (Loc, Defining_Identifier => T, - Task_Definition => Relocate_Node (Task_Definition (N))); + Task_Definition => Relocate_Node (Task_Definition (N)), + Interface_List => Interface_List (N)); + + -- Ada 2005 (AI-399): Mark the object as aliased. Required to use + -- the attribute 'access O_Decl := Make_Object_Declaration (Loc, Defining_Identifier => O_Name, + Aliased_Present => Ada_Version >= Ada_05, Object_Definition => Make_Identifier (Loc, Chars (T))); Rewrite (N, T_Decl); @@ -1690,6 +1762,7 @@ package body Sem_Ch9 is Check_Max_Entries (N, Max_Task_Entries); Process_End_Label (N, 'e', Current_Scope); + Check_Overriding_Indicator (N); end Analyze_Task_Definition; ----------------------- @@ -1697,8 +1770,11 @@ package body Sem_Ch9 is ----------------------- procedure Analyze_Task_Type (N : Node_Id) is - T : Entity_Id; - Def_Id : constant Entity_Id := Defining_Identifier (N); + T : Entity_Id; + Def_Id : constant Entity_Id := Defining_Identifier (N); + Iface : Node_Id; + Iface_Def : Node_Id; + Iface_Typ : Entity_Id; begin Check_Restriction (No_Tasking, N); @@ -1720,6 +1796,47 @@ package body Sem_Ch9 is Set_Stored_Constraint (T, No_Elist); New_Scope (T); + -- Ada 2005 (AI-345) + + if Present (Interface_List (N)) then + Iface := First (Interface_List (N)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + Iface_Def := Type_Definition (Parent (Iface_Typ)); + + if not Is_Interface (Iface_Typ) then + Error_Msg_NE ("(Ada 2005) & must be an interface", + Iface, Iface_Typ); + + else + -- Ada 2005 (AI-251): The declaration of a specific descendant + -- of an interface type freezes the interface type (RM 13.14). + + Freeze_Before (N, Etype (Iface)); + + -- Ada 2005 (AI-345): Task types can only implement limited, + -- synchronized or task interfaces. + + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Task_Present (Iface_Def) + then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) task type cannot implement a " & + "protected interface", Iface); + + else + Error_Msg_N ("(Ada 2005) task type cannot implement a " & + "non-limited interface", Iface); + end if; + end if; + + Next (Iface); + end loop; + end if; + if Present (Discriminant_Specifications (N)) then if Ada_Version = Ada_83 and then Comes_From_Source (N) then Error_Msg_N ("(Ada 83) task discriminant not allowed!", N); @@ -1736,6 +1853,8 @@ package body Sem_Ch9 is end if; end if; + Set_Is_Constrained (T, not Has_Discriminants (T)); + if Present (Task_Definition (N)) then Analyze_Task_Definition (Task_Definition (N)); end if; @@ -1901,6 +2020,263 @@ package body Sem_Ch9 is end if; end Check_Max_Entries; + -------------------------------- + -- Check_Overriding_Indicator -- + -------------------------------- + + procedure Check_Overriding_Indicator (Def : Node_Id) is + Aliased_Hom : Entity_Id; + Decl : Node_Id; + Def_Id : Entity_Id; + Hom : Entity_Id; + Ifaces : constant List_Id := Interface_List (Parent (Def)); + Overrides : Boolean; + Spec : Node_Id; + Vis_Decls : constant List_Id := Visible_Declarations (Def); + + function Matches_Prefixed_View_Profile + (Ifaces : List_Id; + Entry_Params : List_Id; + Proc_Params : List_Id) return Boolean; + -- Ada 2005 (AI-397): Determine if an entry parameter profile matches + -- the prefixed view profile of an abstract procedure. Also determine + -- whether the abstract procedure belongs to an implemented interface. + + ----------------------------------- + -- Matches_Prefixed_View_Profile -- + ----------------------------------- + + function Matches_Prefixed_View_Profile + (Ifaces : List_Id; + Entry_Params : List_Id; + Proc_Params : List_Id) return Boolean + is + Entry_Param : Node_Id; + Proc_Param : Node_Id; + Proc_Param_Typ : Entity_Id; + + function Includes_Interface + (Iface : Entity_Id; + Ifaces : List_Id) return Boolean; + -- Determine if an interface is contained in a list of interfaces + + ------------------------ + -- Includes_Interface -- + ------------------------ + + function Includes_Interface + (Iface : Entity_Id; + Ifaces : List_Id) return Boolean + is + Ent : Entity_Id; + + begin + Ent := First (Ifaces); + + while Present (Ent) loop + if Etype (Ent) = Iface then + return True; + end if; + + Next (Ent); + end loop; + + return False; + end Includes_Interface; + + -- Start of processing for Matches_Prefixed_View_Profile + + begin + Proc_Param := First (Proc_Params); + Proc_Param_Typ := Etype (Parameter_Type (Proc_Param)); + + -- The first parameter of the abstract procedure must be of an + -- interface type. The task or protected type must also implement + -- that interface. + + if not Is_Interface (Proc_Param_Typ) + or else not Includes_Interface (Proc_Param_Typ, Ifaces) + then + return False; + end if; + + Entry_Param := First (Entry_Params); + Proc_Param := Next (Proc_Param); + while Present (Entry_Param) + and then Present (Proc_Param) + loop + -- The two parameters must be mode conformant and have the exact + -- same types. + + if In_Present (Entry_Param) /= In_Present (Proc_Param) + or else Out_Present (Entry_Param) /= Out_Present (Proc_Param) + or else Etype (Parameter_Type (Entry_Param)) /= + Etype (Parameter_Type (Proc_Param)) + then + return False; + end if; + + Next (Entry_Param); + Next (Proc_Param); + end loop; + + -- One of the lists is longer than the other + + if Present (Entry_Param) or else Present (Proc_Param) then + return False; + end if; + + return True; + end Matches_Prefixed_View_Profile; + + -- Start of processing for Check_Overriding_Indicator + + begin + if Present (Ifaces) then + Decl := First (Vis_Decls); + while Present (Decl) loop + + -- Consider entries with either "overriding" or "not overriding" + -- indicator present. + + if Nkind (Decl) = N_Entry_Declaration + and then (Must_Override (Decl) + or else + Must_Not_Override (Decl)) + then + Def_Id := Defining_Identifier (Decl); + + Overrides := False; + + Hom := Homonym (Def_Id); + while Present (Hom) loop + + -- The current entry may override a procedure from an + -- implemented interface. + + if Ekind (Hom) = E_Procedure + and then (Is_Abstract (Hom) + or else + Null_Present (Parent (Hom))) + then + Aliased_Hom := Hom; + + while Present (Alias (Aliased_Hom)) loop + Aliased_Hom := Alias (Aliased_Hom); + end loop; + + if Matches_Prefixed_View_Profile (Ifaces, + Parameter_Specifications (Decl), + Parameter_Specifications (Parent (Aliased_Hom))) + then + Overrides := True; + exit; + end if; + end if; + + Hom := Homonym (Hom); + end loop; + + if Overrides then + if Must_Not_Override (Decl) then + Error_Msg_NE ("entry& is overriding", Def_Id, Def_Id); + end if; + else + if Must_Override (Decl) then + Error_Msg_NE ("entry& is not overriding", Def_Id, Def_Id); + end if; + end if; + + -- Consider subprograms with either "overriding" or "not + -- overriding" indicator present. + + elsif Nkind (Decl) = N_Subprogram_Declaration + and then (Must_Override (Specification (Decl)) + or else + Must_Not_Override (Specification (Decl))) + then + Spec := Specification (Decl); + Def_Id := Defining_Unit_Name (Spec); + + Overrides := False; + + Hom := Homonym (Def_Id); + while Present (Hom) loop + + -- Function + + if Ekind (Def_Id) = E_Function + and then Ekind (Hom) = E_Function + and then Is_Abstract (Hom) + and then Matches_Prefixed_View_Profile (Ifaces, + Parameter_Specifications (Spec), + Parameter_Specifications (Parent (Hom))) + and then Etype (Subtype_Mark (Spec)) = + Etype (Subtype_Mark (Parent (Hom))) + then + Overrides := True; + exit; + + -- Procedure + + elsif Ekind (Def_Id) = E_Procedure + and then Ekind (Hom) = E_Procedure + and then (Is_Abstract (Hom) + or else + Null_Present (Parent (Hom))) + and then Matches_Prefixed_View_Profile (Ifaces, + Parameter_Specifications (Spec), + Parameter_Specifications (Parent (Hom))) + then + Overrides := True; + exit; + end if; + + Hom := Homonym (Hom); + end loop; + + if Overrides then + if Must_Not_Override (Spec) then + Error_Msg_NE + ("subprogram& is overriding", Def_Id, Def_Id); + end if; + else + if Must_Override (Spec) then + Error_Msg_NE + ("subprogram& is not overriding", Def_Id, Def_Id); + end if; + end if; + end if; + + Next (Decl); + end loop; + + -- The protected or task type is not implementing an interface, + -- we need to check for the presence of "overriding" entries or + -- subprograms and flag them as erroneous. + + else + Decl := First (Vis_Decls); + + while Present (Decl) loop + if Nkind (Decl) = N_Entry_Declaration + and then Must_Override (Decl) + then + Def_Id := Defining_Identifier (Decl); + Error_Msg_NE ("entry& is not overriding", Def_Id, Def_Id); + + elsif Nkind (Decl) = N_Subprogram_Declaration + and then Must_Override (Specification (Decl)) + then + Def_Id := Defining_Identifier (Specification (Decl)); + Error_Msg_NE ("subprogram& is not overriding", Def_Id, Def_Id); + end if; + + Next (Decl); + end loop; + end if; + end Check_Overriding_Indicator; + -------------------------- -- Find_Concurrent_Spec -- -------------------------- diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 9f8521bb427..c5fe8324cbe 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -31,6 +31,7 @@ with Einfo; use Einfo; with Exp_Disp; use Exp_Disp; with Exp_Ch7; use Exp_Ch7; with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; with Errout; use Errout; with Hostparm; use Hostparm; with Nlists; use Nlists; @@ -219,12 +220,25 @@ package body Sem_Disp is elsif Ekind (T) = E_Anonymous_Access_Type and then Is_Tagged_Type (Designated_Type (T)) - and then Ekind (Designated_Type (T)) /= E_Incomplete_Type then - if Is_First_Subtype (Designated_Type (T)) then - Tagged_Type := Designated_Type (T); - else - Tagged_Type := Base_Type (Designated_Type (T)); + if Ekind (Designated_Type (T)) /= E_Incomplete_Type then + if Is_First_Subtype (Designated_Type (T)) then + Tagged_Type := Designated_Type (T); + else + Tagged_Type := Base_Type (Designated_Type (T)); + end if; + + -- Ada 2005 (AI-50217) + + elsif From_With_Type (Designated_Type (T)) + and then Present (Non_Limited_View (Designated_Type (T))) + then + if Is_First_Subtype (Non_Limited_View (Designated_Type (T))) then + Tagged_Type := Non_Limited_View (Designated_Type (T)); + else + Tagged_Type := Base_Type (Non_Limited_View + (Designated_Type (T))); + end if; end if; end if; @@ -522,6 +536,18 @@ package body Sem_Disp is Set_Is_Dispatching_Operation (Subp, False); Tagged_Type := Find_Dispatching_Type (Subp); + -- Ada 2005 (AI-345) + + if Ada_Version = Ada_05 + and then Present (Tagged_Type) + and then Is_Concurrent_Type (Tagged_Type) + and then not Is_Empty_Elmt_List + (Abstract_Interfaces + (Corresponding_Record_Type (Tagged_Type))) + then + Tagged_Type := Corresponding_Record_Type (Tagged_Type); + end if; + -- If Subp is derived from a dispatching operation then it should -- always be treated as dispatching. In this case various checks -- below will be bypassed. Makes sure that late declarations for @@ -574,8 +600,10 @@ package body Sem_Disp is elsif Present (Old_Subp) and then Is_Dispatching_Operation (Old_Subp) then - if Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body - and then Comes_From_Source (Subp) + if Comes_From_Source (Subp) + and then + (Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Body + or else Nkind (Unit_Declaration_Node (Subp)) in N_Body_Stub) then declare Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); @@ -947,7 +975,6 @@ package body Sem_Disp is Set_Alias (Old_Subp, Alias (Subp)); -- The derived subprogram should inherit the abstractness - -- of the parent subprogram (except in the case of a function -- returning the type). This sets the abstractness properly -- for cases where a private extension may have inherited @@ -1140,6 +1167,34 @@ package body Sem_Disp is New_Op : Entity_Id) is Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type)); + Elmt : Elmt_Id; + Found : Boolean; + + function Is_Interface_Subprogram (Op : Entity_Id) return Boolean; + -- Comment requjired ??? + + ----------------------------- + -- Is_Interface_Subprogram -- + ----------------------------- + + function Is_Interface_Subprogram (Op : Entity_Id) return Boolean is + Aux : Entity_Id; + + begin + Aux := Op; + while Present (Alias (Aux)) + and then Present (DTC_Entity (Alias (Aux))) + loop + if Is_Interface (Scope (DTC_Entity (Alias (Aux)))) then + return True; + end if; + Aux := Alias (Aux); + end loop; + + return False; + end Is_Interface_Subprogram; + + -- Start of processing for Override_Dispatching_Operation begin -- Patch the primitive operation list @@ -1157,7 +1212,49 @@ package body Sem_Disp is return; end if; - Replace_Elmt (Op_Elmt, New_Op); + -- Ada 2005 (AI-251): Do not replace subprograms corresponding to + -- abstract interfaces. They will be used later to generate the + -- corresponding thunks to initialize the Vtable (see subprogram + -- Freeze_Subprogram) + + if Is_Interface_Subprogram (Prev_Op) then + Set_DT_Position (Prev_Op, DT_Position (Alias (Prev_Op))); + Set_Is_Abstract (Prev_Op, Is_Abstract (New_Op)); + Set_Is_Overriding_Operation (Prev_Op); + Set_Abstract_Interface_Alias (Prev_Op, Alias (Prev_Op)); + Set_Alias (Prev_Op, New_Op); + Set_Is_Internal (Prev_Op); + + -- Override predefined primitive operations + + if Is_Predefined_Dispatching_Operation (Prev_Op) then + Replace_Elmt (Op_Elmt, New_Op); + return; + end if; + + -- Check if this primitive operation was previously added for another + -- interface. + + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); + Found := False; + while Present (Elmt) loop + if Node (Elmt) = New_Op then + Found := True; + exit; + end if; + + Next_Elmt (Elmt); + end loop; + + if not Found then + Append_Elmt (New_Op, Primitive_Operations (Tagged_Type)); + -- Replace_Elmt (Op_Elmt, New_Op); -- why is this commented out??? + end if; + return; + + else + Replace_Elmt (Op_Elmt, New_Op); + end if; if (not Is_Package (Current_Scope)) or else not In_Private_Part (Current_Scope) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index cc55d26d2d5..fdba2bdec03 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -31,6 +31,7 @@ with Debug_A; use Debug_A; with Einfo; use Einfo; with Errout; use Errout; with Expander; use Expander; +with Exp_Disp; use Exp_Disp; with Exp_Ch7; use Exp_Ch7; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; @@ -357,7 +358,9 @@ package body Sem_Res is procedure Check_Direct_Boolean_Op (N : Node_Id) is begin - if Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean then + if Nkind (N) in N_Op + and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean + then Check_Restriction (No_Direct_Boolean_Operators, N); end if; end Check_Direct_Boolean_Op; @@ -538,6 +541,12 @@ package body Sem_Res is if Paren_Count (N) > 0 then Error_Msg_N ("discriminant in constraint must appear alone", N); + + elsif Nkind (N) = N_Expanded_Name + and then Comes_From_Source (N) + then + Error_Msg_N + ("discriminant must appear alone as a direct name", N); end if; return; @@ -2120,7 +2129,7 @@ package body Sem_Res is if Typ = Any_Real and then Expr_Type = Any_Fixed then - Error_Msg_N ("Illegal context for mixed mode operation", N); + Error_Msg_N ("illegal context for mixed mode operation", N); Set_Etype (N, Universal_Real); Ctx_Type := Universal_Real; end if; @@ -2590,9 +2599,23 @@ package body Sem_Res is if Has_Aliased_Components (Etype (Expression (A))) /= Has_Aliased_Components (Etype (F)) then - Error_Msg_N - ("both component types in a view conversion must be" - & " aliased, or neither", A); + if Ada_Version < Ada_05 then + Error_Msg_N + ("both component types in a view conversion must be" + & " aliased, or neither", A); + + -- Ada 2005: rule is relaxed (see AI-363) + + elsif Has_Aliased_Components (Etype (F)) + and then + not Has_Aliased_Components (Etype (Expression (A))) + then + Error_Msg_N + ("view conversion operand must have aliased " & + "components", N); + Error_Msg_N + ("\since target type has aliased components", N); + end if; elsif not Same_Ancestor (Etype (F), Etype (Expression (A))) and then @@ -2600,8 +2623,8 @@ package body Sem_Res is or else Is_By_Reference_Type (Etype (Expression (A)))) then Error_Msg_N - ("view conversion between unrelated by_reference " - & "array types not allowed (\A\I-00246)?", A); + ("view conversion between unrelated by reference " & + "array types not allowed (\'A'I-00246)", A); end if; end if; @@ -2620,19 +2643,16 @@ package body Sem_Res is or else Is_Limited_Type (Etype (Expression (A)))) then Error_Msg_N - ("Conversion between unrelated limited array types " - & "not allowed (\A\I-00246)?", A); - - -- Disable explanation (which produces additional errors) - -- until AI is approved and warning becomes an error. + ("conversion between unrelated limited array types " & + "not allowed (\A\I-00246)", A); - -- if Is_Limited_Type (Etype (F)) then - -- Explain_Limited_Type (Etype (F), A); - -- end if; + if Is_Limited_Type (Etype (F)) then + Explain_Limited_Type (Etype (F), A); + end if; - -- if Is_Limited_Type (Etype (Expression (A))) then - -- Explain_Limited_Type (Etype (Expression (A)), A); - -- end if; + if Is_Limited_Type (Etype (Expression (A))) then + Explain_Limited_Type (Etype (Expression (A)), A); + end if; end if; Resolve (A, Etype (F)); @@ -2668,9 +2688,9 @@ package body Sem_Res is Check_Unset_Reference (A); end if; - -- In Ada 83 we cannot pass an OUT parameter as an IN - -- or IN OUT actual to a nested call, since this is a - -- case of reading an out parameter, which is not allowed. + -- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT + -- actual to a nested call, since this is case of reading an + -- out parameter, which is not allowed. if Ada_Version = Ada_83 and then Is_Entity_Name (A) @@ -3035,6 +3055,46 @@ package body Sem_Res is end if; end if; + -- Ada 2005 (AI-344): A class-wide allocator requires an accessibility + -- check that the level of the type of the created object is not deeper + -- than the level of the allocator's access type, since extensions can + -- now occur at deeper levels than their ancestor types. This is a + -- static accessibility level check; a run-time check is also needed in + -- the case of an initialized allocator with a class-wide argument (see + -- Expand_Allocator_Expression). + + if Ada_Version >= Ada_05 + and then Is_Class_Wide_Type (Designated_Type (Typ)) + then + declare + Exp_Typ : Entity_Id; + + begin + if Nkind (E) = N_Qualified_Expression then + Exp_Typ := Etype (E); + elsif Nkind (E) = N_Subtype_Indication then + Exp_Typ := Entity (Subtype_Mark (Original_Node (E))); + else + Exp_Typ := Entity (E); + end if; + + if Type_Access_Level (Exp_Typ) > Type_Access_Level (Typ) then + if In_Instance_Body then + Error_Msg_N ("?type in allocator has deeper level than" & + " designated class-wide type", E); + Error_Msg_N ("?Program_Error will be raised at run time", E); + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Typ); + else + Error_Msg_N ("type in allocator has deeper level than" & + " designated class-wide type", E); + end if; + end if; + end; + end if; + -- Check for allocation from an empty storage pool if No_Pool_Assigned (Typ) then @@ -3126,8 +3186,8 @@ package body Sem_Res is if Universal_Interpretation (N) = Universal_Integer then -- A universal integer literal is resolved as standard integer - -- except in the case of a fixed-point result, where we leave - -- it as universal (to be handled by Exp_Fixd later on) + -- except in the case of a fixed-point result, where we leave it + -- as universal (to be handled by Exp_Fixd later on) if Is_Fixed_Point_Type (T) then Resolve (N, Universal_Integer); @@ -3209,11 +3269,11 @@ package body Sem_Res is Get_Next_Interp (Index, It); end loop; - -- Reanalyze the literal with the fixed type of the context. - -- If context is Universal_Fixed, we are within a conversion, - -- leave the literal as a universal real because there is no - -- usable fixed type, and the target of the conversion plays - -- no role in the resolution. + -- Reanalyze the literal with the fixed type of the context. If + -- context is Universal_Fixed, we are within a conversion, leave + -- the literal as a universal real because there is no usable + -- fixed type, and the target of the conversion plays no role in + -- the resolution. declare Op2 : Node_Id; @@ -3466,11 +3526,11 @@ package body Sem_Res is W : Node_Id; begin - -- The context imposes a unique interpretation with type Typ on - -- a procedure or function call. Find the entity of the subprogram - -- that yields the expected type, and propagate the corresponding - -- formal constraints on the actuals. The caller has established - -- that an interpretation exists, and emitted an error if not unique. + -- The context imposes a unique interpretation with type Typ on a + -- procedure or function call. Find the entity of the subprogram that + -- yields the expected type, and propagate the corresponding formal + -- constraints on the actuals. The caller has established that an + -- interpretation exists, and emitted an error if not unique. -- First deal with the case of a call to an access-to-subprogram, -- dereference made explicit in Analyze_Call. @@ -3480,9 +3540,9 @@ package body Sem_Res is Nam := Etype (Subp); else - -- Find the interpretation whose type (a subprogram type) - -- has a return type that is compatible with the context. - -- Analysis of the node has established that one exists. + -- Find the interpretation whose type (a subprogram type) has a + -- return type that is compatible with the context. Analysis of + -- the node has established that one exists. Get_First_Interp (Subp, I, It); Nam := Empty; @@ -3507,18 +3567,18 @@ package body Sem_Res is Resolve (Subp, Nam); end if; - -- For an indirect call, we always invalidate checks, since we - -- do not know whether the subprogram is local or global. Yes - -- we could do better here, e.g. by knowing that there are no - -- local subprograms, but it does not seem worth the effort. - -- Similarly, we kill al knowledge of current constant values. + -- For an indirect call, we always invalidate checks, since we do not + -- know whether the subprogram is local or global. Yes we could do + -- better here, e.g. by knowing that there are no local subprograms, + -- but it does not seem worth the effort. Similarly, we kill al + -- knowledge of current constant values. Kill_Current_Values; - -- If this is a procedure call which is really an entry call, do - -- the conversion of the procedure call to an entry call. Protected - -- operations use the same circuitry because the name in the call - -- can be an arbitrary expression with special resolution rules. + -- If this is a procedure call which is really an entry call, do the + -- conversion of the procedure call to an entry call. Protected + -- operations use the same circuitry because the name in the call can be + -- an arbitrary expression with special resolution rules. elsif Nkind (Subp) = N_Selected_Component or else Nkind (Subp) = N_Indexed_Component @@ -3589,12 +3649,12 @@ package body Sem_Res is Error_Msg_N ("cannot call thread body directly", N); end if; - -- If the subprogram is not global, then kill all checks. This is - -- a bit conservative, since in many cases we could do better, but - -- it is not worth the effort. Similarly, we kill constant values. - -- However we do not need to do this for internal entities (unless - -- they are inherited user-defined subprograms), since they are not - -- in the business of molesting global values. + -- If the subprogram is not global, then kill all checks. This is a bit + -- conservative, since in many cases we could do better, but it is not + -- worth the effort. Similarly, we kill constant values. However we do + -- not need to do this for internal entities (unless they are inherited + -- user-defined subprograms), since they are not in the business of + -- molesting global values. if not Is_Library_Level_Entity (Nam) and then (Comes_From_Source (Nam) @@ -3604,43 +3664,47 @@ package body Sem_Res is Kill_Current_Values; end if; - -- Check for call to obsolescent subprogram + -- Deal with call to obsolescent subprogram. Note that we always allow + -- such calls in the compiler itself and the run-time, since we assume + -- that we know what we are doing in such cases. For example, the calls + -- in Ada.Characters.Handling to its own obsolescent subprograms are + -- just fine. - if Warn_On_Obsolescent_Feature - and then Is_Subprogram (Nam) - and then Is_Obsolescent (Nam) - then - Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam); + if Is_Obsolescent (Nam) and then not GNAT_Mode then + Check_Restriction (No_Obsolescent_Features, N); - -- Output additional warning if present + if Warn_On_Obsolescent_Feature then + Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam); - W := Obsolescent_Warning (Nam); + -- Output additional warning if present - if Present (W) then - Name_Buffer (1) := '|'; - Name_Buffer (2) := '?'; - Name_Len := 2; + W := Obsolescent_Warning (Nam); - -- Add characters to message, protecting all of them + if Present (W) then + Name_Buffer (1) := '|'; + Name_Buffer (2) := '?'; + Name_Len := 2; - for J in 1 .. String_Length (Strval (W)) loop - Add_Char_To_Name_Buffer ('''); - Add_Char_To_Name_Buffer - (Get_Character (Get_String_Char (Strval (W), J))); - end loop; + -- Add characters to message, and output message + + for J in 1 .. String_Length (Strval (W)) loop + Add_Char_To_Name_Buffer ('''); + Add_Char_To_Name_Buffer + (Get_Character (Get_String_Char (Strval (W), J))); + end loop; - Error_Msg_N (Name_Buffer (1 .. Name_Len), N); + Error_Msg_N (Name_Buffer (1 .. Name_Len), N); + end if; end if; end if; - -- Check that a procedure call does not occur in the context - -- of the entry call statement of a conditional or timed - -- entry call. Note that the case of a call to a subprogram - -- renaming of an entry will also be rejected. The test - -- for N not being an N_Entry_Call_Statement is defensive, - -- covering the possibility that the processing of entry - -- calls might reach this point due to later modifications - -- of the code above. + -- Check that a procedure call does not occur in the context of the + -- entry call statement of a conditional or timed entry call. Note that + -- the case of a call to a subprogram renaming of an entry will also be + -- rejected. The test for N not being an N_Entry_Call_Statement is + -- defensive, covering the possibility that the processing of entry + -- calls might reach this point due to later modifications of the code + -- above. if Nkind (Parent (N)) = N_Entry_Call_Alternative and then Nkind (N) /= N_Entry_Call_Statement @@ -3662,34 +3726,33 @@ package body Sem_Res is Error_Msg_N ("\cannot call operation that may modify it", N); end if; - -- Freeze the subprogram name if not in default expression. Note - -- that we freeze procedure calls as well as function calls. - -- Procedure calls are not frozen according to the rules (RM - -- 13.14(14)) because it is impossible to have a procedure call to - -- a non-frozen procedure in pure Ada, but in the code that we - -- generate in the expander, this rule needs extending because we - -- can generate procedure calls that need freezing. + -- Freeze the subprogram name if not in default expression. Note that we + -- freeze procedure calls as well as function calls. Procedure calls are + -- not frozen according to the rules (RM 13.14(14)) because it is + -- impossible to have a procedure call to a non-frozen procedure in pure + -- Ada, but in the code that we generate in the expander, this rule + -- needs extending because we can generate procedure calls that need + -- freezing. if Is_Entity_Name (Subp) and then not In_Default_Expression then Freeze_Expression (Subp); end if; - -- For a predefined operator, the type of the result is the type - -- imposed by context, except for a predefined operation on universal - -- fixed. Otherwise The type of the call is the type returned by the - -- subprogram being called. + -- For a predefined operator, the type of the result is the type imposed + -- by context, except for a predefined operation on universal fixed. + -- Otherwise The type of the call is the type returned by the subprogram + -- being called. if Is_Predefined_Op (Nam) then if Etype (N) /= Universal_Fixed then Set_Etype (N, Typ); end if; - -- If the subprogram returns an array type, and the context - -- requires the component type of that array type, the node is - -- really an indexing of the parameterless call. Resolve as such. - -- A pathological case occurs when the type of the component is - -- an access to the array type. In this case the call is truly - -- ambiguous. + -- If the subprogram returns an array type, and the context requires the + -- component type of that array type, the node is really an indexing of + -- the parameterless call. Resolve as such. A pathological case occurs + -- when the type of the component is an access to the array type. In + -- this case the call is truly ambiguous. elsif Needs_No_Actuals (Nam) and then @@ -3760,10 +3823,10 @@ package body Sem_Res is Set_Is_Overloaded (Subp, False); Set_Is_Overloaded (N, False); - -- If we are calling the current subprogram from immediately within - -- its body, then that is the case where we can sometimes detect - -- cases of infinite recursion statically. Do not try this in case - -- restriction No_Recursion is in effect anyway. + -- If we are calling the current subprogram from immediately within its + -- body, then that is the case where we can sometimes detect cases of + -- infinite recursion statically. Do not try this in case restriction + -- No_Recursion is in effect anyway. Scop := Current_Scope; @@ -4018,8 +4081,6 @@ package body Sem_Res is T : Entity_Id; begin - Check_Direct_Boolean_Op (N); - -- If this is an intrinsic operation which is not predefined, use -- the types of its declared arguments to resolve the possibly -- overloaded operands. Otherwise the operands are unambiguous and @@ -4059,6 +4120,7 @@ package body Sem_Res is Check_Unset_Reference (R); Generate_Operator_Reference (N, T); Eval_Relational_Op (N); + Check_Direct_Boolean_Op (N); end if; end if; end Resolve_Comparison_Op; @@ -4213,7 +4275,7 @@ package body Sem_Res is null; else Error_Msg_N - ("Invalid use of subtype mark in expression or call", N); + ("invalid use of subtype mark in expression or call", N); end if; -- Check discriminant use if entity is discriminant in current scope, @@ -4636,7 +4698,7 @@ package body Sem_Res is elsif Ekind (Scope (Nam)) = E_Task_Type and then not In_Open_Scopes (Scope (Nam)) then - Error_Msg_N ("Task has no entry with this name", Entry_Name); + Error_Msg_N ("task has no entry with this name", Entry_Name); end if; end if; @@ -4752,8 +4814,6 @@ package body Sem_Res is -- Start of processing for Resolve_Equality_Op begin - Check_Direct_Boolean_Op (N); - Set_Etype (N, Base_Type (Typ)); Generate_Reference (T, N, ' '); @@ -4822,6 +4882,8 @@ package body Sem_Res is then Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); end if; + + Check_Direct_Boolean_Op (N); end if; end Resolve_Equality_Op; @@ -4837,20 +4899,35 @@ package body Sem_Res is It : Interp; begin - -- Now that we know the type, check that this is not a - -- dereference of an uncompleted type. Note that this - -- is not entirely correct, because dereferences of - -- private types are legal in default expressions. - -- This consideration also applies to similar checks - -- for allocators, qualified expressions, and type - -- conversions. ??? - - Check_Fully_Declared (Typ, N); + -- Now that we know the type, check that this is not dereference of an + -- uncompleted type. Note that this is not entirely correct, because + -- dereferences of private types are legal in default expressions. This + -- exception is taken care of in Check_Fully_Declared. + + -- This consideration also applies to similar checks for allocators, + -- qualified expressions, and type conversions. + + -- An additional exception concerns other per-object expressions that + -- are not directly related to component declarations, in particular + -- representation pragmas for tasks. These will be per-object + -- expressions if they depend on discriminants or some global entity. + -- If the task has access discriminants, the designated type may be + -- incomplete at the point the expression is resolved. This resolution + -- takes place within the body of the initialization procedure, where + -- the discriminant is replaced by its discriminal. + + if Is_Entity_Name (Prefix (N)) + and then Ekind (Entity (Prefix (N))) = E_In_Parameter + then + null; + else + Check_Fully_Declared (Typ, N); + end if; if Is_Overloaded (P) then - -- Use the context type to select the prefix that has the - -- correct designated type. + -- Use the context type to select the prefix that has the correct + -- designated type. Get_First_Interp (P, I, It); while Present (It.Typ) loop @@ -4863,13 +4940,12 @@ package body Sem_Res is if Present (It.Typ) then Resolve (P, It.Typ); else - -- If no interpretation covers the designated type of the - -- prefix, this is the pathological case where not all - -- implementations of the prefix allow the interpretation - -- of the node as a call. Now that the expected type is known, - -- Remove other interpretations from prefix, rewrite it as - -- a call, and resolve again, so that the proper call node - -- is generated. + -- If no interpretation covers the designated type of the prefix, + -- this is the pathological case where not all implementations of + -- the prefix allow the interpretation of the node as a call. Now + -- that the expected type is known, Remove other interpretations + -- from prefix, rewrite it as a call, and resolve again, so that + -- the proper call node is generated. Get_First_Interp (P, I, It); while Present (It.Typ) loop @@ -4903,14 +4979,13 @@ package body Sem_Res is Apply_Access_Check (N); end if; - -- If the designated type is a packed unconstrained array type, - -- and the explicit dereference is not in the context of an - -- attribute reference, then we must compute and set the actual - -- subtype, since it is needed by Gigi. The reason we exclude - -- the attribute case is that this is handled fine by Gigi, and - -- in fact we use such attributes to build the actual subtype. - -- We also exclude generated code (which builds actual subtypes - -- directly if they are needed). + -- If the designated type is a packed unconstrained array type, and the + -- explicit dereference is not in the context of an attribute reference, + -- then we must compute and set the actual subtype, since it is needed + -- by Gigi. The reason we exclude the attribute case is that this is + -- handled fine by Gigi, and in fact we use such attributes to build the + -- actual subtype. We also exclude generated code (which builds actual + -- subtypes directly if they are needed). if Is_Array_Type (Etype (N)) and then Is_Packed (Etype (N)) @@ -4921,9 +4996,9 @@ package body Sem_Res is Set_Etype (N, Get_Actual_Subtype (N)); end if; - -- Note: there is no Eval processing required for an explicit - -- deference, because the type is known to be an allocators, and - -- allocator expressions can never be static. + -- Note: there is no Eval processing required for an explicit deference, + -- because the type is known to be an allocators, and allocator + -- expressions can never be static. end Resolve_Explicit_Dereference; @@ -4940,8 +5015,8 @@ package body Sem_Res is begin if Is_Overloaded (Name) then - -- Use the context type to select the prefix that yields the - -- correct component type. + -- Use the context type to select the prefix that yields the correct + -- component type. declare I : Interp_Index; @@ -4953,6 +5028,9 @@ package body Sem_Res is begin Get_First_Interp (P, I, It); + -- the task has access discriminants, the designated type may be + -- incomplete at the point the expression is resolved. This resolution + -- takes place within the body of the initialization proc while Present (It.Typ) loop if (Is_Array_Type (It.Typ) @@ -5009,10 +5087,10 @@ package body Sem_Res is Index := First_Index (Array_Type); Expr := First (Expressions (N)); - -- The prefix may have resolved to a string literal, in which case - -- its etype has a special representation. This is only possible - -- currently if the prefix is a static concatenation, written in - -- functional notation. + -- The prefix may have resolved to a string literal, in which case its + -- etype has a special representation. This is only possible currently + -- if the prefix is a static concatenation, written in functional + -- notation. if Ekind (Array_Type) = E_String_Literal_Subtype then Resolve (Expr, Standard_Positive); @@ -5067,9 +5145,9 @@ package body Sem_Res is Set_Entity (N, Op); Set_Is_Overloaded (N, False); - -- If the operand type is private, rewrite with suitable - -- conversions on the operands and the result, to expose - -- the proper underlying numeric type. + -- If the operand type is private, rewrite with suitable conversions on + -- the operands and the result, to expose the proper underlying numeric + -- type. if Is_Private_Type (Typ) then Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd (N)); @@ -5167,11 +5245,9 @@ package body Sem_Res is B_Typ : Entity_Id; begin - Check_Direct_Boolean_Op (N); - - -- Predefined operations on scalar types yield the base type. On - -- the other hand, logical operations on arrays yield the type of - -- the arguments (and the context). + -- Predefined operations on scalar types yield the base type. On the + -- other hand, logical operations on arrays yield the type of the + -- arguments (and the context). if Is_Array_Type (Typ) then B_Typ := Typ; @@ -5211,6 +5287,7 @@ package body Sem_Res is Set_Etype (N, B_Typ); Generate_Operator_Reference (N, B_Typ); Eval_Logical_Op (N); + Check_Direct_Boolean_Op (N); end Resolve_Logical_Op; --------------------------- @@ -5269,8 +5346,8 @@ package body Sem_Res is procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is begin - -- Handle restriction against anonymous null access values - -- This restriction can be turned off using -gnatdh. + -- Handle restriction against anonymous null access values This + -- restriction can be turned off using -gnatdh. -- Ada 2005 (AI-231): Remove restriction @@ -5417,9 +5494,9 @@ package body Sem_Res is Explain_Limited_Type (Btyp, N); end if; - -- If the operands are themselves concatenations, resolve them as - -- such directly. This removes several layers of recursion and allows - -- GNAT to handle larger multiple concatenations. + -- If the operands are themselves concatenations, resolve them as such + -- directly. This removes several layers of recursion and allows GNAT to + -- handle larger multiple concatenations. if Nkind (Op1) = N_Op_Concat and then not Is_Array_Type (Component_Type (Typ)) @@ -5468,8 +5545,8 @@ package body Sem_Res is begin -- Catch attempts to do fixed-point exponentation with universal - -- operands, which is a case where the illegality is not caught - -- during normal operator analysis. + -- operands, which is a case where the illegality is not caught during + -- normal operator analysis. if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then Error_Msg_N ("exponentiation not available for fixed point", N); @@ -5560,9 +5637,9 @@ package body Sem_Res is -- Start of processing for Resolve_Op_Not begin - -- Predefined operations on scalar types yield the base type. On - -- the other hand, logical operations on arrays yield the type of - -- the arguments (and the context). + -- Predefined operations on scalar types yield the base type. On the + -- other hand, logical operations on arrays yield the type of the + -- arguments (and the context). if Is_Array_Type (Typ) then B_Typ := Typ; @@ -5669,12 +5746,12 @@ package body Sem_Res is Check_Unset_Reference (H); -- We have to check the bounds for being within the base range as - -- required for a non-static context. Normally this is automatic - -- and done as part of evaluating expressions, but the N_Range - -- node is an exception, since in GNAT we consider this node to - -- be a subexpression, even though in Ada it is not. The circuit - -- in Sem_Eval could check for this, but that would put the test - -- on the main evaluation path for expressions. + -- required for a non-static context. Normally this is automatic and + -- done as part of evaluating expressions, but the N_Range node is an + -- exception, since in GNAT we consider this node to be a subexpression, + -- even though in Ada it is not. The circuit in Sem_Eval could check for + -- this, but that would put the test on the main evaluation path for + -- expressions. Check_Non_Static_Context (L); Check_Non_Static_Context (H); @@ -5756,8 +5833,6 @@ package body Sem_Res is Realval => Small_Value (Typ) * Cint)); Set_Is_Static_Expression (N, Stat); - - end if; -- In all cases, set the corresponding integer field @@ -6389,8 +6464,8 @@ package body Sem_Res is ----------------------------- procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is - Target_Type : constant Entity_Id := Etype (N); - Conv_OK : constant Boolean := Conversion_OK (N); + Conv_OK : constant Boolean := Conversion_OK (N); + Target_Type : Entity_Id := Etype (N); Operand : Node_Id; Opnd_Type : Entity_Id; Rop : Node_Id; @@ -6525,6 +6600,43 @@ package body Sem_Res is ("?useless conversion, & has this type", N, Entity (Orig_N)); end if; end if; + + -- Ada 2005 (AI-251): Handle conversions to abstract interface types + + if Ada_Version >= Ada_05 then + if Is_Access_Type (Target_Type) then + Target_Type := Directly_Designated_Type (Target_Type); + end if; + + if Is_Class_Wide_Type (Target_Type) then + Target_Type := Etype (Target_Type); + end if; + + if Is_Interface (Target_Type) then + if Is_Class_Wide_Type (Opnd_Type) then + Opnd_Type := Etype (Opnd_Type); + end if; + + if not Interface_Present_In_Ancestor + (Typ => Opnd_Type, + Iface => Target_Type) + then + if Nkind (Operand) = N_Attribute_Reference then + Error_Msg_Name_1 := Chars (Prefix (Operand)); + else + Error_Msg_Name_1 := Chars (Operand); + end if; + + Error_Msg_Name_2 := Chars (Target_Type); + Error_Msg_NE + ("(Ada 2005) % does not implement interface %", + Operand, Target_Type); + + else + Expand_Interface_Conversion (N); + end if; + end if; + end if; end Resolve_Type_Conversion; ---------------------- @@ -6998,6 +7110,13 @@ package body Sem_Res is return Conversion_Check (False, "downward conversion of tagged objects not allowed"); + + -- Ada 2005 (AI-251): The conversion of a tagged type to an + -- abstract interface type is always valid + + elsif Is_Interface (Target_Type) then + return True; + else Error_Msg_NE ("invalid tagged conversion, not compatible with}", @@ -7162,6 +7281,94 @@ package body Sem_Res is return True; + -- Ada 2005 (AI-251) + + elsif (Ekind (Target_Type) = E_General_Access_Type + or else Ekind (Target_Type) = E_Anonymous_Access_Type) + and then Is_Interface (Directly_Designated_Type (Target_Type)) + then + -- Check the static accessibility rule of 4.6(17). Note that the + -- check is not enforced when within an instance body, since the RM + -- requires such cases to be caught at run time. + + if Ekind (Target_Type) /= E_Anonymous_Access_Type then + if Type_Access_Level (Opnd_Type) > + Type_Access_Level (Target_Type) + then + -- In an instance, this is a run-time check, but one we know + -- will fail, so generate an appropriate warning. The raise + -- will be generated by Expand_N_Type_Conversion. + + if In_Instance_Body then + Error_Msg_N + ("?cannot convert local pointer to non-local access type", + Operand); + Error_Msg_N + ("?Program_Error will be raised at run time", Operand); + + else + Error_Msg_N + ("cannot convert local pointer to non-local access type", + Operand); + return False; + end if; + + -- Special accessibility checks are needed in the case of access + -- discriminants declared for a limited type. + + elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type + and then not Is_Local_Anonymous_Access (Opnd_Type) + then + -- When the operand is a selected access discriminant the check + -- needs to be made against the level of the object denoted by + -- the prefix of the selected name. (Object_Access_Level + -- handles checking the prefix of the operand for this case.) + + if Nkind (Operand) = N_Selected_Component + and then Object_Access_Level (Operand) + > Type_Access_Level (Target_Type) + then + -- In an instance, this is a run-time check, but one we + -- know will fail, so generate an appropriate warning. + -- The raise will be generated by Expand_N_Type_Conversion. + + if In_Instance_Body then + Error_Msg_N + ("?cannot convert access discriminant to non-local" & + " access type", Operand); + Error_Msg_N + ("?Program_Error will be raised at run time", Operand); + + else + Error_Msg_N + ("cannot convert access discriminant to non-local" & + " access type", Operand); + return False; + end if; + end if; + + -- The case of a reference to an access discriminant from + -- within a limited type declaration (which will appear as + -- a discriminal) is always illegal because the level of the + -- discriminant is considered to be deeper than any (namable) + -- access type. + + if Is_Entity_Name (Operand) + and then not Is_Local_Anonymous_Access (Opnd_Type) + and then (Ekind (Entity (Operand)) = E_In_Parameter + or else Ekind (Entity (Operand)) = E_Constant) + and then Present (Discriminal_Link (Entity (Operand))) + then + Error_Msg_N + ("discriminant has deeper accessibility level than target", + Operand); + return False; + end if; + end if; + end if; + + return True; + elsif (Ekind (Target_Type) = E_General_Access_Type or else Ekind (Target_Type) = E_Anonymous_Access_Type) and then @@ -7181,11 +7388,13 @@ package body Sem_Res is return False; end if; - -- Check the static accessibility rule of 4.6(17). Note that - -- the check is not enforced when within an instance body, since - -- the RM requires such cases to be caught at run time. + -- Check the static accessibility rule of 4.6(17). Note that the + -- check is not enforced when within an instance body, since the RM + -- requires such cases to be caught at run time. - if Ekind (Target_Type) /= E_Anonymous_Access_Type then + if Ekind (Target_Type) /= E_Anonymous_Access_Type + or else Is_Local_Anonymous_Access (Target_Type) + then if Type_Access_Level (Opnd_Type) > Type_Access_Level (Target_Type) then @@ -7207,13 +7416,17 @@ package body Sem_Res is return False; end if; - elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type then + -- Special accessibility checks are needed in the case of access + -- discriminants declared for a limited type. + + elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type + and then not Is_Local_Anonymous_Access (Opnd_Type) + then - -- When the operand is a selected access discriminant - -- the check needs to be made against the level of the - -- object denoted by the prefix of the selected name. - -- (Object_Access_Level handles checking the prefix - -- of the operand for this case.) + -- When the operand is a selected access discriminant the check + -- needs to be made against the level of the object denoted by + -- the prefix of the selected name. (Object_Access_Level + -- handles checking the prefix of the operand for this case.) if Nkind (Operand) = N_Selected_Component and then Object_Access_Level (Operand) @@ -7238,11 +7451,11 @@ package body Sem_Res is end if; end if; - -- The case of a reference to an access discriminant - -- from within a type declaration (which will appear - -- as a discriminal) is always illegal because the - -- level of the discriminant is considered to be - -- deeper than any (namable) access type. + -- The case of a reference to an access discriminant from + -- within a limited type declaration (which will appear as + -- a discriminal) is always illegal because the level of the + -- discriminant is considered to be deeper than any (namable) + -- access type. if Is_Entity_Name (Operand) and then (Ekind (Entity (Operand)) = E_In_Parameter diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 3411194aa18..93a692e5e9c 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -28,6 +28,7 @@ with Atree; use Atree; with Alloc; with Debug; use Debug; with Einfo; use Einfo; +with Elists; use Elists; with Errout; use Errout; with Lib; use Lib; with Opt; use Opt; @@ -529,7 +530,7 @@ package body Sem_Type is end if; end loop; - -- On exit, we know that current homograph is not hidden. + -- On exit, we know that current homograph is not hidden Add_One_Interp (N, H, Etype (H)); @@ -686,6 +687,58 @@ package body Sem_Type is then return True; + -- Ada 2005 (AI-345): A class-wide abstract interface type T1 covers a + -- task_type or protected_type implementing T1 + + elsif Ada_Version >= Ada_05 + and then Is_Class_Wide_Type (T1) + and then Is_Interface (Etype (T1)) + and then Is_Concurrent_Type (T2) + and then Interface_Present_In_Ancestor ( + Typ => Corresponding_Record_Type (Base_Type (T2)), + Iface => Etype (T1)) + then + return True; + + -- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an + -- object T2 implementing T1 + + elsif Ada_Version >= Ada_05 + and then Is_Class_Wide_Type (T1) + and then Is_Interface (Etype (T1)) + and then Is_Tagged_Type (T2) + then + if Interface_Present_In_Ancestor (Typ => T2, + Iface => Etype (T1)) + then + return True; + + elsif Present (Abstract_Interfaces (T2)) then + + -- Ada 2005 (AI-251): A class-wide abstract interface type T1 + -- covers an object T2 that implements a direct derivation of T1. + + declare + E : Elmt_Id := First_Elmt (Abstract_Interfaces (T2)); + begin + while Present (E) loop + if Is_Ancestor (Etype (T1), Node (E)) then + return True; + end if; + + Next_Elmt (E); + end loop; + end; + + -- We should also check the case in which T1 is an ancestor of + -- some implemented interface??? + + return False; + + else + return False; + end if; + -- In a dispatching call the actual may be class-wide elsif Is_Class_Wide_Type (T2) @@ -1629,6 +1682,13 @@ package body Sem_Type is then return Covers (Typ, Etype (N)) + + -- Ada 2005 (AI-345) + + or else + (Is_Concurrent_Type (Etype (N)) + and then Covers (Typ, Corresponding_Record_Type (Etype (N)))) + or else (not Is_Tagged_Type (Typ) and then Ekind (Typ) /= E_Anonymous_Access_Type @@ -1641,6 +1701,14 @@ package body Sem_Type is and then (Scope (It.Nam) /= Standard_Standard or else not Is_Invisible_Operator (N, Base_Type (Typ)))) + + -- Ada 2005 (AI-345) + + or else + (Is_Concurrent_Type (It.Typ) + and then Covers (Typ, Corresponding_Record_Type + (Etype (It.Typ)))) + or else (not Is_Tagged_Type (Typ) and then Ekind (Typ) /= E_Anonymous_Access_Type and then Covers (It.Typ, Typ)) @@ -1694,6 +1762,72 @@ package body Sem_Type is Headers := (others => No_Entry); end Init_Interp_Tables; + ----------------------------------- + -- Interface_Present_In_Ancestor -- + ----------------------------------- + + function Interface_Present_In_Ancestor + (Typ : Entity_Id; + Iface : Entity_Id) return Boolean + is + AI : Entity_Id; + E : Entity_Id; + Elmt : Elmt_Id; + + begin + if Is_Access_Type (Typ) then + E := Etype (Directly_Designated_Type (Typ)); + else + E := Typ; + end if; + + if Is_Concurrent_Type (E) then + E := Corresponding_Record_Type (E); + end if; + + if Is_Class_Wide_Type (E) then + E := Etype (E); + end if; + + if E = Iface then + return True; + end if; + + loop + if Present (Abstract_Interfaces (E)) + and then Abstract_Interfaces (E) /= Empty_List_Or_Node -- ???? + and then not Is_Empty_Elmt_List (Abstract_Interfaces (E)) + then + Elmt := First_Elmt (Abstract_Interfaces (E)); + + while Present (Elmt) loop + AI := Node (Elmt); + + if AI = Iface or else Is_Ancestor (Iface, AI) then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + exit when Etype (E) = E; + + -- Check if the current type is a direct derivation of the + -- interface + + if Etype (E) = Iface then + return True; + end if; + + -- Climb to the immediate ancestor + + E := Etype (E); + end loop; + + return False; + end Interface_Present_In_Ancestor; + --------------------- -- Intersect_Types -- --------------------- @@ -1766,6 +1900,16 @@ package body Sem_Type is elsif Nkind (Parent (L)) = N_Range then Error_Msg_N ("incompatible types given in constraint", Parent (L)); + -- Ada 2005 (AI-251): Complete the error notification + + elsif Is_Class_Wide_Type (Etype (R)) + and then Is_Interface (Etype (Class_Wide_Type (Etype (R)))) + then + Error_Msg_Name_1 := Chars (L); + Error_Msg_Name_2 := Chars (Etype (Class_Wide_Type (Etype (R)))); + Error_Msg_NE ("(Ada 2005) % does not implement interface %", + L, Etype (Class_Wide_Type (Etype (R)))); + else Error_Msg_N ("incompatible types", Parent (L)); end if; @@ -1930,7 +2074,7 @@ package body Sem_Type is Headers (Hash (N)) := Interp_Map.Last; else - -- Place node at end of chain, or locate its previous entry. + -- Place node at end of chain, or locate its previous entry loop if Interp_Map.Table (Map_Ptr).Node = N then @@ -1949,7 +2093,7 @@ package body Sem_Type is end if; end loop; - -- Chain the new node. + -- Chain the new node Interp_Map.Increment_Last; Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last; @@ -2259,8 +2403,29 @@ package body Sem_Type is elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then return T1; + -- ---------------------------------------------------------- -- Special cases for equality operators (all other predefined -- operators can never apply to tagged types) + -- ---------------------------------------------------------- + + -- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an + -- interface + + elsif Is_Class_Wide_Type (T1) + and then Is_Class_Wide_Type (T2) + and then Is_Interface (Etype (T2)) + then + return T1; + + -- Ada 2005 (AI-251): T1 is a concrete type that implements the + -- class-wide interface T2 + + elsif Is_Class_Wide_Type (T2) + and then Is_Interface (Etype (T2)) + and then Interface_Present_In_Ancestor (Typ => T1, + Iface => Etype (T2)) + then + return T1; elsif Is_Class_Wide_Type (T1) and then Is_Ancestor (Root_Type (T1), T2) @@ -2302,7 +2467,7 @@ package body Sem_Type is then return T1; - -- If none of the above cases applies, types are not compatible. + -- If none of the above cases applies, types are not compatible else return Any_Type; @@ -2314,11 +2479,11 @@ package body Sem_Type is ----------------------- -- In addition to booleans and arrays of booleans, we must include - -- aggregates as valid boolean arguments, because in the first pass - -- of resolution their components are not examined. If it turns out not - -- to be an aggregate of booleans, this will be diagnosed in Resolve. - -- Any_Composite must be checked for prior to the array type checks - -- because Any_Composite does not have any associated indexes. + -- aggregates as valid boolean arguments, because in the first pass of + -- resolution their components are not examined. If it turns out not to be + -- an aggregate of booleans, this will be diagnosed in Resolve. + -- Any_Composite must be checked for prior to the array type checks because + -- Any_Composite does not have any associated indexes. function Valid_Boolean_Arg (T : Entity_Id) return Boolean is begin diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads index d4d3c472c86..8cf54fdc1f2 100644 --- a/gcc/ada/sem_type.ads +++ b/gcc/ada/sem_type.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -203,6 +203,13 @@ package Sem_Type is -- matches the signature of the operator, and is declared in an -- open scope, or in the scope of the result type. + function Interface_Present_In_Ancestor + (Typ : Entity_Id; + Iface : Entity_Id) return Boolean; + -- Ada 2005 (AI-251): Typ must be a tagged record type/subtype and Iface + -- must be an abstract interface type. This function is used to check if + -- some ancestor of Typ implements Iface. + function Intersect_Types (L, R : Node_Id) return Entity_Id; -- Find the common interpretation to two analyzed nodes. If one of the -- interpretations is universal, choose the non-universal one. If either |