Skip to content

R
riscv-gcc-1
Commit 758c442c by Gary Dismukes Committed by Arnaud Charlet
Options

exp_ch4.adb (Expand_Allocator_Expression): When an initialized allocator's… 

exp_ch4.adb (Expand_Allocator_Expression): When an initialized allocator's designated type is a class-wide type...

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.

From-SVN: r101024
parent 0ba5b393
Showing with 682 additions and 248 deletions
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);
......
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
......
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;
......
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
......
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;
gcc/ada/i-cpp.ads
------------------------------------------------------------------------------
-- --
-- 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;
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);
......
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,
......
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;
......
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)
......
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
......
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment