Skip to content

R
riscv-gcc-1
Commit f4d379b8 by Hristian Kirtchev Committed by Arnaud Charlet
Options

rtsfind.ads, [...]: Complete support for Ada 2005 interfaces. 

2005-11-14  Hristian Kirtchev  <kirtchev@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* rtsfind.ads, exp_util.adb, exp_util.ads, exp_disp.adb, exp_disp.ads,
	exp_ch7.adb, sem_ch9.adb, snames.adb, snames.ads,
	exp_ch9.adb, exp_ch9.ads, exp_ch6.adb, exp_ch3.adb, exp_ch3.ads,
	einfo.ads, einfo.adb: Complete support for Ada 2005 interfaces.

	* a-tags.ads, a-tags.adb: Major rewrite and additions to implement
	properly new Ada 2005 interfaces (AI-345) and add run-time checks (via
	assertions).

	* exp_dbug.ads, exp_dbug.adb (Get_Secondary_DT_External_Name): New
	subprogram that generates the external name associated with a
	secondary dispatch table.
	(Get_Secondary_DT_External_Name): New subprogram that generates the
	external name associated with a secondary dispatch table.

From-SVN: r106965
parent 748d8778
Showing with 234 additions and 68 deletions
gcc/ada/exp_ch3.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- --
......@@ -40,12 +40,21 @@ package Exp_Ch3 is
procedure Expand_Previous_Access_Type (Def_Id : Entity_Id);
-- For a full type declaration that contains tasks, or that is a task,
-- check whether there exists an access type whose designated type is an
-- incomplete declarations for the current composite type. If so, build
-- the master for that access type, now that it is known to denote an
-- object with tasks.
-- incomplete declarations for the current composite type. If so, build the
-- master for that access type, now that it is known to denote an object
-- with tasks.
procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id);
-- Add a field _parent in the extension part of the record.
-- Add a field _parent in the extension part of the record
procedure Build_Class_Wide_Master (T : Entity_Id);
-- For access to class-wide limited types we must build a task master
-- because some subsequent extension may add a task component. To avoid
-- bringing in the tasking run-time whenever an access-to-class-wide
-- limited type is used, we use the soft-link mechanism and add a level of
-- indirection to calls to routines that manipulate Master_Ids. This must
-- also be used for anonymous access types whose designated type is a task
-- or synchronized interface.
procedure Build_Discr_Checking_Funcs (N : Node_Id);
-- Builds function which checks whether the component name is consistent
......@@ -66,10 +75,10 @@ package Exp_Ch3 is
-- constructed tree, and Typ is the type of the entity (the initialization
-- procedure of the base type is the procedure that actually gets called).
-- In_Init_Proc has to be set to True when the call is itself in an init
-- proc in order to enable the use of discriminals. Enclos_type is the
-- type of the init proc and it is used for various expansion cases
-- including the case where Typ is a task type which is a array component,
-- the indices of the enclosing type are used to build the string that
-- proc in order to enable the use of discriminals. Enclos_type is the type
-- of the init proc and it is used for various expansion cases including
-- the case where Typ is a task type which is a array component, the
-- indices of the enclosing type are used to build the string that
-- identifies each task at runtime.
--
-- Discr_Map is used to replace discriminants by their discriminals in
......@@ -84,33 +93,32 @@ package Exp_Ch3 is
function Freeze_Type (N : Node_Id) return Boolean;
-- This function executes the freezing actions associated with the given
-- freeze type node N and returns True if the node is to be deleted.
-- We delete the node if it is present just for front end purpose and
-- we don't want Gigi to see the node. This function can't delete the
-- node itself since it would confuse any remaining processing of the
-- freeze node.
-- freeze type node N and returns True if the node is to be deleted. We
-- delete the node if it is present just for front end purpose and we don't
-- want Gigi to see the node. This function can't delete the node itself
-- since it would confuse any remaining processing of the freeze node.
function Needs_Simple_Initialization (T : Entity_Id) return Boolean;
-- Certain types need initialization even though there is no specific
-- initialization routine. In this category are access types (which
-- need initializing to null), packed array types whose implementation
-- is a modular type, and all scalar types if Normalize_Scalars is set,
-- as well as private types whose underlying type is present and meets
-- any of these criteria. Finally, descendants of String and Wide_String
-- also need initialization in Initialize/Normalize_Scalars mode.
-- initialization routine. In this category are access types (which need
-- initializing to null), packed array types whose implementation is a
-- modular type, and all scalar types if Normalize_Scalars is set, as well
-- as private types whose underlying type is present and meets any of these
-- criteria. Finally, descendants of String and Wide_String also need
-- initialization in Initialize/Normalize_Scalars mode.
function Get_Simple_Init_Val
(T : Entity_Id;
Loc : Source_Ptr;
Size : Uint := No_Uint) return Node_Id;
-- For a type which Needs_Simple_Initialization (see above), prepares
-- the tree for an expression representing the required initial value.
-- Loc is the source location used in constructing this tree which is
-- returned as the result of the call. The Size parameter indicates the
-- target size of the object if it is known (indicated by a value that
-- is not No_Uint and is greater than zero). If Size is not given (Size
-- set to No_Uint, or non-positive), then the Esize of T is used as an
-- estimate of the Size. The object size is needed to prepare a known
-- invalid value for use by Normalize_Scalars.
-- For a type which Needs_Simple_Initialization (see above), prepares the
-- tree for an expression representing the required initial value. Loc is
-- the source location used in constructing this tree which is returned as
-- the result of the call. The Size parameter indicates the target size of
-- the object if it is known (indicated by a value that is not No_Uint and
-- is greater than zero). If Size is not given (Size set to No_Uint, or
-- non-positive), then the Esize of T is used as an estimate of the Size.
-- The object size is needed to prepare a known invalid value for use by
-- Normalize_Scalars.
end Exp_Ch3;
gcc/ada/exp_ch7.adb
......@@ -1793,6 +1793,13 @@ package body Exp_Ch7 is
return The_Parent;
end if;
-- A raise statement can be wrapped. This will arise when the
-- expression in a raise_with_expression uses the secondary
-- stack, for example.
when N_Raise_Statement =>
return The_Parent;
-- If the expression is within the iteration scheme of a loop,
-- we must create a declaration for it, followed by an assignment
-- in order to have a usable statement to wrap.
......@@ -2728,13 +2735,27 @@ package body Exp_Ch7 is
Utyp := Underlying_Type (Base_Type (Utyp));
Set_Assignment_OK (Cref);
-- Deal with non-tagged derivation of private views
-- Deal with non-tagged derivation of private views. If the parent is
-- now known to be protected, the finalization routine is the one
-- defined on the corresponding record of the ancestor (corresponding
-- records do not automatically inherit operations, but maybe they
-- should???)
if Is_Untagged_Derivation (Typ) then
Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
if Is_Protected_Type (Typ) then
Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
else
Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
end if;
Cref := Unchecked_Convert_To (Utyp, Cref);
-- We need to set Assignment_OK to prevent problems with unchecked
-- conversions, where we do not want them to be converted back in the
-- case of untagged record derivation (see code in Make_*_Call
-- procedures for similar situations).
Set_Assignment_OK (Cref);
-- To prevent problems with UC see 1.156 RH ???
end if;
-- If the underlying_type is a subtype, we are dealing with
......
gcc/ada/exp_ch9.adb
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/exp_ch9.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- --
......@@ -311,13 +311,21 @@ package Exp_Ch9 is
-- protected type.
procedure Set_Privals
(Dec : Node_Id;
Op : Node_Id;
Loc : Source_Ptr);
(Dec : Node_Id;
Op : Node_Id;
Loc : Source_Ptr;
After_Barrier : Boolean := False);
-- Associates a new set of privals (placeholders for later access to
-- private components of protected objects) with the private object
-- declarations of a protected object. These will be used to expand
-- the references to private objects in the next protected
-- subprogram or entry body to be expanded.
--
-- The flag After_Barrier indicates whether this is called after building
-- the barrier function for an entry body. This flag determines whether
-- the privals should have source names (which simplifies debugging) or
-- internally generated names. Entry barriers contain no debuggable code,
-- and there may be visibility conflicts between an entry index and a
-- a prival, so privals for barrier function have internal names.
end Exp_Ch9;
gcc/ada/exp_dbug.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1996-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- --
......@@ -134,7 +134,7 @@ package body Exp_Dbug is
-- used to determine whether encoding is required for a discrete type.
procedure Output_Homonym_Numbers_Suffix;
-- If homonym numbers are stored, then output them into Name_Buffer.
-- If homonym numbers are stored, then output them into Name_Buffer
procedure Prepend_String_To_Buffer (S : String);
-- Prepend given string to the contents of the string buffer, updating
......@@ -250,9 +250,9 @@ package body Exp_Dbug is
then
return True;
-- Here we check if the static bounds match the natural size, which
-- is the size passed through with the debugging information. This
-- is the Esize rounded up to 8, 16, 32 or 64 as appropriate.
-- Here we check if the static bounds match the natural size, which is
-- the size passed through with the debugging information. This is the
-- Esize rounded up to 8, 16, 32 or 64 as appropriate.
else
declare
......@@ -305,12 +305,12 @@ package body Exp_Dbug is
Def : Entity_Id;
function Output_Subscript (N : Node_Id; S : String) return Boolean;
-- Outputs a single subscript value as ?nnn (subscript is compile
-- time known value with value nnn) or as ?e (subscript is local
-- constant with name e), where S supplies the proper string to
-- use for ?. Returns False if the subscript is not of an appropriate
-- type to output in one of these two forms. The result is prepended
-- to the name stored in Name_Buffer.
-- Outputs a single subscript value as ?nnn (subscript is compile time
-- known value with value nnn) or as ?e (subscript is local constant
-- with name e), where S supplies the proper string to use for ?.
-- Returns False if the subscript is not of an appropriate type to
-- output in one of these two forms. The result is prepended to the
-- name stored in Name_Buffer.
----------------------
-- Output_Subscript --
......@@ -358,9 +358,9 @@ package body Exp_Dbug is
when N_Package_Renaming_Declaration =>
Add_Str_To_Name_Buffer ("___XRP");
-- If it is a child unit create a fully qualified name,
-- to disambiguate multiple child units with the same
-- name and different parents.
-- If it is a child unit create a fully qualified name, to
-- disambiguate multiple child units with the same name and
-- different parents.
if Is_Child_Unit (Ent) then
Prepend_String_To_Buffer ("__");
......@@ -386,8 +386,8 @@ package body Exp_Dbug is
when N_Expanded_Name =>
-- The entity field for an N_Expanded_Name is on the
-- expanded name node itself, so we are done here too.
-- The entity field for an N_Expanded_Name is on the expanded
-- name node itself, so we are done here too.
exit;
......@@ -713,6 +713,7 @@ package body Exp_Dbug is
-- If this is a library level subprogram (i.e. a subprogram that is a
-- compilation unit other than a subunit), then we prepend _ada_ to
-- ensure distinctions required as described in the spec.
-- Check explicitly for child units, because those are not flagged
-- as Compilation_Units by lib. Should they be ???
......@@ -880,6 +881,39 @@ package body Exp_Dbug is
end if;
end Get_Variant_Encoding;
------------------------------------
-- Get_Secondary_DT_External_Name --
------------------------------------
procedure Get_Secondary_DT_External_Name
(Typ : Entity_Id;
Ancestor_Typ : Entity_Id;
Suffix_Index : Int) is
begin
Get_External_Name (Typ, Has_Suffix => False);
if Ancestor_Typ /= Typ then
declare
Len : constant Natural := Name_Len;
Save_Str : constant String (1 .. Name_Len)
:= Name_Buffer (1 .. Name_Len);
begin
Get_External_Name (Ancestor_Typ, Has_Suffix => False);
-- Append the extended name of the ancestor to the
-- extended name of Typ
Name_Buffer (Len + 2 .. Len + Name_Len + 1) :=
Name_Buffer (1 .. Name_Len);
Name_Buffer (1 .. Len) := Save_Str;
Name_Buffer (Len + 1) := '_';
Name_Len := Len + Name_Len + 1;
end;
end if;
Add_Nat_To_Name_Buffer (Suffix_Index);
end Get_Secondary_DT_External_Name;
---------------------------------
-- Make_Packed_Array_Type_Name --
---------------------------------
......@@ -1166,7 +1200,6 @@ package body Exp_Dbug is
else
Add_Char_To_Name_Buffer ('X');
end if;
end Set_BNPE_Suffix;
---------------------
......@@ -1338,7 +1371,6 @@ package body Exp_Dbug is
exit;
end if;
end loop;
end Strip_Suffixes;
end Exp_Dbug;
gcc/ada/exp_dbug.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1996-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1996-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- --
......@@ -360,7 +360,7 @@ package Exp_Dbug is
-- Operations generated for protected entries follow the same encoding.
-- Each entry results in two suprograms: a procedure that holds the
-- entry body, and a function that holds the evaluation of the barrier.
-- The names of these subprograms include the prefix 'E' or 'B' res-
-- The names of these subprograms include the prefix '_E' or '_B' res-
-- pectively. The names also include a numeric suffix to render them
-- unique in the presence of overloaded entries.
......@@ -382,8 +382,8 @@ package Exp_Dbug is
-- lock_setN
-- lock_setP
-- lock_update1sE
-- lock_udpate2sB
-- lock_update_E1s
-- lock_udpate_B2s
-- If the protected type implements at least one interface, the
-- following additional operations are created:
......@@ -538,6 +538,12 @@ package Exp_Dbug is
-- field, and neither the outer structure name, nor the field name
-- should appear when the value is printed.
-- When the debugger sees a record named REP being a field inside
-- another record, it should treat the fields inside REP as being
-- part of the outer record (this REP field is only present for
-- code generation purposes). The REP record should not appear in
-- the values printed by the debugger.
-----------------------
-- Fixed-Point Types --
-----------------------
......@@ -1432,6 +1438,66 @@ package Exp_Dbug is
-- the second enumeration literal would be named QU43 and the
-- value assigned to it would be 1.
-----------------------------------------------
-- Secondary Dispatch tables of tagged types --
-----------------------------------------------
procedure Get_Secondary_DT_External_Name
(Typ : Entity_Id;
Ancestor_Typ : Entity_Id;
Suffix_Index : Int);
-- Set Name_Buffer and Name_Len to the external name of one secondary
-- dispatch table of Typ. If the interface has been inherited from some
-- ancestor then Ancestor_Typ is such node (in this case the secondary
-- DT is needed to handle overriden primitives); if there is no such
-- ancestor then Ancestor_Typ is equal to Typ.
--
-- Internal rule followed for the generation of the external name:
--
-- Case 1. If the secondary dispatch has not been inherited from some
-- ancestor of Typ then the external name is composed as
-- follows:
-- External_Name (Typ) + Suffix_Number + 'P'
--
-- Case 2. if the secondary dispatch table has been inherited from some
-- ancestor then the external name is composed as follows:
-- External_Name (Typ) + '_' + External_Name (Ancestor_Typ)
-- + Suffix_Number + 'P'
--
-- Note: We have to use the external names (instead of simply their
-- names) to protect the frontend against programs that give the same
-- name to all the interfaces and use the expanded name to reference
-- them. The Suffix_Number is used to differentiate all the secondary
-- dispatch tables of a given type.
--
-- Examples:
--
-- package Pkg1 is | package Pkg2 is | package Pkg3 is
-- type Typ is | type Typ is | type Typ is
-- interface; | interface; | interface;
-- end Pkg1; | end Pkg; | end Pkg3;
--
-- with Pkg1, Pkg2, Pkg3;
-- package Case_1 is
-- type Typ is new Pkg1.Typ and Pkg2.Typ and Pkg3.Typ with ...
-- end Case_1;
--
-- with Case_1;
-- package Case_2 is
-- type Typ is new Case_1.Typ with ...
-- end Case_2;
--
-- These are the external names generated for Case_1.Typ (note that
-- Pkg1.Typ is associated with the Primary Dispatch Table, because it
-- is the the parent of this type, and hence no external name is
-- generated for it).
-- case_1__typ0P (associated with Pkg2.Typ)
-- case_1__typ1P (associated with Pkg3.Typ)
--
-- These are the external names generated for Case_2.Typ:
-- case_2__typ_case_1__typ0P
-- case_2__typ_case_1__typ1P
----------------------------
-- Effect of Optimization --
----------------------------
......
gcc/ada/exp_disp.adb
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/exp_util.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- --
......@@ -33,6 +33,21 @@ with Types; use Types;
package Exp_Util is
-- An enumeration type used to capture all the possible interface
-- kinds and their hierarchical relation. These values are used in
-- Find_Implemented_Interface and Implements_Interface.
type Interface_Kind is (
Any_Interface, -- Any interface
Any_Limited_Interface, -- Only limited interfaces
Any_Synchronized_Interface, -- Only synchronized interfaces
Iface, -- Individual kinds
Limited_Interface,
Protected_Interface,
Synchronized_Interface,
Task_Interface);
-----------------------------------------------
-- Handling of Actions Associated with Nodes --
-----------------------------------------------
......@@ -325,17 +340,27 @@ package Exp_Util is
-- class-wide).
function Find_Interface_ADT
(T : Entity_Id;
Iface : Entity_Id) return Entity_Id;
(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;
(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_Implemented_Interface
(Typ : Entity_Id;
Kind : Interface_Kind;
Check_Parent : Boolean := False) return Entity_Id;
-- Ada 2005 (AI-345): Find a designated kind of interface implemented by
-- Typ or any parent subtype. Return the first encountered interface that
-- correspond to the selected class. Return Empty if no such interface is
-- found. Use Check_Parent to climb a potential derivation chain and
-- examine the parent subtypes for any implementation.
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
......@@ -410,11 +435,13 @@ package Exp_Util is
-- chain, counting only entries in the curren scope. If an entity is not
-- overloaded, the returned number will be one.
function Implements_Limited_Interface (Typ : Entity_Id) return Boolean;
-- Ada 2005 (AI-345): Determine whether Typ implements some limited
-- interface. The interface may be of limited, protected, synchronized
-- or taks kind. Typ may also be derived from a type that implements a
-- limited interface.
function Implements_Interface
(Typ : Entity_Id;
Kind : Interface_Kind;
Check_Parent : Boolean := False) return Boolean;
-- Ada 2005 (AI-345): Determine whether Typ implements a designated kind
-- of interface. Use Check_Parent to climb a potential derivation chain
-- and examine the parent subtypes for any implementation.
function Inside_Init_Proc return Boolean;
-- Returns True if current scope is within an init proc
......
gcc/ada/snames.adb
......@@ -93,6 +93,7 @@ package body Snames is
"_disp_conditional_select#" &
"_disp_get_prim_op_kind#" &
"_disp_timed_select#" &
"_disp_get_task_id#" &
"initialize#" &
"adjust#" &
"finalize#" &
......@@ -458,6 +459,7 @@ package body Snames is
"machine_mantissa#" &
"machine_overflows#" &
"machine_radix#" &
"machine_rounding#" &
"machine_rounds#" &
"machine_size#" &
"mantissa#" &
......@@ -639,6 +641,7 @@ package body Snames is
"unchecked_conversion#" &
"unchecked_deallocation#" &
"to_pointer#" &
"free#" &
"abstract#" &
"aliased#" &
"protected#" &
......@@ -674,6 +677,7 @@ package body Snames is
"include_option#" &
"language_processing#" &
"languages#" &
"library_ali_dir#" &
"library_dir#" &
"library_auto_init#" &
"library_gcc#" &
......
gcc/ada/snames.ads
This source diff could not be displayed because it is too large. You can view the blob instead.
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