Skip to content

R
riscv-gcc-1
Commit c6f39437 by Arnaud Charlet
Options

[multiple changes] 

2009-07-13  Thomas Quinot  <quinot@adacore.com>

	* exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies):
	Do not attempt to generate stubs for predefined primitives of
	synchronized interfaces.
	(Add_Stub_Type): Factor some code from the PCS-specific variants of
	Build_Stub_Type.

2009-07-13  Ed Schonberg  <schonberg@adacore.com>

	* sem_disp.adb (Override_Dispatching_Operation): Functions inherit the
	Controlling_Result flag from the operation they override.

From-SVN: r149553
parent d97a04d0
Showing with 178 additions and 153 deletions
gcc/ada/ChangeLog
2009-07-13 Thomas Quinot <quinot@adacore.com>
* exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies):
Do not attempt to generate stubs for predefined primitives of
synchronized interfaces.
(Add_Stub_Type): Factor some code from the PCS-specific variants of
Build_Stub_Type.
2009-07-13 Ed Schonberg <schonberg@adacore.com>
* sem_disp.adb (Override_Dispatching_Operation): Functions inherit the
Controlling_Result flag from the operation they override.
2009-07-13 Arnaud Charlet <charlet@adacore.com>
* gcc-interface/Make-lang.in: Update dependencies
......
gcc/ada/exp_dist.adb
......@@ -27,6 +27,7 @@ with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Atag; use Exp_Atag;
with Exp_Disp; use Exp_Disp;
with Exp_Strm; use Exp_Strm;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
......@@ -55,8 +56,7 @@ with GNAT.HTable; use GNAT.HTable;
package body Exp_Dist is
-- The following model has been used to implement distributed objects:
-- given a designated type D and a RACW type R, then a record of the
-- form:
-- given a designated type D and a RACW type R, then a record of the form:
-- type Stub is tagged record
-- [...declaration similar to s-parint.ads RACW_Stub_Type...]
......@@ -64,8 +64,8 @@ package body Exp_Dist is
-- is built. This type has two properties:
-- 1) Since it has the same structure than RACW_Stub_Type, it can be
-- converted to and from this type to make it suitable for
-- 1) Since it has the same structure than RACW_Stub_Type, it can
-- be converted to and from this type to make it suitable for
-- System.Partition_Interface.Get_Unique_Remote_Pointer in order
-- to avoid memory leaks when the same remote object arrive on the
-- same partition through several paths;
......@@ -82,11 +82,10 @@ package body Exp_Dist is
-- RCI subprograms are numbered starting at 2. The RCI receiver for
-- an RCI package can thus identify calls received through remote
-- access-to-subprogram dereferences by the fact that they have a
-- (primitive) subprogram id of 0, and 1 is used for the internal
-- RAS information lookup operation. (This is for the Garlic code
-- generation, where subprograms are identified by numbers; in the
-- PolyORB version, they are identified by name, with a numeric suffix
-- for homonyms.)
-- (primitive) subprogram id of 0, and 1 is used for the internal RAS
-- information lookup operation. (This is for the Garlic code generation,
-- where subprograms are identified by numbers; in the PolyORB version,
-- they are identified by name, with a numeric suffix for homonyms.)
type Hash_Index is range 0 .. 50;
......@@ -95,13 +94,13 @@ package body Exp_Dist is
-----------------------
function Hash (F : Entity_Id) return Hash_Index;
-- DSA expansion associates stubs to distributed object types using
-- a hash table on entity ids.
-- DSA expansion associates stubs to distributed object types using a hash
-- table on entity ids.
function Hash (F : Name_Id) return Hash_Index;
-- The generation of subprogram identifiers requires an overload counter
-- to be associated with each remote subprogram names. These counters
-- are maintained in a hash table on name ids.
-- to be associated with each remote subprogram names. These counters are
-- maintained in a hash table on name ids.
type Subprogram_Identifiers is record
Str_Identifier : String_Id;
......@@ -115,8 +114,8 @@ package body Exp_Dist is
Key => Entity_Id,
Hash => Hash,
Equal => "=");
-- Mapping between a remote subprogram and the corresponding
-- subprogram identifiers.
-- Mapping between a remote subprogram and the corresponding subprogram
-- identifiers.
package Overload_Counter_Table is
new Simple_HTable (Header_Num => Hash_Index,
......@@ -125,9 +124,9 @@ package body Exp_Dist is
Key => Name_Id,
Hash => Hash,
Equal => "=");
-- Mapping between a subprogram name and an integer that
-- counts the number of defining subprogram names with that
-- Name_Id encountered so far in a given context (an interface).
-- Mapping between a subprogram name and an integer that counts the number
-- of defining subprogram names with that Name_Id encountered so far in a
-- given context (an interface).
function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
......@@ -264,8 +263,8 @@ package body Exp_Dist is
(Loc : Source_Ptr;
Prefix : Entity_Id;
Selector_Name : Name_Id) return Node_Id;
-- Return a selected_component whose prefix denotes the given entity,
-- and with the given Selector_Name.
-- Return a selected_component whose prefix denotes the given entity, and
-- with the given Selector_Name.
function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
-- Return the scope represented by a given spec
......@@ -274,8 +273,8 @@ package body Exp_Dist is
(Typ : Entity_Id;
Nam : Entity_Id;
TSS_Nam : TSS_Name_Type);
-- Create a renaming declaration of subprogram Nam,
-- and register it as a TSS for Typ with name TSS_Nam.
-- Create a renaming declaration of subprogram Nam, and register it as a
-- TSS for Typ with name TSS_Nam.
function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
-- Return True if the current parameter needs an extra formal to reflect
......@@ -563,11 +562,10 @@ package body Exp_Dist is
procedure Specific_Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id);
-- Build a type declaration for the stub type associated with an RACW
-- type, and the necessary RPC receiver, if applicable. PCS-specific
-- Build a components list for the stub type associated with an RACW type,
-- and build the necessary RPC receiver, if applicable. PCS-specific
-- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
-- is generated, then RPC_Receiver_Decl is set to Empty.
......@@ -616,6 +614,10 @@ package body Exp_Dist is
Stmts : List_Id);
-- Add receiving stubs to the declarative part of an RCI unit
--------------------
-- GARLIC_Support --
--------------------
package GARLIC_Support is
-- Support for generating DSA code that uses the GARLIC PCS
......@@ -657,8 +659,7 @@ package body Exp_Dist is
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id);
function Build_Subprogram_Receiving_Stubs
......@@ -690,6 +691,10 @@ package body Exp_Dist is
end GARLIC_Support;
---------------------
-- PolyORB_Support --
---------------------
package PolyORB_Support is
-- Support for generating DSA code that uses the PolyORB PCS
......@@ -731,8 +736,7 @@ package body Exp_Dist is
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id);
function Build_Subprogram_Receiving_Stubs
......@@ -769,6 +773,10 @@ package body Exp_Dist is
-- their methods to be accessed as objects, for the implementation of
-- remote access-to-subprogram types).
-------------
-- Helpers --
-------------
package Helpers is
-- Routines to build distribution helper subprograms for user-defined
......@@ -1146,7 +1154,6 @@ package body Exp_Dist is
end if;
else
-- Case of declaring the RACW in another package than its designated
-- type: use the private declarations list if present; otherwise
-- use the visible declarations.
......@@ -1317,11 +1324,12 @@ package body Exp_Dist is
Is_TSS (Current_Primitive, TSS_Stream_Input) or else
Is_TSS (Current_Primitive, TSS_Stream_Output) or else
Is_TSS (Current_Primitive, TSS_Stream_Read) or else
Is_TSS (Current_Primitive, TSS_Stream_Write))
Is_TSS (Current_Primitive, TSS_Stream_Write) or else
Is_Predefined_Interface_Primitive (Current_Primitive))
and then not Is_Hidden (Current_Primitive)
then
-- The first thing to do is build an up-to-date copy of the
-- spec with all the formals referencing Designated_Type
-- spec with all the formals referencing Controlling_Type
-- transformed into formals referencing Stub_Type. Since this
-- primitive may have been inherited, go back the alias chain
-- until the real primitive has been found.
......@@ -1337,7 +1345,7 @@ package body Exp_Dist is
-- Copy the spec from the original declaration for the purpose
-- of declaring an overriding subprogram: we need to replace
-- the type of each controlling formal with Stub_Type. The
-- primitive may have been declared for Designated_Type or
-- primitive may have been declared for Controlling_Type or
-- inherited from some ancestor type for which we do not have
-- an easily determined Entity_Id. We have no systematic way
-- of knowing which type to substitute Stub_Type for. Instead,
......@@ -1860,6 +1868,7 @@ package body Exp_Dist is
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Designated_Type);
Stub_Type_Comps : List_Id;
Stub_Type_Decl : Node_Id;
Stub_Type_Access_Decl : Node_Id;
......@@ -1875,8 +1884,7 @@ package body Exp_Dist is
Existing := False;
Stub_Type :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S'));
Set_Ekind (Stub_Type, E_Record_Type);
Set_Is_RACW_Stub_Type (Stub_Type);
Stub_Type_Access :=
......@@ -1884,9 +1892,24 @@ package body Exp_Dist is
Chars => New_External_Name
(Related_Id => Chars (Stub_Type), Suffix => 'A'));
Specific_Build_Stub_Type
(RACW_Type, Stub_Type,
Stub_Type_Decl, RPC_Receiver_Decl);
Specific_Build_Stub_Type (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
Stub_Type_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Stub_Type,
Type_Definition =>
Make_Record_Definition (Loc,
Tagged_Present => True,
Limited_Present => True,
Component_List =>
Make_Component_List (Loc,
Component_Items => Stub_Type_Comps)));
-- Does the stub type need to explicitly implement interfaces from the
-- designated type???
-- In particular are there issues in the case where the designated type
-- is a synchronized interface???
Stub_Type_Access_Decl :=
Make_Full_Type_Declaration (Loc,
......@@ -1901,9 +1924,10 @@ package body Exp_Dist is
Append_To (Decls, Stub_Type_Access_Decl);
Analyze (Last (Decls));
-- This is in no way a type derivation, but we fake it to make sure that
-- the dispatching table gets built with the corresponding primitive
-- operations at the right place.
-- We can't directly derive the stub type from the designated type,
-- because we don't want any components or discriminants from the real
-- type, so instead we manually fake a derivation to get an appropriate
-- dispatch table.
Derive_Subprograms (Parent_Type => Designated_Type,
Derived_Type => Stub_Type);
......@@ -1930,6 +1954,7 @@ package body Exp_Dist is
procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
E : Entity_Id;
begin
E := First_Entity (Spec_Id);
while Present (E) loop
......@@ -1960,10 +1985,9 @@ package body Exp_Dist is
Get_Name_String (N);
-- Homonym handling: as in Exp_Dbug, but much simpler,
-- because the only entities for which we have to generate
-- names here need only to be disambiguated within their
-- own scope.
-- Homonym handling: as in Exp_Dbug, but much simpler, because the only
-- entities for which we have to generate names here need only to be
-- disambiguated within their own scope.
if Overload_Order > 1 then
Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
......@@ -1972,7 +1996,8 @@ package body Exp_Dist is
end if;
Id := String_From_Name_Buffer;
Subprogram_Identifier_Table.Set (Def,
Subprogram_Identifier_Table.Set
(Def,
Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
end Assign_Subprogram_Identifier;
......@@ -1988,6 +2013,7 @@ package body Exp_Dist is
Decls : List_Id)
is
Loc : constant Source_Ptr := Sloc (Object);
begin
-- Declare a temporary object for the actual, possibly initialized with
-- a 'Input/From_Any call.
......@@ -2071,7 +2097,6 @@ package body Exp_Dist is
end if;
else
-- General case of a regular object declaration. Object is flagged
-- constant unless it has mode out or in out, to allow the backend
-- to optimize where possible.
......@@ -4084,8 +4109,8 @@ package body Exp_Dist is
Loc : constant Source_Ptr := Sloc (Nod);
Stream_Parameter : Node_Id;
-- Name of the stream used to transmit parameters to the
-- remote package.
-- Name of the stream used to transmit parameters to the remote
-- package.
Result_Parameter : Node_Id;
-- Name of the result parameter (in non-APC cases) which get the
......@@ -4410,8 +4435,8 @@ package body Exp_Dist is
else
-- Loop around parameters and assign out (or in out)
-- parameters. In the case of RACW, controlling arguments
-- cannot possibly have changed since they are remote, so we do
-- not read them from the stream.
-- cannot possibly have changed since they are remote, so
-- we do not read them from the stream.
Current_Parameter := First (Ordered_Parameters_List);
while Present (Current_Parameter) loop
......@@ -4619,25 +4644,14 @@ package body Exp_Dist is
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (Stub_Type);
Loc : constant Source_Ptr := Sloc (RACW_Type);
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
begin
Stub_Type_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Stub_Type,
Type_Definition =>
Make_Record_Definition (Loc,
Tagged_Present => True,
Limited_Present => True,
Component_List =>
Make_Component_List (Loc,
Component_Items => New_List (
Stub_Type_Comps := New_List (
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Origin),
......@@ -4645,8 +4659,7 @@ package body Exp_Dist is
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (
RTE (RE_Partition_ID), Loc))),
New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
......@@ -4673,8 +4686,7 @@ package body Exp_Dist is
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (
Standard_Boolean, Loc)))))));
New_Occurrence_Of (Standard_Boolean, Loc))));
if Is_RAS then
RPC_Receiver_Decl := Empty;
......@@ -5193,7 +5205,9 @@ package body Exp_Dist is
-------------------------------
function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
Desig : constant Entity_Id :=
Etype (Designated_Type (RACW_Type));
Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
Body_Decls : List_Id;
......@@ -5311,15 +5325,15 @@ package body Exp_Dist is
Typ : Entity_Id;
begin
-- If the kind of the parameter is E_Void, then it is not a
-- controlling formal (this can happen in the context of RAS).
-- If the kind of the parameter is E_Void, then it is not a controlling
-- formal (this can happen in the context of RAS).
if Ekind (Defining_Identifier (Parameter)) = E_Void then
return False;
end if;
-- If the parameter is not a controlling formal, then it cannot
-- be possibly a RACW_Controlling_Formal.
-- If the parameter is not a controlling formal, then it cannot be
-- possibly a RACW_Controlling_Formal.
if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
return False;
......@@ -5636,7 +5650,6 @@ package body Exp_Dist is
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
Fnam : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (RACW_Type), 'F'));
......@@ -5860,11 +5873,9 @@ package body Exp_Dist is
Make_Defining_Identifier (Loc, Name_R);
Reference : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('R'));
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Any : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('A'));
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
begin
Func_Spec :=
......@@ -5992,7 +6003,6 @@ package body Exp_Dist is
Func_Body : Node_Id;
begin
-- The spec for this subprogram has a dummy 'access RACW' argument,
-- which serves only for overloading purposes.
......@@ -6353,6 +6363,7 @@ package body Exp_Dist is
New_Occurrence_Of (Subp_Ref, Loc)))),
-- Inc_Usage (A.Target);
-- end if;
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
......@@ -6365,7 +6376,6 @@ package body Exp_Dist is
Selector_Name =>
Make_Identifier (Loc, Name_Target)))))),
-- end if;
-- if not All_Calls_Remote then
-- return Fat_Type!(A);
-- end if;
......@@ -6669,8 +6679,8 @@ package body Exp_Dist is
-- Request object received from neutral layer
Subp_Id : Entity_Id;
-- Subprogram identifier as received from the neutral
-- distribution core.
-- Subprogram identifier as received from the neutral distribution
-- core.
Subp_Index : Entity_Id;
-- Internal index as determined by matching either the method name
......@@ -6787,9 +6797,9 @@ package body Exp_Dist is
begin
-- Building receiving stubs consist in several operations:
-- - a package RPC receiver must be built. This subprogram
-- will get a Subprogram_Id from the incoming stream
-- and will dispatch the call to the right subprogram;
-- - a package RPC receiver must be built. This subprogram will get
-- a Subprogram_Id from the incoming stream and will dispatch the
-- call to the right subprogram;
-- - a receiving stub for each subprogram visible in the package
-- spec. This stub will read all the parameters from the stream,
......@@ -6837,9 +6847,9 @@ package body Exp_Dist is
New_Occurrence_Of (Is_Local, Loc),
New_Occurrence_Of (Local_Address, Loc))));
-- For each subprogram, the receiving stub will be built and a
-- case statement will be made on the Subprogram_Id to dispatch
-- to the right subprogram.
-- For each subprogram, the receiving stub will be built and a case
-- statement will be made on the Subprogram_Id to dispatch to the
-- right subprogram.
All_Calls_Remote_E := Boolean_Literals (
Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
......@@ -7615,26 +7625,13 @@ package body Exp_Dist is
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (Stub_Type);
pragma Unreferenced (RACW_Type);
Loc : constant Source_Ptr := Sloc (RACW_Type);
begin
Stub_Type_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Stub_Type,
Type_Definition =>
Make_Record_Definition (Loc,
Tagged_Present => True,
Limited_Present => True,
Component_List =>
Make_Component_List (Loc,
Component_Items => New_List (
Stub_Type_Comps := New_List (
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Target),
......@@ -7652,7 +7649,7 @@ package body Exp_Dist is
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (Standard_Boolean, Loc)))))));
New_Occurrence_Of (Standard_Boolean, Loc))));
RPC_Receiver_Decl :=
Make_Object_Declaration (Loc,
......@@ -7758,8 +7755,8 @@ package body Exp_Dist is
Decls : constant List_Id := New_List;
-- All the parameters will get declared before calling the real
-- subprograms. Also the out parameters will be declared.
-- At this level, parameters may be unconstrained.
-- subprograms. Also the out parameters will be declared. At this
-- level, parameters may be unconstrained.
Statements : constant List_Id := New_List;
......@@ -7835,8 +7832,10 @@ package body Exp_Dist is
-- Controlling formals in distributed object primitive
-- operations are handled specially:
-- - the first controlling formal is used as the
-- target of the call;
-- - the remaining controlling formals are transmitted
-- as RACWs.
......@@ -7932,8 +7931,9 @@ package body Exp_Dist is
-- the object declaration and the variable is set using
-- 'Input instead of 'Read.
Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
Etyp, New_Occurrence_Of (Any, Loc), Decls);
Expr :=
PolyORB_Support.Helpers.Build_From_Any_Call
(Etyp, New_Occurrence_Of (Any, Loc), Decls);
if Constrained then
Append_To (Statements,
......@@ -7941,11 +7941,12 @@ package body Exp_Dist is
Name => New_Occurrence_Of (Object, Loc),
Expression => Expr));
Expr := Empty;
else
null;
else
-- Expr will be used to initialize (and constrain) the
-- parameter when it is declared.
null;
end if;
end if;
......@@ -8006,10 +8007,7 @@ package body Exp_Dist is
(Defining_Identifier (Current_Parameter), Loc),
Explicit_Actual_Parameter =>
Make_Explicit_Dereference (Loc,
Prefix =>
Unchecked_Convert_To (RACW_Type,
OK_Convert_To (RTE (RE_Address),
New_Occurrence_Of (Object, Loc))))));
Prefix => New_Occurrence_Of (Object, Loc))));
else
Append_To (Parameter_List,
......@@ -8019,9 +8017,7 @@ package body Exp_Dist is
(Defining_Identifier (Current_Parameter), Loc),
Explicit_Actual_Parameter =>
Unchecked_Convert_To (RACW_Type,
OK_Convert_To (RTE (RE_Address),
New_Occurrence_Of (Object, Loc)))));
New_Occurrence_Of (Object, Loc)));
end if;
else
......@@ -8201,10 +8197,10 @@ package body Exp_Dist is
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
-- An exception raised during the execution of an incoming
-- remote subprogram call and that needs to be sent back
-- to the caller is propagated by the receiving stubs, and
-- will be handled by the caller (the distribution runtime).
-- An exception raised during the execution of an incoming remote
-- subprogram call and that needs to be sent back to the caller is
-- propagated by the receiving stubs, and will be handled by the
-- caller (the distribution runtime).
if Asynchronous and then not Dynamically_Asynchronous then
......@@ -8648,6 +8644,7 @@ package body Exp_Dist is
New_Occurrence_Of (Rec, Loc),
Selector_Name =>
New_Occurrence_Of (Field, Loc)),
Expression =>
Build_From_Any_Call (Etype (Field),
Build_Get_Aggregate_Element (Loc,
......@@ -9303,6 +9300,7 @@ package body Exp_Dist is
if No (Typ) and then Nkind (N) = N_Selected_Component then
Typ := Etype (Selector_Name (N));
end if;
pragma Assert (Present (Typ));
-- Get full view for private type, completion for incomplete type
......@@ -9731,8 +9729,8 @@ package body Exp_Dist is
Struct_Counter := 0;
TA_Append_Record_Traversal (
Stmts => VP_Stmts,
TA_Append_Record_Traversal
(Stmts => VP_Stmts,
Clist => Component_List (Variant),
Container => Struct_Any,
Counter => Struct_Counter);
......@@ -9742,8 +9740,8 @@ package body Exp_Dist is
Append_To (VP_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Add_Aggregate_Element), Loc),
New_Occurrence_Of
(RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Union_Any, Loc),
New_Occurrence_Of (Struct_Any, Loc))));
......@@ -9753,8 +9751,8 @@ package body Exp_Dist is
Append_To (VP_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Add_Aggregate_Element), Loc),
New_Occurrence_Of
(RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Container, Loc),
New_Occurrence_Of
......@@ -9860,8 +9858,8 @@ package body Exp_Dist is
Set_Expression (Any_Decl,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (
RTE (RE_Any_Aggregate_Build), Loc),
Name => New_Occurrence_Of
(RTE (RE_Any_Aggregate_Build), Loc),
Parameter_Associations => New_List (
Result_TC,
Make_Aggregate (Loc,
......@@ -10993,6 +10991,7 @@ package body Exp_Dist is
Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc)));
else
Inner_Any_TypeCode_Expr :=
Make_Function_Call (Loc,
......@@ -11002,6 +11001,7 @@ package body Exp_Dist is
New_Occurrence_Of (Any, Loc),
Make_Integer_Literal (Loc, Ndim)));
end if;
else
Inner_Any_TypeCode_Expr :=
Make_Function_Call (Loc,
......@@ -11161,9 +11161,12 @@ package body Exp_Dist is
Inst :=
Make_Package_Instantiation (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('R')),
Name =>
New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
Generic_Associations => New_List (
Make_Generic_Association (Loc,
Selector_Name =>
......@@ -11171,6 +11174,7 @@ package body Exp_Dist is
Explicit_Generic_Actual_Parameter =>
Make_String_Literal (Loc,
Strval => Pkg_Name)),
Make_Generic_Association (Loc,
Selector_Name =>
Make_Identifier (Loc, Name_Version),
......@@ -11181,7 +11185,8 @@ package body Exp_Dist is
Attribute_Name =>
Name_Version))));
RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
RCI_Locator_Table.Set
(Defining_Unit_Name (Package_Spec),
Defining_Unit_Name (Inst));
return Inst;
end RCI_Package_Locator;
......@@ -11292,11 +11297,11 @@ package body Exp_Dist is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
Decls, RPC_Receiver, Stub_Elements);
PolyORB_Support.Add_Obj_RPC_Receiver_Completion
(Loc, Decls, RPC_Receiver, Stub_Elements);
when others =>
GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
Decls, RPC_Receiver, Stub_Elements);
GARLIC_Support.Add_Obj_RPC_Receiver_Completion
(Loc, Decls, RPC_Receiver, Stub_Elements);
end case;
end Specific_Add_Obj_RPC_Receiver_Completion;
......@@ -11470,12 +11475,14 @@ package body Exp_Dist is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
return PolyORB_Support.Build_Stub_Target (Loc,
Decls, RCI_Locator, Controlling_Parameter);
return
PolyORB_Support.Build_Stub_Target
(Loc, Decls, RCI_Locator, Controlling_Parameter);
when others =>
return GARLIC_Support.Build_Stub_Target (Loc,
Decls, RCI_Locator, Controlling_Parameter);
return
GARLIC_Support.Build_Stub_Target
(Loc, Decls, RCI_Locator, Controlling_Parameter);
end case;
end Specific_Build_Stub_Target;
......@@ -11485,24 +11492,25 @@ package body Exp_Dist is
procedure Specific_Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id)
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Build_Stub_Type (
RACW_Type, Stub_Type,
Stub_Type_Decl, RPC_Receiver_Decl);
PolyORB_Support.Build_Stub_Type
(RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
when others =>
GARLIC_Support.Build_Stub_Type (
RACW_Type, Stub_Type,
Stub_Type_Decl, RPC_Receiver_Decl);
GARLIC_Support.Build_Stub_Type
(RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
end case;
end Specific_Build_Stub_Type;
-----------------------------------------------
-- Specific_Build_Subprogram_Receiving_Stubs --
-----------------------------------------------
function Specific_Build_Subprogram_Receiving_Stubs
(Vis_Decl : Node_Id;
Asynchronous : Boolean;
......@@ -11514,7 +11522,8 @@ package body Exp_Dist is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
return PolyORB_Support.Build_Subprogram_Receiving_Stubs
return
PolyORB_Support.Build_Subprogram_Receiving_Stubs
(Vis_Decl,
Asynchronous,
Dynamically_Asynchronous,
......@@ -11523,7 +11532,8 @@ package body Exp_Dist is
Parent_Primitive);
when others =>
return GARLIC_Support.Build_Subprogram_Receiving_Stubs
return
GARLIC_Support.Build_Subprogram_Receiving_Stubs
(Vis_Decl,
Asynchronous,
Dynamically_Asynchronous,
......
gcc/ada/sem_disp.adb
......@@ -1775,10 +1775,12 @@ package body Sem_Disp is
-- even if non-dispatching, and a call from inside calls the
-- overriding operation because it hides the implicit one. To
-- indicate that the body of Prev_Op is never called, set its
-- dispatch table entity to Empty.
-- dispatch table entity to Empty. If the overridden operation
-- has a dispatching result, so does the overriding one.
Set_Alias (Prev_Op, New_Op);
Set_DTC_Entity (Prev_Op, Empty);
Set_Has_Controlling_Result (New_Op, Has_Controlling_Result (Prev_Op));
return;
end if;
end Override_Dispatching_Operation;
......
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