-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- Turn off subprogram ordering, not used for this unit
with Atree; use Atree;
-with Namet; use Namet;
with Nlists; use Nlists;
with Sinfo; use Sinfo;
with Stand; use Stand;
-- Overridden_Operation Node26
-- Package_Instantiation Node26
+ -- Related_Interface Node26
+ -- Static_Initialization Node26
-- Wrapped_Entity Node27
-- Is_CPP_Class Flag74
-- Has_Non_Standard_Rep Flag75
-- Is_Constructor Flag76
- -- Is_Thread_Body Flag77
+ -- Static_Elaboration_Desired Flag77
-- Is_Tag Flag78
-- Has_All_Calls_Remote Flag79
-- Is_Constr_Subt_For_U_Nominal Flag80
-- Has_Pragma_Unreferenced_Objects Flag212
-- Requires_Overriding Flag213
-- Has_RACW Flag214
-
- -- (unused) Flag215
+ -- Has_Up_Level_Access Flag215
+ -- Universal_Aliasing Flag216
+ -- Suppress_Value_Tracking_On_Call Flag217
+
+ -- (unused) Flag77
+
+ -- (unused) Flag218
+ -- (unused) Flag219
+ -- (unused) Flag220
+
+ -- (unused) Flag221
+ -- (unused) Flag222
+ -- (unused) Flag223
+ -- (unused) Flag224
+ -- (unused) Flag225
+ -- (unused) Flag226
+ -- (unused) Flag227
+ -- (unused) Flag228
+ -- (unused) Flag229
+ -- (unused) Flag230
-----------------------
-- Local subprograms --
function Has_Stream_Size_Clause (Id : E) return B is
begin
- pragma Assert (Is_Elementary_Type (Id));
return Flag184 (Id);
end Has_Stream_Size_Clause;
return Flag72 (Id);
end Has_Unknown_Discriminants;
+ function Has_Up_Level_Access (Id : E) return B is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Variable
+ or else Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_Loop_Parameter);
+ return Flag215 (Id);
+ end Has_Up_Level_Access;
+
function Has_Volatile_Components (Id : E) return B is
begin
return Flag87 (Implementation_Base_Type (Id));
function Is_Limited_Interface (Id : E) return B is
begin
- pragma Assert (Is_Interface (Id));
return Flag197 (Id);
end Is_Limited_Interface;
return Flag200 (Id);
end Is_Task_Interface;
- function Is_Thread_Body (Id : E) return B is
- begin
- return Flag77 (Id);
- end Is_Thread_Body;
-
function Is_True_Constant (Id : E) return B is
begin
return Flag163 (Id);
return Node24 (Id);
end Obsolescent_Warning;
- function Original_Access_Type (Id : E) return E is
- begin
- pragma Assert
- (Ekind (Id) = E_Access_Subprogram_Type
- or else Ekind (Id) = E_Access_Protected_Subprogram_Type);
- return Node21 (Id);
- end Original_Access_Type;
-
function Original_Array_Type (Id : E) return E is
begin
pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
return Node15 (Id);
end Related_Instance;
+ function Related_Interface (Id : E) return E is
+ begin
+ pragma Assert (Ekind (Id) = E_Component);
+ return Node26 (Id);
+ end Related_Interface;
+
function Renamed_Entity (Id : E) return N is
begin
return Node18 (Id);
return Node15 (Implementation_Base_Type (Id));
end Storage_Size_Variable;
+ function Static_Elaboration_Desired (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) = E_Package);
+ return Flag77 (Id);
+ end Static_Elaboration_Desired;
+
+ function Static_Initialization (Id : E) return N is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Procedure and then not Is_Dispatching_Operation (Id));
+ return Node26 (Id);
+ end Static_Initialization;
+
function Stored_Constraint (Id : E) return L is
begin
pragma Assert
return Flag165 (Id);
end Suppress_Style_Checks;
+ function Suppress_Value_Tracking_On_Call (Id : E) return B is
+ begin
+ return Flag217 (Id);
+ end Suppress_Value_Tracking_On_Call;
+
function Task_Body_Procedure (Id : E) return N is
begin
pragma Assert (Ekind (Id) in Task_Kind);
return Node19 (Id);
end Underlying_Full_View;
+ function Universal_Aliasing (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag216 (Base_Type (Id));
+ end Universal_Aliasing;
+
function Unset_Reference (Id : E) return N is
begin
return Node16 (Id);
Set_Flag101 (Id, V);
end Set_Has_Nested_Block_With_Handler;
+ procedure Set_Has_Up_Level_Access (Id : E; V : B := True) is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Variable
+ or else Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_Loop_Parameter);
+ Set_Flag215 (Id, V);
+ end Set_Has_Up_Level_Access;
+
procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True) is
begin
pragma Assert (Base_Type (Id) = Id);
or else Ekind (Id) = E_Record_Subtype
or else Ekind (Id) = E_Record_Type_With_Private
or else Ekind (Id) = E_Record_Subtype_With_Private
- or else Ekind (Id) = E_Class_Wide_Type);
+ or else Ekind (Id) = E_Class_Wide_Type
+ or else Ekind (Id) = E_Class_Wide_Subtype);
Set_Flag186 (Id, V);
end Set_Is_Interface;
Set_Flag55 (Id, V);
end Set_Is_Tagged_Type;
- procedure Set_Is_Thread_Body (Id : E; V : B := True) is
- begin
- Set_Flag77 (Id, V);
- end Set_Is_Thread_Body;
-
procedure Set_Is_Task_Interface (Id : E; V : B := True) is
begin
pragma Assert (Is_Interface (Id));
Set_Node24 (Id, V);
end Set_Obsolescent_Warning;
- procedure Set_Original_Access_Type (Id : E; V : E) is
- begin
- pragma Assert
- (Ekind (Id) = E_Access_Subprogram_Type
- or else Ekind (Id) = E_Access_Protected_Subprogram_Type);
- Set_Node21 (Id, V);
- end Set_Original_Access_Type;
-
procedure Set_Original_Array_Type (Id : E; V : E) is
begin
pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
Set_Node15 (Id, V);
end Set_Related_Instance;
+ procedure Set_Related_Interface (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind (Id) = E_Component);
+ Set_Node26 (Id, V);
+ end Set_Related_Interface;
+
procedure Set_Renamed_Entity (Id : E; V : N) is
begin
Set_Node18 (Id, V);
Set_Node15 (Id, V);
end Set_Storage_Size_Variable;
+ procedure Set_Static_Elaboration_Desired (Id : E; V : B) is
+ begin
+ pragma Assert (Ekind (Id) = E_Package);
+ Set_Flag77 (Id, V);
+ end Set_Static_Elaboration_Desired;
+
+ procedure Set_Static_Initialization (Id : E; V : N) is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Procedure and then not Is_Dispatching_Operation (Id));
+ Set_Node26 (Id, V);
+ end Set_Static_Initialization;
+
procedure Set_Stored_Constraint (Id : E; V : L) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag165 (Id, V);
end Set_Suppress_Style_Checks;
+ procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True) is
+ begin
+ Set_Flag217 (Id, V);
+ end Set_Suppress_Value_Tracking_On_Call;
+
procedure Set_Task_Body_Procedure (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) in Task_Kind);
Set_Node19 (Id, V);
end Set_Underlying_Full_View;
+ procedure Set_Universal_Aliasing (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id) and then Base_Type (Id) = Id);
+ Set_Flag216 (Id, V);
+ end Set_Universal_Aliasing;
+
procedure Set_Unset_Reference (Id : E; V : N) is
begin
Set_Node16 (Id, V);
Set_Last_Entity (V, Id);
end Append_Entity;
+ --------------------
+ -- Available_View --
+ --------------------
+
+ function Available_View (Id : E) return E is
+ begin
+ if Is_Incomplete_Type (Id)
+ and then Present (Non_Limited_View (Id))
+ then
+ return Non_Limited_View (Id);
+
+ elsif Is_Class_Wide_Type (Id)
+ and then Is_Incomplete_Type (Etype (Id))
+ and then Present (Non_Limited_View (Etype (Id)))
+ then
+ return Class_Wide_Type (Non_Limited_View (Etype (Id)));
+
+ else
+ return Id;
+ end if;
+ end Available_View;
+
---------------
-- Base_Type --
---------------
-- Is_By_Reference_Type --
--------------------------
+ -- This function knows too much semantics, it should be in sem_util ???
+
function Is_By_Reference_Type (Id : E) return B is
Btype : constant Entity_Id := Base_Type (Id);
elsif Is_Private_Type (Btype) then
declare
Utyp : constant Entity_Id := Underlying_Type (Btype);
-
begin
if No (Utyp) then
return False;
end if;
end;
+ elsif Is_Incomplete_Type (Btype) then
+ declare
+ Ftyp : constant Entity_Id := Full_View (Btype);
+ begin
+ if No (Ftyp) then
+ return False;
+ else
+ return Is_By_Reference_Type (Ftyp);
+ end if;
+ end;
+
elsif Is_Concurrent_Type (Btype) then
return True;
elsif Is_Record_Type (Btype) then
+ if Is_Limited_Interface (Id) then
+ return True;
+
-- AI-419: limitedness is not inherited from a limited interface
- if Is_Limited_Record (Rtype) then
+ elsif Is_Limited_Record (Rtype) then
return not Is_Interface (Rtype)
or else Is_Protected_Interface (Rtype)
or else Is_Synchronized_Interface (Rtype)
if Ekind (T) = E_Class_Wide_Type then
return Etype (T);
+ elsif Ekind (T) = E_Class_Wide_Subtype then
+ return Etype (Base_Type (T));
+
-- All other cases
else
W ("Has_Task", Flag30 (Id));
W ("Has_Unchecked_Union", Flag123 (Id));
W ("Has_Unknown_Discriminants", Flag72 (Id));
+ W ("Has_Up_Level_Access", Flag215 (Id));
W ("Has_Volatile_Components", Flag87 (Id));
W ("Has_Xref_Entry", Flag182 (Id));
W ("In_Package_Body", Flag48 (Id));
W ("Is_Tag", Flag78 (Id));
W ("Is_Tagged_Type", Flag55 (Id));
W ("Is_Task_Interface", Flag200 (Id));
- W ("Is_Thread_Body", Flag77 (Id));
W ("Is_True_Constant", Flag163 (Id));
W ("Is_Unchecked_Union", Flag117 (Id));
W ("Is_Unsigned_Type", Flag144 (Id));
W ("Sec_Stack_Needed_For_Return", Flag167 (Id));
W ("Size_Depends_On_Discriminant", Flag177 (Id));
W ("Size_Known_At_Compile_Time", Flag92 (Id));
+ W ("Static_Elaboration_Desired", Flag77 (Id));
W ("Strict_Alignment", Flag145 (Id));
W ("Suppress_Elaboration_Warnings", Flag148 (Id));
W ("Suppress_Init_Proc", Flag105 (Id));
W ("Suppress_Style_Checks", Flag165 (Id));
+ W ("Suppress_Value_Tracking_On_Call", Flag217 (Id));
W ("Treat_As_Volatile", Flag41 (Id));
+ W ("Universal_Aliasing", Flag216 (Id));
W ("Uses_Sec_Stack", Flag95 (Id));
W ("Vax_Float", Flag151 (Id));
W ("Warnings_Off", Flag96 (Id));
E_Component |
E_Constant |
E_Discriminant |
+ E_Exception |
E_In_Parameter |
E_In_Out_Parameter |
E_Out_Parameter |
when Type_Kind |
Formal_Kind |
E_Constant |
+ E_Exception |
E_Variable |
E_Loop_Parameter =>
Write_Str ("Alignment");
Modular_Integer_Kind =>
Write_Str ("Original_Array_Type");
- when E_Access_Subprogram_Type |
- E_Access_Protected_Subprogram_Type =>
- Write_Str ("Original_Access_Type");
-
when others =>
Write_Str ("Field21??");
end case;
procedure Write_Field26_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Component =>
+ Write_Str ("Related_Interface");
+
when E_Generic_Package |
E_Package =>
Write_Str ("Package_Instantiation");
when E_Procedure |
E_Function =>
- Write_Str ("Overridden_Operation");
+
+ if Is_Dispatching_Operation (Id) then
+ Write_Str ("Overridden_Operation");
+ else
+ Write_Str ("Static_Initialization");
+ end if;
when others =>
Write_Str ("Field26??");
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- --
------------------------------------------------------------------------------
+with Namet; use Namet;
with Snames; use Snames;
with Types; use Types;
with Uintp; use Uintp;
-- Access_Disp_Table (Elist16) [implementation base type only]
-- Present in record type entities. For a tagged type, points to the
--- dispatch tables associated with the tagged type. For a non-tagged
--- record, contains Empty.
+-- dispatch tables associated with the tagged type; the last entity of
+-- this list is an access type declaration used to expand dispatching
+-- calls through the primary dispatch table. For a non-tagged record,
+-- contains Empty.
-- Address_Clause (synthesized)
-- Applies to entries, objects and subprograms. Set if an address clause
-- subprogram. Always empty for entries.
-- Alignment (Uint14)
--- Present in entities for types and also in constants, variables,
--- loop parameters, and formal parameters. This indicates the desired
--- alignment for a type, or the actual alignment for an object. A value
--- of zero (Uint_0) indicates that the alignment has not been set yet.
--- The alignment can be set by an explicit alignment clause, or set by
--- the front-end in package Layout, or set by the back-end as part of
--- the back end back-annotation process. The alignment field is also
--- present in E_Exception entities, but there it is used only by the
--- back-end for back annotation.
+-- Present in entities for types and also in constants, variables
+-- (including exceptions where it refers to the static data allocated for
+-- an exception), loop parameters, and formal parameters. This indicates
+-- the desired alignment for a type, or the actual alignment for an
+-- object. A value of zero (Uint_0) indicates that the alignment has not
+-- been set yet. The alignment can be set by an explicit alignment
+-- clause, or set by the front-end in package Layout, or set by the
+-- back-end as part of the back end back-annotation process. The
+-- alignment field is also present in E_Exception entities, but there it
+-- is used only by the back-end for back annotation.
-- Alignment_Clause (synthesized)
-- Applies to all entities for types and objects. If an alignment
-- subtype then it returns the subtype or type from which the subtype
-- was obtained, otherwise it returns Empty.
+-- Available_View (synthesized)
+-- Applies to types that have the With_Type flag set. Returns the
+-- non-limited view of the type, if available, otherwise the type
+-- itself. For class-wide types, there is no direct link in the tree,
+-- so we have to retrieve the class-wide type of the non-limited view
+-- of the Etype.
+
-- Associated_Formal_Package (Node12)
-- Present in packages that are the actuals of formal_packages. Points
-- to the entity in the declaration for the formal package.
-- Export pragma).
-- Can_Never_Be_Null (Flag38)
--- This flag is present in all entities, but can only be set in an
--- object which can never have a null value. This is used to avoid
--- unncessary resetting of the Is_Known_Non_Null flag for such
--- entities. The cases where this is set True are constant access
--- values initialized to a non-null value, and access parameters.
+-- This flag is present in all entities, but can only be set in an object
+-- which can never have a null value. This is set True for constant
+-- access values initialized to a non-null value. This is also True for
+-- all access parameters in Ada 83 and Ada 95 modes, and for access
+-- parameters that explicily exlude null in Ada 2005.
+--
+-- This is used to avoid unnecessary resetting of the Is_Known_Non_Null
+-- flag for such entities. In Ada 2005 mode, this is also used when
+-- determining subtype conformance of subprogram profiles to ensure
+-- that two formals have the same null-exclusion status.
+--
+-- ??? This is also set on some access types, eg the Etype of the
+-- anonymous access type of a controlling formal.
-- Chars (Name1)
-- Present in all entities. This field contains an entry into the names
-- Esize (Uint12)
-- Present in all types and subtypes, and also for components, constants,
--- and variables. Contains the Object_Size of the type or of the object.
--- A value of zero indicates that the value is not yet known.
+-- and variables, including exceptions where it refers to the static data
+-- allocated for an exception. Contains the Object_Size of the type or of
+-- the object. A value of zero indicates that the value is not yet known.
--
-- For the case of components where a component clause is present, the
-- value is the value from the component clause, which must be non-
-- clause whose entries are successive integers.
-- Has_Controlling_Result (Flag98)
--- Present in E_Function entities. True if The function is a primitive
--- function of a tagged type which can dispatch on result
+-- Present in E_Function entities. True if the function is a primitive
+-- function of a tagged type which can dispatch on result.
-- Has_Controlled_Component (Flag43) [base type only]
-- Present in all entities. Set only for composite type entities which
-- control wrapping of the body in Exp_Ch6 to ensure that the program
-- error exeption is correctly raised in this case at runtime.
+-- Has_Up_Level_Access (Flag215)
+-- Present in E_Variable and E_Constant entities. Set if the entity is
+-- declared in a local procedure p and is accessed in a procedure nested
+-- inside p. Only set when VM_Target /= No_VM currently.
+
-- Has_Nested_Block_With_Handler (Flag101)
-- Present in scope entities. Set if there is a nested block within the
-- scope that has an exception handler and the two scopes are in the
-- Known_To_Have_Preelab_Init (Flag207)
-- Present in all type and subtype entities. If set, then the type is
-- known to have preelaborable initialization. In the case of a partial
--- view of a private type, it is only possible for this tobe set if a
+-- view of a private type, it is only possible for this to be set if a
-- pragma Preelaborable_Initialization is given for the type. For other
-- types, it is never set if the type does not have preelaborable
-- initialization, it may or may not be set if the type does have
-- storage size clause cannot be given to a derived type.
-- Has_Stream_Size_Clause (Flag184)
--- This flag is set on types which have a Stream_Size clause attribute.
--- Used to prevent multiple Stream_Size clauses for a given entity.
+-- This flag is present in all entities. It is set for types which have a
+-- Stream_Size clause attribute. Used to prevent multiple Stream_Size
+-- clauses for a given entity, and also whether it is necessary to check
+-- for a stream size clause.
-- Has_Subprogram_Descriptor (Flag93)
-- This flag is set on entities for which zero-cost exception subprogram
-- type itself (RM 7.3.1 (5)).
-- Is_Limited_Interface (Flag197)
--- Present in types that are interfaces. True if interface is declared
--- limited, or is derived from limited interfaces.
+-- Present in record types and subtypes. True for interface types, if
+-- interface is declared limited, task, protected, or synchronized, or
+-- is derived from a limited interface.
-- Is_Limited_Record (Flag25)
-- Present in all entities. Set to true for record (sub)types if the
-- Is_Limited_Type (synthesized)
-- Applies to all entities. True if entity is a limited type (limited
--- private type, task type, protected type, composite containing a
--- limited component, or a subtype of any of these types).
+-- private type, limited interface type, task type, protected type,
+-- composite containing a limited component, or a subtype of any of
+-- these types).
-- Is_Machine_Code_Subprogram (Flag137)
-- Present in subprogram entities. Set to indicate that the subprogram
-- component type that is a character type.
-- Is_Synchronized_Interface (Flag199)
--- Present_types that are interfaces. True is interface is declared
--- synchronized, or is derived from synchronized interfaces.
+-- Present in types that are interfaces. True if interface is declared
+-- synchronized, task, or protected, or is derived from a synchronized
+-- interface.
-- Is_Tag (Flag78)
-- Present in E_Component. For regular tagged type this flag is set on
-- Is_Task_Type (synthesized)
-- Applies to all entities, true for task types and subtypes
--- Is_Thread_Body (Flag77)
--- Applies to subprogram entities. Set if a valid Thread_Body pragma
--- applies to this subprogram, which is thus a thread body.
-
-- Is_True_Constant (Flag163)
-- This flag is set in constants and variables which have an initial
-- value specified but which are never assigned, partially or in the
-- the contents of the corresponding string literal node. This field is
-- only accessed if the flag Is_Obsolescent is set.
--- Original_Access_Type (Node21)
--- Present in access to subprogram types. Anonymous access to protected
--- subprogram types are replaced by an occurrence of an internal access
--- to subprogram type. This field links the replacement entity with the
--- original entity.
-
-- Original_Array_Type (Node21)
-- Present in modular types and array types and subtypes. Set only
-- if the Is_Packed_Array_Type flag is set, indicating that the type
-- wrapper package, but for debugging purposes its external symbol
-- must correspond to the name and scope of the related instance.
+-- Related_Interface (Node26)
+-- Present in components associated with secondary dispatch tables
+-- (dispatch table pointers and offset components). Set to point to the
+-- entity of the corresponding interface type.
+
-- Renamed_Entity (Node18)
--- Present in exceptions, packages and generic units that are defined
--- by a renaming declaration. Denotes the renamed entity, or transit-
--- itively the ultimate renamed entity if there is a chain of renaming
--- declarations.
+-- Present in exceptions, packages, subprograms and generic units. Set
+-- for entities that are defined by a renaming declaration. Denotes the
+-- renamed entity, or transititively the ultimate renamed entity if
+-- there is a chain of renaming declarations. Empty if no renaming.
-- Renamed_Object (Node18)
-- Present in all objects (constants, variables, components, formal
-- this field is present only in the root type (since derived types
-- share the same storage pool).
+-- Static_Elaboration_Desired (Flag77)
+-- Present in library-level packages. Set by the pragma of the same
+-- name, to indicate that static initialization must be attempted for
+-- all types declared in the package, and that a warning must be emitted
+-- for those types to which static initialization is not available.
+
+-- Static_Initialization (Node26)
+-- Present in initialization procedures for types whose objects can be
+-- initialized statically. The value of this attribute is a positional
+-- aggregate whose components are compile-time static values. Used
+-- when available in object declarations to eliminate the call to the
+-- initialization procedure, and to minimize elaboration code.
+
-- Stored_Constraint (Elist23)
-- Present in entities that can have discriminants (concurrent types
-- subtypes, record types and subtypes, private types and subtypes,
-- Present in all entities. Suppresses any style checks specifically
-- associated with the given entity if set.
+-- Suppress_Value_Tracking_On_Call (Flag217)
+-- Present in all entities. Set in a scope entity if value tracking is to
+-- be suppressed on any call within the scope. Used when an access to a
+-- local subprogram is computed, to deal with the possibility that this
+-- value may be passed around, and if used, may clobber a local variable.
+
-- Task_Body_Procedure (Node25)
-- Present in task types and subtypes. Points to the entity for
-- the task body procedure (as further described in Exp_Ch9, task
-- entity which may or may not be a type, with the intent that if it is a
-- type, its underlying type is taken.
+-- Universal_Aliasing (Flag216) [base type only]
+-- Present in all type entities. Set to direct the back-end to avoid
+-- any optimizations based on type-based alias analysis for this type.
+-- Indicates that objects of this type can alias objects of any other
+-- types, which guarantees that any objects can be referenced through
+-- access types designating this type safely, whatever the actual type
+-- of these objects. In other words, the effect is as though access
+-- types designating this type were subject to No_Strict_Aliasing.
+
-- Unset_Reference (Node16)
-- Present in variables and out parameters. This is normally Empty. It
-- is set to point to an identifier that represents a reference to the
-- Referenced_As_LHS (Flag36)
-- Suppress_Elaboration_Warnings (Flag148)
-- Suppress_Style_Checks (Flag165)
+ -- Suppress_Value_Tracking_On_Call (Flag217)
-- Was_Hidden (Flag196)
-- Declaration_Node (synth)
-- Has_Specified_Stream_Output (Flag191)
-- Has_Specified_Stream_Read (Flag192)
-- Has_Specified_Stream_Write (Flag193)
+ -- Has_Stream_Size_Clause (Flag184)
-- Has_Task (Flag30) (base type only)
-- Has_Unchecked_Union (Flag123) (base type only)
-- Has_Volatile_Components (Flag87) (base type only)
-- Is_Frozen (Flag4)
-- Is_Generic_Actual_Type (Flag94)
-- Is_Generic_Type (Flag13)
- -- Is_Limited_Interface (Flag197)
-- Is_Protected_Interface (Flag198)
-- Is_Synchronized_Interface (Flag199)
-- Is_Task_Interface (Flag200)
-- Strict_Alignment (Flag145) (base type only)
-- Suppress_Init_Proc (Flag105) (base type only)
-- Treat_As_Volatile (Flag41)
+ -- Universal_Aliasing (Flag216) (base type only)
-- Alignment_Clause (synth)
-- Ancestor_Subtype (synth)
-- E_Access_Protected_Subprogram_Type
-- Equivalent_Type (Node18)
-- Directly_Designated_Type (Node20)
- -- Original_Access_Type (Node21)
-- Needs_No_Actuals (Flag22)
-- (plus type attributes)
-- E_Access_Subprogram_Type
-- Equivalent_Type (Node18) (remote types only)
-- Directly_Designated_Type (Node20)
- -- Original_Access_Type (Node21)
-- Needs_No_Actuals (Flag22)
-- (plus type attributes)
-- Original_Record_Component (Node22)
-- Protected_Operation (Node23)
-- DT_Offset_To_Top_Func (Node25)
+ -- Related_Interface (Node26)
-- Has_Biased_Representation (Flag139)
-- Has_Per_Object_Constraint (Flag154)
-- Is_Atomic (Flag85)
-- Has_Biased_Representation (Flag139)
-- Has_Completion (Flag26) (constants only)
-- Has_Size_Clause (Flag29)
+ -- Has_Up_Level_Access (Flag215)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
-- (plus type attributes)
-- E_Exception
+ -- Esize (Uint12)
-- Alignment (Uint14)
-- Renamed_Entity (Node18)
-- Register_Exception_Call (Node20)
-- Is_Overriding_Operation (Flag39) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Pure (Flag44)
- -- Is_Thread_Body (Flag77) (non-generic case only)
-- Is_Visible_Child_Unit (Flag116)
-- Needs_No_Actuals (Flag22)
-- Requires_Overriding (Flag213) (non-generic case only)
-- Is_Visible_Child_Unit (Flag116)
-- Is_Wrapper_Package (synth) (non-generic case only)
-- Scope_Depth (synth)
+ -- Static_Elaboration_Desired (Flag77) (non-generic case only)
-- E_Package_Body
-- Handler_Records (List10) (non-generic case only)
-- Inner_Instances (Elist23) (for generic proc)
-- Privals_Chain (Elist23) (for protected proc)
-- Abstract_Interface_Alias (Node25)
+ -- Static_Initialization (Node26) (init_proc only)
-- Overridden_Operation (Node26)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Extra_Formals (Node28)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Pure (Flag44)
- -- Is_Thread_Body (Flag77) (non-generic case only)
-- Is_Valued_Procedure (Flag127)
-- Is_Visible_Child_Unit (Flag116)
-- Needs_No_Actuals (Flag22)
-- Is_Constrained (Flag12)
-- Is_Controlled (Flag42) (base type only)
-- Is_Interface (Flag186)
+ -- Is_Limited_Interface (Flag197)
-- Reverse_Bit_Order (Flag164) (base type only)
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
-- Is_Constrained (Flag12)
-- Is_Controlled (Flag42) (base type only)
-- Is_Interface (Flag186)
+ -- Is_Limited_Interface (Flag197)
-- Reverse_Bit_Order (Flag164) (base type only)
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
-- Never_Set_In_Source (Flag115)
-- Treat_As_Volatile (Flag41)
-- Is_Return_Object (Flag209)
+ -- Has_Up_Level_Access (Flag215)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
-- Constant_Value (synth)
function Has_Missing_Return (Id : E) return B;
function Has_Nested_Block_With_Handler (Id : E) return B;
function Has_Forward_Instantiation (Id : E) return B;
+ function Has_Up_Level_Access (Id : E) return B;
function Has_Non_Standard_Rep (Id : E) return B;
function Has_Object_Size_Clause (Id : E) return B;
function Has_Per_Object_Constraint (Id : E) return B;
function Is_Tag (Id : E) return B;
function Is_Tagged_Type (Id : E) return B;
function Is_Task_Interface (Id : E) return B;
- function Is_Thread_Body (Id : E) return B;
function Is_True_Constant (Id : E) return B;
function Is_Unchecked_Union (Id : E) return B;
function Is_Unsigned_Type (Id : E) return B;
function Normalized_Position_Max (Id : E) return U;
function Object_Ref (Id : E) return E;
function Obsolescent_Warning (Id : E) return N;
- function Original_Access_Type (Id : E) return E;
function Original_Array_Type (Id : E) return E;
function Original_Record_Component (Id : E) return E;
function Overridden_Operation (Id : E) return E;
function Register_Exception_Call (Id : E) return N;
function Related_Array_Object (Id : E) return E;
function Related_Instance (Id : E) return E;
+ function Related_Interface (Id : E) return E;
function Renamed_Entity (Id : E) return N;
function Renamed_Object (Id : E) return N;
function Renaming_Map (Id : E) return U;
function Small_Value (Id : E) return R;
function Spec_Entity (Id : E) return E;
function Storage_Size_Variable (Id : E) return E;
+ function Static_Elaboration_Desired (Id : E) return B;
+ function Static_Initialization (Id : E) return N;
function Stored_Constraint (Id : E) return L;
function Strict_Alignment (Id : E) return B;
function String_Literal_Length (Id : E) return U;
function Suppress_Elaboration_Warnings (Id : E) return B;
function Suppress_Init_Proc (Id : E) return B;
function Suppress_Style_Checks (Id : E) return B;
+ function Suppress_Value_Tracking_On_Call (Id : E) return B;
function Task_Body_Procedure (Id : E) return N;
function Treat_As_Volatile (Id : E) return B;
function Underlying_Full_View (Id : E) return E;
+ function Universal_Aliasing (Id : E) return B;
function Unset_Reference (Id : E) return N;
function Uses_Sec_Stack (Id : E) return B;
function Vax_Float (Id : E) return B;
function Address_Clause (Id : E) return N;
function Alignment_Clause (Id : E) return N;
function Ancestor_Subtype (Id : E) return E;
+ function Available_View (Id : E) return E;
function Base_Type (Id : E) return E;
function Constant_Value (Id : E) return N;
function Declaration_Node (Id : E) return N;
procedure Set_Has_Missing_Return (Id : E; V : B := True);
procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True);
procedure Set_Has_Forward_Instantiation (Id : E; V : B := True);
+ procedure Set_Has_Up_Level_Access (Id : E; V : B := True);
procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True);
procedure Set_Has_Object_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True);
procedure Set_Is_Tag (Id : E; V : B := True);
procedure Set_Is_Tagged_Type (Id : E; V : B := True);
procedure Set_Is_Task_Interface (Id : E; V : B := True);
- procedure Set_Is_Thread_Body (Id : E; V : B := True);
procedure Set_Is_True_Constant (Id : E; V : B := True);
procedure Set_Is_Unchecked_Union (Id : E; V : B := True);
procedure Set_Is_Unsigned_Type (Id : E; V : B := True);
procedure Set_Normalized_Position_Max (Id : E; V : U);
procedure Set_Object_Ref (Id : E; V : E);
procedure Set_Obsolescent_Warning (Id : E; V : N);
- procedure Set_Original_Access_Type (Id : E; V : E);
procedure Set_Original_Array_Type (Id : E; V : E);
procedure Set_Original_Record_Component (Id : E; V : E);
procedure Set_Overridden_Operation (Id : E; V : E);
procedure Set_Register_Exception_Call (Id : E; V : N);
procedure Set_Related_Array_Object (Id : E; V : E);
procedure Set_Related_Instance (Id : E; V : E);
+ procedure Set_Related_Interface (Id : E; V : E);
procedure Set_Renamed_Entity (Id : E; V : N);
procedure Set_Renamed_Object (Id : E; V : N);
procedure Set_Renaming_Map (Id : E; V : U);
procedure Set_Small_Value (Id : E; V : R);
procedure Set_Spec_Entity (Id : E; V : E);
procedure Set_Storage_Size_Variable (Id : E; V : E);
+ procedure Set_Static_Elaboration_Desired (Id : E; V : B);
+ procedure Set_Static_Initialization (Id : E; V : N);
procedure Set_Stored_Constraint (Id : E; V : L);
procedure Set_Strict_Alignment (Id : E; V : B := True);
procedure Set_String_Literal_Length (Id : E; V : U);
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True);
procedure Set_Suppress_Init_Proc (Id : E; V : B := True);
procedure Set_Suppress_Style_Checks (Id : E; V : B := True);
+ procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True);
procedure Set_Task_Body_Procedure (Id : E; V : N);
procedure Set_Treat_As_Volatile (Id : E; V : B := True);
procedure Set_Underlying_Full_View (Id : E; V : E);
+ procedure Set_Universal_Aliasing (Id : E; V : B := True);
procedure Set_Unset_Reference (Id : E; V : N);
procedure Set_Uses_Sec_Stack (Id : E; V : B := True);
procedure Set_Vax_Float (Id : E; V : B := True);
pragma Inline (Has_Task);
pragma Inline (Has_Unchecked_Union);
pragma Inline (Has_Unknown_Discriminants);
+ pragma Inline (Has_Up_Level_Access);
pragma Inline (Has_Volatile_Components);
pragma Inline (Has_Xref_Entry);
pragma Inline (Hiding_Loop_Variable);
pragma Inline (Is_Tag);
pragma Inline (Is_Tagged_Type);
pragma Inline (Is_Task_Interface);
- pragma Inline (Is_Thread_Body);
pragma Inline (Is_True_Constant);
pragma Inline (Is_Task_Type);
pragma Inline (Is_Type);
pragma Inline (Normalized_Position_Max);
pragma Inline (Object_Ref);
pragma Inline (Obsolescent_Warning);
- pragma Inline (Original_Access_Type);
pragma Inline (Original_Array_Type);
pragma Inline (Original_Record_Component);
pragma Inline (Overridden_Operation);
pragma Inline (Register_Exception_Call);
pragma Inline (Related_Array_Object);
pragma Inline (Related_Instance);
+ pragma Inline (Related_Interface);
pragma Inline (Renamed_Entity);
pragma Inline (Renamed_Object);
pragma Inline (Renaming_Map);
pragma Inline (Small_Value);
pragma Inline (Spec_Entity);
pragma Inline (Storage_Size_Variable);
+ pragma Inline (Static_Elaboration_Desired);
+ pragma Inline (Static_Initialization);
pragma Inline (Stored_Constraint);
pragma Inline (Strict_Alignment);
pragma Inline (String_Literal_Length);
pragma Inline (Suppress_Elaboration_Warnings);
pragma Inline (Suppress_Init_Proc);
pragma Inline (Suppress_Style_Checks);
+ pragma Inline (Suppress_Value_Tracking_On_Call);
pragma Inline (Task_Body_Procedure);
pragma Inline (Treat_As_Volatile);
pragma Inline (Underlying_Full_View);
+ pragma Inline (Universal_Aliasing);
pragma Inline (Unset_Reference);
pragma Inline (Uses_Sec_Stack);
pragma Inline (Vax_Float);
pragma Inline (Set_Has_Pragma_Pure_Function);
pragma Inline (Set_Has_Pragma_Unreferenced);
pragma Inline (Set_Has_Pragma_Unreferenced_Objects);
- pragma Inline (Set_Known_To_Have_Preelab_Init);
pragma Inline (Set_Has_Primitive_Operations);
pragma Inline (Set_Has_Private_Declaration);
pragma Inline (Set_Has_Qualified_Name);
pragma Inline (Set_Has_Specified_Stream_Write);
pragma Inline (Set_Has_Static_Discriminants);
pragma Inline (Set_Has_Storage_Size_Clause);
+ pragma Inline (Set_Has_Stream_Size_Clause);
pragma Inline (Set_Has_Subprogram_Descriptor);
pragma Inline (Set_Has_Task);
pragma Inline (Set_Has_Unchecked_Union);
pragma Inline (Set_Has_Unknown_Discriminants);
+ pragma Inline (Set_Has_Up_Level_Access);
pragma Inline (Set_Has_Volatile_Components);
pragma Inline (Set_Has_Xref_Entry);
pragma Inline (Set_Hiding_Loop_Variable);
pragma Inline (Set_Is_Tag);
pragma Inline (Set_Is_Tagged_Type);
pragma Inline (Set_Is_Task_Interface);
- pragma Inline (Set_Is_Thread_Body);
pragma Inline (Set_Is_True_Constant);
pragma Inline (Set_Is_Unchecked_Union);
pragma Inline (Set_Is_Unsigned_Type);
pragma Inline (Set_Kill_Elaboration_Checks);
pragma Inline (Set_Kill_Range_Checks);
pragma Inline (Set_Kill_Tag_Checks);
+ pragma Inline (Set_Known_To_Have_Preelab_Init);
pragma Inline (Set_Last_Assignment);
pragma Inline (Set_Last_Entity);
pragma Inline (Set_Limited_View);
pragma Inline (Set_Normalized_Position_Max);
pragma Inline (Set_Object_Ref);
pragma Inline (Set_Obsolescent_Warning);
- pragma Inline (Set_Original_Access_Type);
pragma Inline (Set_Original_Array_Type);
pragma Inline (Set_Original_Record_Component);
pragma Inline (Set_Overridden_Operation);
pragma Inline (Set_Register_Exception_Call);
pragma Inline (Set_Related_Array_Object);
pragma Inline (Set_Related_Instance);
+ pragma Inline (Set_Related_Interface);
pragma Inline (Set_Renamed_Entity);
pragma Inline (Set_Renamed_Object);
pragma Inline (Set_Renaming_Map);
pragma Inline (Set_Small_Value);
pragma Inline (Set_Spec_Entity);
pragma Inline (Set_Storage_Size_Variable);
+ pragma Inline (Set_Static_Elaboration_Desired);
+ pragma Inline (Set_Static_Initialization);
pragma Inline (Set_Stored_Constraint);
pragma Inline (Set_Strict_Alignment);
pragma Inline (Set_String_Literal_Length);
pragma Inline (Set_Suppress_Elaboration_Warnings);
pragma Inline (Set_Suppress_Init_Proc);
pragma Inline (Set_Suppress_Style_Checks);
+ pragma Inline (Set_Suppress_Value_Tracking_On_Call);
pragma Inline (Set_Task_Body_Procedure);
pragma Inline (Set_Treat_As_Volatile);
pragma Inline (Set_Underlying_Full_View);
+ pragma Inline (Set_Universal_Aliasing);
pragma Inline (Set_Unset_Reference);
pragma Inline (Set_Uses_Sec_Stack);
pragma Inline (Set_Vax_Float);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
Acc_Type : Entity_Id;
Type_Id : Entity_Id;
- function Mark_Allocator (Nod : Node_Id) return Traverse_Result;
- -- Ada 2005 AI-162: Traverse the expression for an allocator, to locate
- -- inner allocators that may specify access discriminants. Such access
- -- discriminants are coextensions of the enclosing objects. They should
- -- be allocated from the same storage pool as the enclosing object, and
- -- deallocated at the same time as the enclosing object. They are
- -- linked to the enclosing allocator to simplify this sharing.
- -- On the other hand, access discriminants for stack-allocated objects
- -- are themselves allocated statically, and do not carry the flag.
-
- --------------------
- -- Mark_Allocator --
- --------------------
-
- function Mark_Allocator (Nod : Node_Id) return Traverse_Result is
- begin
- if Nkind (Nod) = N_Allocator
- and then Nkind (Parent (Nod)) = N_Index_Or_Discriminant_Constraint
- then
- Set_Is_Coextension (Nod);
-
- if No (Coextensions (N)) then
- Set_Coextensions (N, New_Elmt_List);
- end if;
-
- Append_Elmt (Nod, Coextensions (N));
- end if;
-
- return OK;
- end Mark_Allocator;
-
- procedure Mark_Coextensions is new Traverse_Proc (Mark_Allocator);
-
- -- Start of processing for Analyze_Allocator
-
begin
Check_Restriction (No_Allocators, N);
- Set_Coextensions (N, No_Elist);
- Mark_Coextensions (E);
if Nkind (E) = N_Qualified_Expression then
if not Is_Overloaded (P) then
if Is_Access_Type (Etype (P)) then
- -- Set the Etype. We need to go thru Is_For_Access_Subtypes
- -- to avoid other problems caused by the Private_Subtype
- -- and it is safe to go to the Base_Type because this is the
- -- same as converting the access value to its Base_Type.
+ -- Set the Etype. We need to go thru Is_For_Access_Subtypes to
+ -- avoid other problems caused by the Private_Subtype and it is
+ -- safe to go to the Base_Type because this is the same as
+ -- converting the access value to its Base_Type.
declare
DT : Entity_Id := Designated_Type (Etype (P));
DT := Base_Type (DT);
end if;
- Set_Etype (N, DT);
+ -- An explicit dereference is a legal occurrence of an
+ -- incomplete type imported through a limited_with clause,
+ -- if the full view is visible.
+
+ if From_With_Type (DT)
+ and then not From_With_Type (Scope (DT))
+ and then
+ (Is_Immediately_Visible (Scope (DT))
+ or else
+ (Is_Child_Unit (Scope (DT))
+ and then Is_Visible_Child_Unit (Scope (DT))))
+ then
+ Set_Etype (N, Available_View (DT));
+
+ else
+ Set_Etype (N, DT);
+ end if;
end;
elsif Etype (P) /= Any_Type then
Set_Name (N, P);
Set_Parameter_Associations (N, Exprs);
+ -- Analyze actuals prior to analyzing the call itself.
+
Actual := First (Parameter_Associations (N));
while Present (Actual) loop
Analyze (Actual);
Check_Parameterless_Call (Actual);
- Next_Actual (Actual);
+
+ -- Move to next actual. Note that we use Next, not Next_Actual
+ -- here. The reason for this is a bit subtle. If a function call
+ -- includes named associations, the parser recognizes the node as
+ -- a call, and it is analyzed as such. If all associations are
+ -- positional, the parser builds an indexed_component node, and
+ -- it is only after analysis of the prefix that the construct
+ -- is recognized as a call, in which case Process_Function_Call
+ -- rewrites the node and analyzes the actuals. If the list of
+ -- actuals is malformed, the parser may leave the node as an
+ -- indexed component (despite the presence of named associations).
+ -- The iterator Next_Actual is equivalent to Next if the list is
+ -- positional, but follows the normalized chain of actuals when
+ -- named associations are present. In this case normalization has
+ -- not taken place, and actuals remain unanalyzed, which leads to
+ -- subsequent crashes or loops if there is an attempt to continue
+ -- analysis of the program.
+
+ Next (Actual);
end loop;
Analyze_Call (N);
Get_Next_Interp (I, It);
end loop;
- if Etype (N) = Any_Type then
+ if Etype (N) = Any_Type
+ and then not Try_Object_Operation (N)
+ then
Error_Msg_NE ("undefined selector& for overloaded prefix", N, Sel);
Set_Entity (Sel, Any_Id);
Set_Etype (Sel, Any_Type);
-- implements an interface, check whether there is some other
-- primitive operation with that name.
- if Etype (N) = Any_Type
- and then Ada_Version >= Ada_05
+ if Ada_Version >= Ada_05
and then Is_Tagged_Type (Prefix_Type)
- and then Try_Object_Operation (N)
then
- return;
+ if Etype (N) = Any_Type
+ and then Try_Object_Operation (N)
+ then
+ return;
+
+ -- If the context is not syntactically a procedure call, it
+ -- may be a call to a primitive function declared outside of
+ -- the synchronized type.
+
+ -- If the context is a procedure call, there might still be
+ -- an overloading between an entry and a primitive procedure
+ -- declared outside of the synchronized type, called in prefix
+ -- notation. This is harder to disambiguate because in one case
+ -- the controlling formal is implicit ???
+
+ elsif Nkind (Parent (N)) /= N_Procedure_Call_Statement
+ and then Try_Object_Operation (N)
+ then
+ return;
+ end if;
end if;
Set_Is_Overloaded (N, Is_Overloaded (Sel));
Is_Subprg_Call : constant Boolean := K = N_Procedure_Call_Statement
or else K = N_Function_Call;
Obj : constant Node_Id := Prefix (N);
- Subprog : constant Node_Id := Selector_Name (N);
+ Subprog : constant Node_Id :=
+ Make_Identifier (Sloc (Selector_Name (N)),
+ Chars => Chars (Selector_Name (N)));
+ -- Identifier on which possible interpretations will be collected.
+
Success : Boolean := False;
Report_Error : Boolean := False;
Node_To_Replace : Node_Id;
Obj_Type : Entity_Id := Etype (Obj);
+ function Valid_Candidate
+ (Success : Boolean;
+ Call : Node_Id;
+ Subp : Entity_Id) return Entity_Id;
+ -- If the subprogram is a valid interpretation, record it, and add
+ -- to the list of interpretations of Subprog.
+
procedure Complete_Object_Operation
(Call_Node : Node_Id;
- Node_To_Replace : Node_Id;
- Subprog : Node_Id);
+ Node_To_Replace : Node_Id);
-- Make Subprog the name of Call_Node, replace Node_To_Replace with
-- Call_Node, insert the object (or its dereference) as the first actual
-- in the call, and complete the analysis of the call.
+ procedure Report_Ambiguity (Op : Entity_Id);
+ -- If a prefixed procedure call is ambiguous, indicate whether the
+ -- call includes an implicit dereference or an implicit 'Access.
+
procedure Transform_Object_Operation
(Call_Node : out Node_Id;
- Node_To_Replace : out Node_Id;
- Subprog : Node_Id);
+ Node_To_Replace : out Node_Id);
-- Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..)
-- Call_Node is the resulting subprogram call,
-- Node_To_Replace is either N or the parent of N, and Subprog
-- Traverse all ancestor types looking for a class-wide subprogram
-- for which the current operation is a valid non-dispatching call.
+ procedure Try_One_Prefix_Interpretation (T : Entity_Id);
+ -- If prefix is overloaded, its interpretation may include different
+ -- tagged types, and we must examine the primitive operations and
+ -- the class-wide operations of each in order to find candidate
+ -- interpretations for the call as a whole.
+
function Try_Primitive_Operation
(Call_Node : Node_Id;
Node_To_Replace : Node_Id) return Boolean;
-- Traverse the list of primitive subprograms looking for a dispatching
-- operation for which the current node is a valid call .
+ ---------------------
+ -- Valid_Candidate --
+ ---------------------
+
+ function Valid_Candidate
+ (Success : Boolean;
+ Call : Node_Id;
+ Subp : Entity_Id) return Entity_Id
+ is
+ Comp_Type : Entity_Id;
+
+ begin
+ -- If the subprogram is a valid interpretation, record it in global
+ -- variable Subprog, to collect all possible overloadings.
+
+ if Success then
+ if Subp /= Entity (Subprog) then
+ Add_One_Interp (Subprog, Subp, Etype (Subp));
+ end if;
+ end if;
+
+ -- If the call may be an indexed call, retrieve component type
+ -- of resulting expression, and add possible interpretation.
+
+ Comp_Type := Empty;
+
+ if Nkind (Call) = N_Function_Call
+ and then Nkind (Parent (N)) = N_Indexed_Component
+ and then Needs_One_Actual (Subp)
+ then
+ if Is_Array_Type (Etype (Subp)) then
+ Comp_Type := Component_Type (Etype (Subp));
+
+ elsif Is_Access_Type (Etype (Subp))
+ and then Is_Array_Type (Designated_Type (Etype (Subp)))
+ then
+ Comp_Type := Component_Type (Designated_Type (Etype (Subp)));
+ end if;
+ end if;
+
+ if Present (Comp_Type)
+ and then Etype (Subprog) /= Comp_Type
+ then
+ Add_One_Interp (Subprog, Subp, Comp_Type);
+ end if;
+
+ if Etype (Call) /= Any_Type then
+ return Subp;
+ else
+ return Empty;
+ end if;
+ end Valid_Candidate;
+
-------------------------------
-- Complete_Object_Operation --
-------------------------------
procedure Complete_Object_Operation
(Call_Node : Node_Id;
- Node_To_Replace : Node_Id;
- Subprog : Node_Id)
+ Node_To_Replace : Node_Id)
is
Formal_Type : constant Entity_Id :=
Etype (First_Formal (Entity (Subprog)));
First_Actual : Node_Id;
begin
- First_Actual := First (Parameter_Associations (Call_Node));
+ -- Place the name of the operation, with its interpretations,
+ -- on the rewritten call.
+
Set_Name (Call_Node, Subprog);
+ First_Actual := First (Parameter_Associations (Call_Node));
+
-- For cross-reference purposes, treat the new node as being in
-- the source if the original one is.
end if;
-- If need be, rewrite first actual as an explicit dereference
+ -- If the call is overloaded, the rewriting can only be done
+ -- once the primitive operation is identified.
+
+ if Is_Overloaded (Subprog) then
- if not Is_Access_Type (Formal_Type)
+ -- The prefix itself may be overloaded, and its interpretations
+ -- must be propagated to the new actual in the call.
+
+ if Is_Overloaded (Obj) then
+ Save_Interps (Obj, First_Actual);
+ end if;
+
+ Rewrite (First_Actual, Obj);
+
+ elsif not Is_Access_Type (Formal_Type)
and then Is_Access_Type (Etype (Obj))
then
Rewrite (First_Actual,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Access,
Prefix => Relocate_Node (Obj)));
+
+ if not Is_Aliased_View (Obj) then
+ Error_Msg_NE
+ ("object in prefixed call to& must be aliased"
+ & " ('R'M'-2005 4.3.1 (13))",
+ Prefix (First_Actual), Subprog);
+ end if;
+
Analyze (First_Actual);
else
- Rewrite (First_Actual, Obj);
- end if;
+ if Is_Overloaded (Obj) then
+ Save_Interps (Obj, First_Actual);
+ end if;
- if Is_Overloaded (Call_Node) then
- Save_Interps (Call_Node, Node_To_Replace);
+ Rewrite (First_Actual, Obj);
end if;
Rewrite (Node_To_Replace, Call_Node);
- Analyze (Node_To_Replace);
+
+ -- Propagate the interpretations collected in subprog to the new
+ -- function call node, to be resolved from context.
+
+ if Is_Overloaded (Subprog) then
+ Save_Interps (Subprog, Node_To_Replace);
+ else
+ Analyze (Node_To_Replace);
+ end if;
end Complete_Object_Operation;
+ ----------------------
+ -- Report_Ambiguity --
+ ----------------------
+
+ procedure Report_Ambiguity (Op : Entity_Id) is
+ Access_Formal : constant Boolean :=
+ Is_Access_Type (Etype (First_Formal (Op)));
+ Access_Actual : constant Boolean :=
+ Is_Access_Type (Etype (Prefix (N)));
+
+ begin
+ Error_Msg_Sloc := Sloc (Op);
+
+ if Access_Formal and then not Access_Actual then
+ if Nkind (Parent (Op)) = N_Full_Type_Declaration then
+ Error_Msg_N
+ ("\possible interpretation"
+ & " (inherited, with implicit 'Access) #", N);
+ else
+ Error_Msg_N
+ ("\possible interpretation (with implicit 'Access) #", N);
+ end if;
+
+ elsif not Access_Formal and then Access_Actual then
+ if Nkind (Parent (Op)) = N_Full_Type_Declaration then
+ Error_Msg_N
+ ("\possible interpretation"
+ & " ( inherited, with implicit dereference) #", N);
+ else
+ Error_Msg_N
+ ("\possible interpretation (with implicit dereference) #", N);
+ end if;
+
+ else
+ if Nkind (Parent (Op)) = N_Full_Type_Declaration then
+ Error_Msg_N ("\possible interpretation (inherited)#", N);
+ else
+ Error_Msg_N ("\possible interpretation#", N);
+ end if;
+ end if;
+ end Report_Ambiguity;
+
--------------------------------
-- Transform_Object_Operation --
--------------------------------
procedure Transform_Object_Operation
(Call_Node : out Node_Id;
- Node_To_Replace : out Node_Id;
- Subprog : Node_Id)
+ Node_To_Replace : out Node_Id)
is
Parent_Node : constant Node_Id := Parent (N);
if Nkind (Parent_Node) = N_Procedure_Call_Statement then
Call_Node :=
Make_Procedure_Call_Statement (Loc,
- Name => New_Copy_Tree (Subprog),
+ Name => New_Copy (Subprog),
Parameter_Associations => Actuals);
else
Call_Node :=
Make_Function_Call (Loc,
- Name => New_Copy_Tree (Subprog),
+ Name => New_Copy (Subprog),
Parameter_Associations => Actuals);
end if;
Call_Node :=
Make_Function_Call (Loc,
- Name => New_Copy_Tree (Subprog),
+ Name => New_Copy (Subprog),
Parameter_Associations => Actuals);
-- Parameterless call: Obj.F is rewritten as F (Obj)
Call_Node :=
Make_Function_Call (Loc,
- Name => New_Copy_Tree (Subprog),
+ Name => New_Copy (Subprog),
Parameter_Associations => New_List (Dummy));
end if;
end Transform_Object_Operation;
(Call_Node : Node_Id;
Node_To_Replace : Node_Id) return Boolean
is
- Anc_Type : Entity_Id;
- Cls_Type : Entity_Id;
- Hom : Entity_Id;
- Hom_Ref : Node_Id;
- Success : Boolean;
+ Anc_Type : Entity_Id;
+ Matching_Op : Entity_Id := Empty;
+ Error : Boolean;
+
+ procedure Traverse_Homonyms
+ (Anc_Type : Entity_Id;
+ Error : out Boolean);
+ -- Traverse the homonym chain of the subprogram searching for those
+ -- homonyms whose first formal has the Anc_Type's class-wide type,
+ -- or an anonymous access type designating the class-wide type. If an
+ -- ambiguity is detected, then Error is set to True.
+
+ procedure Traverse_Interfaces
+ (Anc_Type : Entity_Id;
+ Error : out Boolean);
+ -- Traverse the list of interfaces, if any, associated with Anc_Type
+ -- and search for acceptable class-wide homonyms associated with each
+ -- interface. If an ambiguity is detected, then Error is set to True.
+
+ -----------------------
+ -- Traverse_Homonyms --
+ -----------------------
+
+ procedure Traverse_Homonyms
+ (Anc_Type : Entity_Id;
+ Error : out Boolean)
+ is
+ Cls_Type : Entity_Id;
+ Hom : Entity_Id;
+ Hom_Ref : Node_Id;
+ Success : Boolean;
- begin
- -- Loop through ancestor types, traverse the homonym chain of the
- -- subprogram, and try out those homonyms whose first formal has the
- -- class-wide type of the ancestor, or an access type to it.
-
- Anc_Type := Obj_Type;
+ begin
+ Error := False;
- loop
Cls_Type := Class_Wide_Type (Anc_Type);
Hom := Current_Entity (Subprog);
(Etype (First_Formal (Hom)) = Cls_Type
or else
(Is_Access_Type (Etype (First_Formal (Hom)))
+ and then
+ Ekind (Etype (First_Formal (Hom))) =
+ E_Anonymous_Access_Type
and then
Designated_Type (Etype (First_Formal (Hom))) =
- Cls_Type))
+ Cls_Type))
then
- Hom_Ref := New_Reference_To (Hom, Sloc (Subprog));
Set_Etype (Call_Node, Any_Type);
- Set_Parent (Call_Node, Parent (Node_To_Replace));
+ Set_Is_Overloaded (Call_Node, False);
+ Success := False;
- Set_Name (Call_Node, Hom_Ref);
+ if No (Matching_Op) then
+ Hom_Ref := New_Reference_To (Hom, Sloc (Subprog));
+ Set_Etype (Call_Node, Any_Type);
+ Set_Parent (Call_Node, Parent (Node_To_Replace));
- Analyze_One_Call
- (N => Call_Node,
- Nam => Hom,
- Report => Report_Error,
- Success => Success,
- Skip_First => True);
+ Set_Name (Call_Node, Hom_Ref);
- if Success then
+ Analyze_One_Call
+ (N => Call_Node,
+ Nam => Hom,
+ Report => Report_Error,
+ Success => Success,
+ Skip_First => True);
- -- Reformat into the proper call
+ Matching_Op :=
+ Valid_Candidate (Success, Call_Node, Hom);
- Complete_Object_Operation
- (Call_Node => Call_Node,
- Node_To_Replace => Node_To_Replace,
- Subprog => Hom_Ref);
-
- return True;
+ else
+ Analyze_One_Call
+ (N => Call_Node,
+ Nam => Hom,
+ Report => Report_Error,
+ Success => Success,
+ Skip_First => True);
+
+ if Present (Valid_Candidate (Success, Call_Node, Hom))
+ and then Nkind (Call_Node) /= N_Function_Call
+ then
+ Error_Msg_NE ("ambiguous call to&", N, Hom);
+ Report_Ambiguity (Matching_Op);
+ Report_Ambiguity (Hom);
+ Error := True;
+ return;
+ end if;
end if;
end if;
Hom := Homonym (Hom);
end loop;
+ end Traverse_Homonyms;
+
+ -------------------------
+ -- Traverse_Interfaces --
+ -------------------------
- -- Examine other ancestor types
+ procedure Traverse_Interfaces
+ (Anc_Type : Entity_Id;
+ Error : out Boolean)
+ is
+ Intface : Node_Id;
+ Intface_List : constant List_Id :=
+ Abstract_Interface_List (Anc_Type);
+
+ begin
+ Error := False;
+
+ if Is_Non_Empty_List (Intface_List) then
+ Intface := First (Intface_List);
+ while Present (Intface) loop
+
+ -- Look for acceptable class-wide homonyms associated with
+ -- the interface.
+
+ Traverse_Homonyms (Etype (Intface), Error);
+
+ if Error then
+ return;
+ end if;
+
+ -- Continue the search by looking at each of the interface's
+ -- associated interface ancestors.
+
+ Traverse_Interfaces (Etype (Intface), Error);
+
+ if Error then
+ return;
+ end if;
+
+ Next (Intface);
+ end loop;
+ end if;
+ end Traverse_Interfaces;
+
+ -- Start of processing for Try_Class_Wide_Operation
+
+ begin
+ -- Loop through ancestor types (including interfaces), traversing the
+ -- homonym chain of the subprogram, and trying out those homonyms
+ -- whose first formal has the class-wide type of the ancestor, or an
+ -- anonymous access type designating the class-wide type.
+
+ Anc_Type := Obj_Type;
+ loop
+ -- Look for a match among homonyms associated with the ancestor
+
+ Traverse_Homonyms (Anc_Type, Error);
+
+ if Error then
+ return True;
+ end if;
+
+ -- Continue the search for matches among homonyms associated with
+ -- any interfaces implemented by the ancestor.
+
+ Traverse_Interfaces (Anc_Type, Error);
+
+ if Error then
+ return True;
+ end if;
exit when Etype (Anc_Type) = Anc_Type;
Anc_Type := Etype (Anc_Type);
end loop;
- -- Nothing matched
+ if Present (Matching_Op) then
+ Set_Etype (Call_Node, Etype (Matching_Op));
+ end if;
- return False;
+ return Present (Matching_Op);
end Try_Class_Wide_Operation;
+ -----------------------------------
+ -- Try_One_Prefix_Interpretation --
+ -----------------------------------
+
+ procedure Try_One_Prefix_Interpretation (T : Entity_Id) is
+ begin
+ Obj_Type := T;
+
+ if Is_Access_Type (Obj_Type) then
+ Obj_Type := Designated_Type (Obj_Type);
+ end if;
+
+ if Ekind (Obj_Type) = E_Private_Subtype then
+ Obj_Type := Base_Type (Obj_Type);
+ end if;
+
+ if Is_Class_Wide_Type (Obj_Type) then
+ Obj_Type := Etype (Class_Wide_Type (Obj_Type));
+ end if;
+
+ -- The type may have be obtained through a limited_with clause,
+ -- in which case the primitive operations are available on its
+ -- non-limited view.
+
+ if Ekind (Obj_Type) = E_Incomplete_Type
+ and then From_With_Type (Obj_Type)
+ then
+ Obj_Type := Non_Limited_View (Obj_Type);
+ end if;
+
+ -- If the object is not tagged, or the type is still an incomplete
+ -- type, this is not a prefixed call.
+
+ if not Is_Tagged_Type (Obj_Type)
+ or else Is_Incomplete_Type (Obj_Type)
+ then
+ return;
+ end if;
+
+ if Try_Primitive_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace)
+ or else
+ Try_Class_Wide_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace)
+ then
+ null;
+ end if;
+ end Try_One_Prefix_Interpretation;
+
-----------------------------
-- Try_Primitive_Operation --
-----------------------------
is
Elmt : Elmt_Id;
Prim_Op : Entity_Id;
- Prim_Op_Ref : Node_Id := Empty;
- Success : Boolean := False;
- Op_Exists : Boolean := False;
+ Matching_Op : Entity_Id := Empty;
+ Prim_Op_Ref : Node_Id := Empty;
+
+ Corr_Type : Entity_Id := Empty;
+ -- If the prefix is a synchronized type, the controlling type of
+ -- the primitive operation is the corresponding record type, else
+ -- this is the object type itself.
+
+ Success : Boolean := False;
function Valid_First_Argument_Of (Op : Entity_Id) return Boolean;
-- Verify that the prefix, dereferenced if need be, is a valid
Typ : constant Entity_Id := Etype (First_Formal (Op));
begin
- -- Simple case. Object may be a subtype of the tagged type.
+ -- Simple case. Object may be a subtype of the tagged type
+ -- or may be the corresponding record of a synchronized type.
return Obj_Type = Typ
or else Base_Type (Obj_Type) = Typ
- -- Prefix can be dereferenced
+ or else Corr_Type = Typ
+
+ -- Prefix can be dereferenced
or else
- (Is_Access_Type (Obj_Type)
- and then Designated_Type (Obj_Type) = Typ)
+ (Is_Access_Type (Corr_Type)
+ and then Designated_Type (Corr_Type) = Typ)
- -- Formal is an access parameter, for which the object
- -- can provide an access.
+ -- Formal is an access parameter, for which the object
+ -- can provide an access.
or else
(Ekind (Typ) = E_Anonymous_Access_Type
- and then Designated_Type (Typ) = Base_Type (Obj_Type));
+ and then Designated_Type (Typ) = Base_Type (Corr_Type));
end Valid_First_Argument_Of;
-- Start of processing for Try_Primitive_Operation
begin
- -- Look for subprograms in the list of primitive operations
- -- The name must be identical, and the kind of call indicates the
- -- expected kind of operation (function or procedure).
- -- If the type is a (tagged) synchronized type, the primitive ops
- -- are attached to the corresponding record type.
+ -- Look for subprograms in the list of primitive operations The name
+ -- must be identical, and the kind of call indicates the expected
+ -- kind of operation (function or procedure). If the type is a
+ -- (tagged) synchronized type, the primitive ops are attached to
+ -- the corresponding record type.
if Is_Concurrent_Type (Obj_Type) then
- Elmt :=
- First_Elmt
- (Primitive_Operations (Corresponding_Record_Type (Obj_Type)));
+ Corr_Type := Corresponding_Record_Type (Obj_Type);
+ Elmt := First_Elmt (Primitive_Operations (Corr_Type));
else
+ Corr_Type := Obj_Type;
Elmt := First_Elmt (Primitive_Operations (Obj_Type));
end if;
-- primitive is also in this list of primitive operations and
-- will be used instead.
- if Present (Abstract_Interface_Alias (Prim_Op))
- and then Is_Ancestor (Find_Dispatching_Type
- (Alias (Prim_Op)), Obj_Type)
+ if (Present (Abstract_Interface_Alias (Prim_Op))
+ and then Is_Ancestor (Find_Dispatching_Type
+ (Alias (Prim_Op)), Corr_Type))
+ or else
+
+ -- Do not consider hidden primitives unless they belong to a
+ -- generic private type with a tagged parent.
+
+ (Is_Hidden (Prim_Op)
+ and then not Is_Immediately_Visible (Obj_Type))
then
goto Continue;
end if;
- if not Success then
+ Set_Etype (Call_Node, Any_Type);
+ Set_Is_Overloaded (Call_Node, False);
+
+ if No (Matching_Op) then
Prim_Op_Ref := New_Reference_To (Prim_Op, Sloc (Subprog));
Candidate := Prim_Op;
- Set_Etype (Call_Node, Any_Type);
Set_Parent (Call_Node, Parent (Node_To_Replace));
Set_Name (Call_Node, Prim_Op_Ref);
+ Success := False;
Analyze_One_Call
(N => Call_Node,
Success => Success,
Skip_First => True);
- if Success
- or else Needs_One_Actual (Prim_Op)
- then
- Op_Exists := True;
- end if;
+ Matching_Op := Valid_Candidate (Success, Call_Node, Prim_Op);
else
-- More than one interpretation, collect for subsequent
- -- disambiguation.
+ -- disambiguation. If this is a procedure call and there
+ -- is another match, report ambiguity now.
+
+ Analyze_One_Call
+ (N => Call_Node,
+ Nam => Prim_Op,
+ Report => Report_Error,
+ Success => Success,
+ Skip_First => True);
- Add_One_Interp (Prim_Op_Ref, Prim_Op, Etype (Prim_Op));
+ if Present (Valid_Candidate (Success, Call_Node, Prim_Op))
+ and then Nkind (Call_Node) /= N_Function_Call
+ then
+ Error_Msg_NE ("ambiguous call to&", N, Prim_Op);
+ Report_Ambiguity (Matching_Op);
+ Report_Ambiguity (Prim_Op);
+ return True;
+ end if;
end if;
end if;
Next_Elmt (Elmt);
end loop;
- if Op_Exists then
- Complete_Object_Operation
- (Call_Node => Call_Node,
- Node_To_Replace => Node_To_Replace,
- Subprog => Prim_Op_Ref);
+ if Present (Matching_Op) then
+ Set_Etype (Call_Node, Etype (Matching_Op));
end if;
- return Op_Exists;
+ return Present (Matching_Op);
end Try_Primitive_Operation;
-- Start of processing for Try_Object_Operation
begin
- if Is_Access_Type (Obj_Type) then
- Obj_Type := Designated_Type (Obj_Type);
- end if;
-
- if Ekind (Obj_Type) = E_Private_Subtype then
- Obj_Type := Base_Type (Obj_Type);
- end if;
-
- if Is_Class_Wide_Type (Obj_Type) then
- Obj_Type := Etype (Class_Wide_Type (Obj_Type));
- end if;
-
- -- The type may have be obtained through a limited_with clause,
- -- in which case the primitive operations are available on its
- -- non-limited view.
-
- if Ekind (Obj_Type) = E_Incomplete_Type
- and then From_With_Type (Obj_Type)
- then
- Obj_Type := Non_Limited_View (Obj_Type);
- end if;
-
- if not Is_Tagged_Type (Obj_Type) then
- return False;
- end if;
+ Analyze_Expression (Obj);
- -- Analyze the actuals if node is know to be a subprogram call
+ -- Analyze the actuals if node is known to be a subprogram call
if Is_Subprg_Call and then N = Name (Parent (N)) then
Actual := First (Parameter_Associations (Parent (N)));
end loop;
end if;
- Analyze_Expression (Obj);
-
-- Build a subprogram call node, using a copy of Obj as its first
-- actual. This is a placeholder, to be replaced by an explicit
-- dereference when needed.
Transform_Object_Operation
(Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace,
- Subprog => Subprog);
+ Node_To_Replace => Node_To_Replace);
Set_Etype (New_Call_Node, Any_Type);
+ Set_Etype (Subprog, Any_Type);
Set_Parent (New_Call_Node, Parent (Node_To_Replace));
- if Try_Primitive_Operation
- (Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace)
+ if not Is_Overloaded (Obj) then
+ Try_One_Prefix_Interpretation (Obj_Type);
- or else
- Try_Class_Wide_Operation
- (Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace)
- then
+ else
+ declare
+ I : Interp_Index;
+ It : Interp;
+ begin
+ Get_First_Interp (Obj, I, It);
+ while Present (It.Nam) loop
+ Try_One_Prefix_Interpretation (It.Typ);
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ if Etype (New_Call_Node) /= Any_Type then
+ Complete_Object_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace);
return True;
elsif Present (Candidate) then
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
Err : out Boolean;
Proc : Entity_Id := Empty);
-- Called to check for missing return statements in a function body, or for
- -- returns present in a procedure body which has No_Return set. L is the
+ -- returns present in a procedure body which has No_Return set. HSS is the
-- handled statement sequence for the subprogram body. This procedure
-- checks all flow paths to make sure they either have return (Mode = 'F',
-- used for functions) or do not have a return (Mode = 'P', used for
-- return.
if Nkind (N) = N_Extended_Return_Statement then
- New_Scope (Stm_Entity);
+ Push_Scope (Stm_Entity);
end if;
-- Check that pragma No_Return is obeyed:
R_Stm_Type_Is_Anon_Access :
constant Boolean :=
- Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type
+ Ekind (R_Stm_Type) = E_Anonymous_Access_Subprogram_Type
or else
- Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type
+ Ekind (R_Stm_Type) = E_Anonymous_Access_Protected_Subprogram_Type
or else
- Ekind (R_Type) = E_Anonymous_Access_Type;
+ Ekind (R_Stm_Type) = E_Anonymous_Access_Type;
-- True if type of the return object is an anonymous access type
begin
if R_Type_Is_Anon_Access then
if R_Stm_Type_Is_Anon_Access then
- if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
+ if Base_Type (Designated_Type (R_Stm_Type)) /=
+ Base_Type (Designated_Type (R_Type))
+ or else not Subtypes_Statically_Match (R_Stm_Type, R_Type)
+ then
Error_Msg_N
- ("subtypes must statically match", Subtype_Ind);
+ ("subtype must statically match function result subtype",
+ Subtype_Mark (Subtype_Ind));
end if;
+
else
Error_Msg_N ("must use anonymous access type", Subtype_Ind);
end if;
if Is_Constrained (R_Type) then
if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
Error_Msg_N
- ("subtypes must statically match", Subtype_Ind);
+ ("subtype must statically match function result subtype",
+ Subtype_Ind);
end if;
end if;
+ -- If the function's result type doesn't match the return object
+ -- entity's type, then we check for the case where the result type
+ -- is class-wide, and allow the declaration if the type of the object
+ -- definition matches the class-wide type. This prevents rejection
+ -- in the case where the object declaration is initialized by a call
+ -- to a build-in-place function with a specific result type and the
+ -- object entity had its type changed to that specific type. (Note
+ -- that the ARG believes that return objects should be allowed to
+ -- have a type covered by a class-wide result type in any case, so
+ -- once that relaxation is made (see AI05-32), the above check for
+ -- type compatibility should be changed to test Covers rather than
+ -- equality, and then the following special test will no longer be
+ -- needed. ???)
+
+ elsif Is_Class_Wide_Type (R_Type)
+ and then R_Type = Etype (Object_Definition (Obj_Decl))
+ then
+ null;
+
else
Error_Msg_N
("wrong type for return_subtype_indication", Subtype_Ind);
-- needed to process the formals declarations. Then make the formals
-- visible in a separate step.
- New_Scope (Gen_Id);
+ Push_Scope (Gen_Id);
declare
E : Entity_Id;
Set_Etype (Designator, Typ);
if Ekind (Typ) = E_Incomplete_Type
+ and then Is_Value_Type (Typ)
+ then
+ null;
+
+ elsif Ekind (Typ) = E_Incomplete_Type
or else (Is_Class_Wide_Type (Typ)
and then
Ekind (Root_Type (Typ)) = E_Incomplete_Type)
Install_Formals (Spec_Id);
Last_Formal := Last_Entity (Spec_Id);
- New_Scope (Spec_Id);
+ Push_Scope (Spec_Id);
-- Make sure that the subprogram is immediately visible. For
-- child units that have no separate spec this is indispensable.
(Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
Generate_Reference_To_Formals (Body_Id);
Install_Formals (Body_Id);
- New_Scope (Body_Id);
+ Push_Scope (Body_Id);
end if;
end if;
-- Ada 2005 (AI-251): Check wrong placement of abstract interface
- -- primitives.
+ -- primitives, and update anonymous access returns with limited views.
if Ada_Version >= Ada_05
and then Comes_From_Source (N)
declare
E : Entity_Id;
Etyp : Entity_Id;
+ Rtyp : Entity_Id;
begin
-- Check the type of the formals
" defined in package specs", N);
end if;
end if;
+
+ -- If the return type is an anonymous access type whose
+ -- designated type is the limited view of a class-wide type
+ -- and the non-limited view is available. update the return
+ -- type accordingly.
+
+ Rtyp := Etype (Current_Scope);
+
+ if Ekind (Rtyp) = E_Anonymous_Access_Type then
+ Etyp := Directly_Designated_Type (Rtyp);
+
+ if Is_Class_Wide_Type (Etyp)
+ and then From_With_Type (Etyp)
+ then
+ Set_Directly_Designated_Type
+ (Etype (Current_Scope), Available_View (Etyp));
+ end if;
+ end if;
end;
end if;
Stm : Node_Id := First (Statements (HSS));
begin
- -- Skip an initial label (for one thing this occurs when we are in
- -- front end ZCX mode, but in any case it is irrelevant).
+ -- Skip initial labels (for one thing this occurs when we are in
+ -- front end ZCX mode, but in any case it is irrelevant), and also
+ -- initial Push_xxx_Error_Label nodes, which are also irrelevant.
- if Nkind (Stm) = N_Label then
+ while Nkind (Stm) = N_Label
+ or else Nkind (Stm) in N_Push_xxx_Label
+ loop
Next (Stm);
- end if;
+ end loop;
-- Do the test on the original statement before expansion
begin
Generate_Definition (Designator);
- -- Check for RCI unit subprogram declarations against in-lined
+ -- Check for RCI unit subprogram declarations for illegal inlined
-- subprograms and subprograms having access parameter or limited
- -- parameter without Read and Write (RM E.2.3(12-13)).
+ -- parameter without Read and Write attributes (RM E.2.3(12-13)).
Validate_RCI_Subprogram_Declaration (N);
else
-- For a compilation unit, check for library-unit pragmas
- New_Scope (Designator);
+ Push_Scope (Designator);
Set_Categorization_From_Pragmas (N);
Validate_Categorization_Dependency (N, Designator);
Pop_Scope;
function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
Designator : constant Entity_Id := Defining_Entity (N);
+ Formal : Entity_Id;
+ Formal_Typ : Entity_Id;
Formals : constant List_Id := Parameter_Specifications (N);
-- Start of processing for Analyze_Subprogram_Specification
Set_Scope (Designator, Current_Scope);
if Present (Formals) then
- New_Scope (Designator);
+ Push_Scope (Designator);
Process_Formals (Formals, N);
- -- Ada 2005 (AI-345): Allow overriding primitives of protected
- -- interfaces by means of normal subprograms. For this purpose
- -- temporarily use the corresponding record type as the etype
- -- of the first formal.
+ -- Ada 2005 (AI-345): Allow the overriding of interface primitives
+ -- by subprograms which belong to a concurrent type implementing an
+ -- interface. Set the parameter type of each controlling formal to
+ -- the corresponding record type.
- if Ada_Version >= Ada_05
- and then Comes_From_Source (Designator)
- and then Present (First_Entity (Designator))
- and then (Ekind (Etype (First_Entity (Designator)))
- = E_Protected_Type
- or else
- Ekind (Etype (First_Entity (Designator)))
- = E_Task_Type)
- and then Present (Corresponding_Record_Type
- (Etype (First_Entity (Designator))))
- and then Present (Abstract_Interfaces
- (Corresponding_Record_Type
- (Etype (First_Entity (Designator)))))
- then
- Set_Etype (First_Entity (Designator),
- Corresponding_Record_Type (Etype (First_Entity (Designator))));
+ if Ada_Version >= Ada_05 then
+ Formal := First_Formal (Designator);
+ while Present (Formal) loop
+ Formal_Typ := Etype (Formal);
+
+ if (Ekind (Formal_Typ) = E_Protected_Type
+ or else Ekind (Formal_Typ) = E_Task_Type)
+ and then Present (Corresponding_Record_Type (Formal_Typ))
+ and then Present (Abstract_Interfaces
+ (Corresponding_Record_Type (Formal_Typ)))
+ then
+ Set_Etype (Formal,
+ Corresponding_Record_Type (Formal_Typ));
+ end if;
+
+ Formal := Next_Formal (Formal);
+ end loop;
end if;
End_Scope;
begin
return Check_All_Returns (N) = OK
and then Present (Declarations (N))
+ and then Present (First (Declarations (N)))
and then Chars (Expression (Return_Statement)) =
Chars (Defining_Identifier (First (Declarations (N))));
end Has_Single_Return;
Remove_Pragmas;
Analyze (Body_To_Analyze);
- New_Scope (Defining_Entity (Body_To_Analyze));
+ Push_Scope (Defining_Entity (Body_To_Analyze));
Save_Global_References (Original_Body);
End_Scope;
Remove (Body_To_Analyze);
end if;
-- Ada 2005 (AI-231): In case of anonymous access types check the
- -- null-exclusion and access-to-constant attributes must match.
+ -- null-exclusion and access-to-constant attributes match.
if Ada_Version >= Ada_05
and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type
return;
end if;
- -- In subtype conformant case, conventions must match (RM 6.3.1(16))
+ -- In subtype conformant case, conventions must match (RM 6.3.1(16)).
-- If this is a renaming as body, refine error message to indicate that
-- the conflict is with the original declaration. If the entity is not
-- frozen, the conventions don't have to match, the one of the renamed
return;
end if;
- -- Full conformance checks
+ if Ctype >= Subtype_Conformant then
- if Ctype = Fully_Conformant then
+ -- Ada 2005 (AI-231): In case of anonymous access types check
+ -- the null-exclusion and access-to-constant attributes must
+ -- match.
- -- We have checked already that names match
+ if Ada_Version >= Ada_05
+ and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type
+ and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type
+ and then
+ (Can_Never_Be_Null (Old_Formal) /=
+ Can_Never_Be_Null (New_Formal)
+ or else
+ Is_Access_Constant (Etype (Old_Formal)) /=
+ Is_Access_Constant (Etype (New_Formal)))
+ then
+ -- It is allowed to omit the null-exclusion in case of stream
+ -- attribute subprograms. We recognize stream subprograms
+ -- through their TSS-generated suffix.
- if Parameter_Mode (Old_Formal) = E_In_Parameter then
+ declare
+ TSS_Name : constant TSS_Name_Type := Get_TSS_Name (New_Id);
+ begin
+ if TSS_Name /= TSS_Stream_Read
+ and then TSS_Name /= TSS_Stream_Write
+ and then TSS_Name /= TSS_Stream_Input
+ and then TSS_Name /= TSS_Stream_Output
+ then
+ Conformance_Error
+ ("type of & does not match!", New_Formal);
+ return;
+ end if;
+ end;
+ end if;
+ end if;
- -- Ada 2005 (AI-231): In case of anonymous access types check
- -- the null-exclusion and access-to-constant attributes must
- -- match.
+ -- Full conformance checks
- if Ada_Version >= Ada_05
- and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type
- and then
- (Can_Never_Be_Null (Old_Formal)
- /= Can_Never_Be_Null (New_Formal)
- or else Is_Access_Constant (Etype (Old_Formal))
- /= Is_Access_Constant (Etype (New_Formal)))
- then
- -- It is allowed to omit the null-exclusion in case of
- -- stream attribute subprograms
+ if Ctype = Fully_Conformant then
- declare
- TSS_Name : TSS_Name_Type;
+ -- We have checked already that names match
- begin
- Get_Name_String (Chars (New_Id));
- TSS_Name :=
- TSS_Name_Type
- (Name_Buffer
- (Name_Len - TSS_Name'Length + 1 .. Name_Len));
-
- if TSS_Name /= TSS_Stream_Read
- and then TSS_Name /= TSS_Stream_Write
- and then TSS_Name /= TSS_Stream_Input
- and then TSS_Name /= TSS_Stream_Output
- then
- Conformance_Error
- ("type of & does not match!", New_Formal);
- return;
- end if;
- end;
- end if;
+ if Parameter_Mode (Old_Formal) = E_In_Parameter then
-- Check default expressions for in parameters
-- The old default value has been analyzed because the
-- current full declaration will have frozen everything
- -- before. The new default values have not been
- -- analyzed, so analyze them now before we check for
- -- conformance.
+ -- before. The new default value has not been analyzed,
+ -- so analyze it now before we check for conformance.
if NewD then
- New_Scope (New_Id);
+ Push_Scope (New_Id);
Analyze_Per_Use_Expression
(Default_Value (New_Formal), Etype (New_Formal));
End_Scope;
end if;
-- A couple of special checks for Ada 83 mode. These checks are
- -- skipped if either entity is an operator in package Standard.
+ -- skipped if either entity is an operator in package Standard,
-- or if either old or new instance is not from the source program.
if Ada_Version = Ada_83
-- Grouping (use of comma in param lists) must be the same
-- This is where we catch a misconformance like:
- -- A,B : Integer
+ -- A, B : Integer
-- A : Integer; B : Integer
-- which are represented identically in the tree except
-----------------------
procedure Check_Conventions (Typ : Entity_Id) is
+
+ function Skip_Check (Op : Entity_Id) return Boolean;
+ pragma Inline (Skip_Check);
+ -- A small optimization: skip the predefined dispatching operations,
+ -- since they always have the same convention. Also do not consider
+ -- abstract primitives since those are left by an erroneous overriding.
+ -- This function returns True for any operation that is thus exempted
+ -- exempted from checking.
+
procedure Check_Convention
(Op : Entity_Id;
Search_From : Elmt_Id);
- -- Verify that the convention of inherited dispatching operation
- -- Op is consistent among all subprograms it overrides. In order
- -- to minimize the search, Search_From is utilized to designate
- -- a specific point in the list rather than iterating over the
- -- whole list once more.
+ -- Verify that the convention of inherited dispatching operation Op is
+ -- consistent among all subprograms it overrides. In order to minimize
+ -- the search, Search_From is utilized to designate a specific point in
+ -- the list rather than iterating over the whole list once more.
----------------------
-- Check_Convention --
Search_From : Elmt_Id)
is
procedure Error_Msg_Operation (Op : Entity_Id);
- -- Emit a continuation to an error message depicting the kind,
- -- name, convention and source location of subprogram Op.
+ -- Emit a continuation to an error message depicting the kind, name,
+ -- convention and source location of subprogram Op.
-------------------------
-- Error_Msg_Operation --
Error_Msg_Name_1 := Chars (Op);
-- Error messages of primitive subprograms do not contain a
- -- convention attribute since the convention may have been
- -- first inherited from a parent subprogram, then changed by
- -- a pragma.
+ -- convention attribute since the convention may have been first
+ -- inherited from a parent subprogram, then changed by a pragma.
if Comes_From_Source (Op) then
Error_Msg_Sloc := Sloc (Op);
-- Local variables
- Prim_Op : Entity_Id;
- Prim_Op_Elmt : Elmt_Id;
+ Second_Prim_Op : Entity_Id;
+ Second_Prim_Op_Elmt : Elmt_Id;
-- Start of processing for Check_Convention
begin
- Prim_Op_Elmt := Next_Elmt (Search_From);
- while Present (Prim_Op_Elmt) loop
- Prim_Op := Node (Prim_Op_Elmt);
-
- -- A small optimization, skip the predefined dispatching
- -- operations since they always have the same convention.
- -- Also do not consider abstract primitives since those
- -- are left by an erroneous overriding.
-
- if not Is_Predefined_Dispatching_Operation (Prim_Op)
- and then not Is_Abstract_Subprogram (Prim_Op)
- and then Chars (Prim_Op) = Chars (Op)
- and then Type_Conformant (Prim_Op, Op)
- and then Convention (Prim_Op) /= Convention (Op)
+ Second_Prim_Op_Elmt := Next_Elmt (Search_From);
+ while Present (Second_Prim_Op_Elmt) loop
+ Second_Prim_Op := Node (Second_Prim_Op_Elmt);
+
+ if not Skip_Check (Second_Prim_Op)
+ and then Chars (Second_Prim_Op) = Chars (Op)
+ and then Type_Conformant (Second_Prim_Op, Op)
+ and then Convention (Second_Prim_Op) /= Convention (Op)
then
Error_Msg_N
("inconsistent conventions in primitive operations", Typ);
Error_Msg_Operation (Op);
- Error_Msg_Operation (Prim_Op);
+ Error_Msg_Operation (Second_Prim_Op);
-- Avoid cascading errors
return;
end if;
- Next_Elmt (Prim_Op_Elmt);
+ Next_Elmt (Second_Prim_Op_Elmt);
end loop;
end Check_Convention;
+ ----------------
+ -- Skip_Check --
+ ----------------
+
+ function Skip_Check (Op : Entity_Id) return Boolean is
+ begin
+ return Is_Predefined_Dispatching_Operation (Op)
+ or else Is_Abstract_Subprogram (Op);
+ end Skip_Check;
+
-- Local variables
Prim_Op : Entity_Id;
-- Start of processing for Check_Conventions
begin
- -- The algorithm checks every overriding dispatching operation
- -- against all the corresponding overridden dispatching operations,
- -- detecting differences in coventions.
+ -- The algorithm checks every overriding dispatching operation against
+ -- all the corresponding overridden dispatching operations, detecting
+ -- differences in coventions.
Prim_Op_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Op_Elmt) loop
Prim_Op := Node (Prim_Op_Elmt);
- -- A small optimization, skip the predefined dispatching operations
+ -- A small optimization: skip the predefined dispatching operations
-- since they always have the same convention. Also avoid processing
-- of abstract primitives left from an erroneous overriding.
- if not Is_Predefined_Dispatching_Operation (Prim_Op)
- and then not Is_Abstract_Subprogram (Prim_Op)
- then
+ if not Skip_Check (Prim_Op) then
Check_Convention
(Op => Prim_Op,
Search_From => Prim_Op_Elmt);
-- Check_Returns --
-------------------
+ -- Note: this procedure needs to know far too much about how the expander
+ -- messes with exceptions. The use of the flag Exception_Junk and the
+ -- incorporation of knowledge of Exp_Ch11.Expand_Local_Exception_Handlers
+ -- works, but is not very clean. It would be better if the expansion
+ -- routines would leave Original_Node working nicely, and we could use
+ -- Original_Node here to ignore all the peculiar expander messing ???
+
procedure Check_Returns
(HSS : Node_Id;
Mode : Character;
procedure Check_Statement_Sequence (L : List_Id) is
Last_Stm : Node_Id;
+ Stm : Node_Id;
Kind : Node_Kind;
Raise_Exception_Call : Boolean;
Last_Stm := Last (L);
+ -- Deal with digging out exception handler statement sequences that
+ -- have been transformed by the local raise to goto optimization.
+ -- See Exp_Ch11.Expand_Local_Exception_Handlers for details. If this
+ -- optimization has occurred, we are looking at something like:
+
+ -- begin
+ -- original stmts in block
+
+ -- exception \
+ -- when excep1 => |
+ -- goto L1; | omitted if No_Exception_Propagation
+ -- when excep2 => |
+ -- goto L2; /
+ -- end;
+
+ -- goto L3; -- skip handler when exception not raised
+
+ -- <<L1>> -- target label for local exception
+ -- begin
+ -- estmts1
+ -- end;
+
+ -- goto L3;
+
+ -- <<L2>>
+ -- begin
+ -- estmts2
+ -- end;
+
+ -- <<L3>>
+
+ -- and what we have to do is to dig out the estmts1 and estmts2
+ -- sequences (which were the original sequences of statements in
+ -- the exception handlers) and check them.
+
+ if Nkind (Last_Stm) = N_Label
+ and then Exception_Junk (Last_Stm)
+ then
+ Stm := Last_Stm;
+ loop
+ Prev (Stm);
+ exit when No (Stm);
+ exit when Nkind (Stm) /= N_Block_Statement;
+ exit when not Exception_Junk (Stm);
+ Prev (Stm);
+ exit when No (Stm);
+ exit when Nkind (Stm) /= N_Label;
+ exit when not Exception_Junk (Stm);
+ Check_Statement_Sequence
+ (Statements (Handled_Statement_Sequence (Next (Stm))));
+
+ Prev (Stm);
+ Last_Stm := Stm;
+ exit when No (Stm);
+ exit when Nkind (Stm) /= N_Goto_Statement;
+ exit when not Exception_Junk (Stm);
+ end loop;
+ end if;
+
-- Don't count pragmas
while Nkind (Last_Stm) = N_Pragma
((Nkind (Last_Stm) = N_Goto_Statement
or else Nkind (Last_Stm) = N_Label
or else Nkind (Last_Stm) = N_Object_Declaration)
- and then Exception_Junk (Last_Stm))
+ and then Exception_Junk (Last_Stm))
+ or else Nkind (Last_Stm) in N_Push_xxx_Label
+ or else Nkind (Last_Stm) in N_Pop_xxx_Label
loop
Prev (Last_Stm);
end loop;
Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
- -- If neither T1 nor T2 are generic actual types, or if they are
- -- in different scopes (e.g. parent and child instances), then verify
- -- that the base types are equal. Otherwise T1 and T2 must be
- -- on the same subtype chain. The whole purpose of this procedure
- -- is to prevent spurious ambiguities in an instantiation that may
- -- arise if two distinct generic types are instantiated with the
- -- same actual.
+ -- If neither T1 nor T2 are generic actual types, or if they are in
+ -- different scopes (e.g. parent and child instances), then verify that
+ -- the base types are equal. Otherwise T1 and T2 must be on the same
+ -- subtype chain. The whole purpose of this procedure is to prevent
+ -- spurious ambiguities in an instantiation that may arise if two
+ -- distinct generic types are instantiated with the same actual.
+
+ function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean;
+ -- Returns True if and only if either T1 denotes a limited view of T2
+ -- or T2 denotes a limited view of T1. This can arise when the limited
+ -- with view of a type is used in a subprogram declaration and the
+ -- subprogram body is in the scope of a regular with clause for the
+ -- same unit. In such a case, the two type entities can be considered
+ -- identical for purposes of conformance checking.
----------------------
-- Base_Types_Match --
elsif Base_Type (T1) = Base_Type (T2) then
- -- The following is too permissive. A more precise test must
+ -- The following is too permissive. A more precise test should
-- check that the generic actual is an ancestor subtype of the
-- other ???.
or else not Is_Generic_Actual_Type (T2)
or else Scope (T1) /= Scope (T2);
- -- In some cases a type imported through a limited_with clause,
- -- and its non-limited view are both visible, for example in an
- -- anonymous access_to_classwide type in a formal. Both entities
- -- designate the same type.
+ else
+ return False;
+ end if;
+ end Base_Types_Match;
- elsif From_With_Type (T1)
- and then Ekind (T1) = E_Incomplete_Type
- and then T2 = Non_Limited_View (T1)
+ -------------------------------
+ -- Matches_Limited_With_View --
+ -------------------------------
+
+ function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean is
+ begin
+ -- In some cases a type imported through a limited_with clause, and
+ -- its nonlimited view are both visible, for example in an anonymous
+ -- access-to-class-wide type in a formal. Both entities designate the
+ -- same type.
+
+ if From_With_Type (T1)
+ and then T2 = Available_View (T1)
then
return True;
elsif From_With_Type (T2)
- and then Ekind (T2) = E_Incomplete_Type
- and then T1 = Non_Limited_View (T2)
+ and then T1 = Available_View (T2)
then
return True;
else
return False;
end if;
- end Base_Types_Match;
+ end Matches_Limited_With_View;
-- Start of processing for Conforming_Types
Type_2 := Get_Instance_Of (T2);
end if;
- -- First see if base types match
+ -- If one of the types is a view of the other introduced by a limited
+ -- with clause, treat these as conforming for all purposes.
- if Base_Types_Match (Type_1, Type_2) then
+ if Matches_Limited_With_View (T1, T2) then
+ return True;
+
+ elsif Base_Types_Match (Type_1, Type_2) then
return Ctype <= Mode_Conformant
or else Subtypes_Statically_Match (Type_1, Type_2);
or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
end if;
- -- Ada 2005 (AI-254): Anonymous access to subprogram types must be
+ -- Ada 2005 (AI-254): Anonymous access-to-subprogram types must be
-- treated recursively because they carry a signature.
Are_Anonymous_Access_To_Subprogram_Types :=
end if;
end if;
- -- Create extra formal for supporting accessibility checking
+ -- Create extra formal for supporting accessibility checking. This
+ -- is done for both anonymous access formals and formals of named
+ -- access types that are marked as controlling formals. The latter
+ -- case can occur when Expand_Dispatching_Call creates a subprogram
+ -- type and substitutes the types of access-to-class-wide actuals
+ -- for the anonymous access-to-specific-type of controlling formals.
-- This is suppressed if we specifically suppress accessibility
-- checks at the package level for either the subprogram, or the
-- different suppression setting. The explicit checks at the
-- package level are safe from this point of view.
- if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+ if (Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+ or else (Is_Controlling_Formal (Formal)
+ and then Is_Access_Type (Etype (Formal))))
and then not
(Explicit_Suppress (E, Accessibility_Check)
or else
-- allocated by the caller (0), or should be allocated by the
-- callee on the secondary stack (1) or in the global heap (2).
-- For the moment we just use Natural for the type of this formal.
- -- Note that this formal isn't needed in the case where the
- -- result subtype is constrained.
-
- if not Is_Constrained (Result_Subt) then
+ -- Note that this formal isn't usually needed in the case where
+ -- the result subtype is constrained, but it is needed when the
+ -- function has a tagged result, because generally such functions
+ -- can be called in a dispatching context and such calls must be
+ -- handled like calls to a class-wide function.
+
+ if not Is_Constrained (Result_Subt)
+ or else Is_Tagged_Type (Underlying_Type (Result_Subt))
+ then
Discard :=
Add_Extra_Formal
(E, Standard_Natural,
-- region, rather than using copy-back after the function
-- returns. This is true even if we are able to get away with
-- having 'in out' parameters, which are normally illegal for
- -- functions.
+ -- functions. This formal is also needed when the function has
+ -- a tagged result, because generally such functions can be called
+ -- in a dispatching context and such calls must be handled like
+ -- calls to class-wide functions.
- if Is_Controlled (Result_Subt)
- or else Has_Controlled_Component (Result_Subt)
+ if Controlled_Type (Result_Subt)
+ or else Is_Tagged_Type (Underlying_Type (Result_Subt))
then
Discard :=
Add_Extra_Formal
begin
-- Non-conformant if paren count does not match. Note: if some idiot
-- complains that we don't do this right for more than 3 levels of
- -- parentheses, they will be treated with the respect they deserve :-)
+ -- parentheses, they will be treated with the respect they deserve!
if Paren_Count (E1) /= Paren_Count (E2) then
return False;
First_Hom : Entity_Id;
Overridden_Subp : out Entity_Id)
is
+ Formal_Typ : Entity_Id;
Ifaces_List : Elist_Id;
In_Scope : Boolean;
Typ : Entity_Id;
return;
end if;
- -- Def_Id must be declared withing the scope of a protected or
- -- task type or be a primitive operation of such a type.
+ -- Search for the concurrent declaration since it contains the list
+ -- of all implemented interfaces. In this case, the subprogram is
+ -- declared within the scope of a protected or a task type.
if Present (Scope (Def_Id))
and then Is_Concurrent_Type (Scope (Def_Id))
Typ := Scope (Def_Id);
In_Scope := True;
- elsif Present (First_Formal (Def_Id))
- and then Is_Concurrent_Type (Etype (First_Formal (Def_Id)))
- and then not Is_Generic_Actual_Type (Etype (First_Formal (Def_Id)))
- then
- Typ := Etype (First_Formal (Def_Id));
- In_Scope := False;
+ -- The subprogram may be a primitive of a concurrent type
+
+ elsif Present (First_Formal (Def_Id)) then
+ Formal_Typ := Etype (First_Formal (Def_Id));
+
+ if Is_Concurrent_Type (Formal_Typ)
+ and then not Is_Generic_Actual_Type (Formal_Typ)
+ then
+ Typ := Formal_Typ;
+ In_Scope := False;
+
+ -- This case occurs when the concurrent type is declared within
+ -- a generic unit. As a result the corresponding record has been
+ -- built and used as the type of the first formal, we just have
+ -- to retrieve the corresponding concurrent type.
+ elsif Is_Concurrent_Record_Type (Formal_Typ)
+ and then Present (Corresponding_Concurrent_Type (Formal_Typ))
+ then
+ Typ := Corresponding_Concurrent_Type (Formal_Typ);
+ In_Scope := False;
+
+ else
+ return;
+ end if;
else
return;
end if;
-- Gather all limited, protected and task interfaces that Typ
- -- implements. Do not collect the interfaces in case of full type
- -- declarations because they don't have interface lists.
+ -- implements. There is no overriding to check if is an inherited
+ -- operation in a type derivation on for a generic actual.
- if Nkind (Parent (Typ)) /= N_Full_Type_Declaration then
+ if Nkind (Parent (Typ)) /= N_Full_Type_Declaration
+ and then Nkind (Parent (Def_Id)) /= N_Subtype_Declaration
+ and then Nkind (Parent (Def_Id)) /= N_Task_Type_Declaration
+ and then Nkind (Parent (Def_Id)) /= N_Protected_Type_Declaration
+ then
Collect_Abstract_Interfaces (Typ, Ifaces_List);
if not Is_Empty_Elmt_List (Ifaces_List) then
Overridden_Subp :=
- Overrides_Synchronized_Primitive
+ Find_Overridden_Synchronized_Primitive
(Def_Id, First_Hom, Ifaces_List, In_Scope);
end if;
end if;
-- Indicate that E overrides the operation from which
-- S is inherited.
- if Present (Alias (S)) then
+ if Present (Alias (S)) then
Set_Overridden_Operation (E, Alias (S));
else
Set_Overridden_Operation (E, S);
if Is_Tagged_Type (Formal_Type) then
null;
+ -- Special handling of Value_Type for CIL case
+
+ elsif Is_Value_Type (Formal_Type) then
+ null;
+
elsif Nkind (Parent (T)) /= N_Access_Function_Definition
and then Nkind (Parent (T)) /= N_Access_Procedure_Definition
then
Error_Msg_N ("invalid use of incomplete type", Param_Spec);
+
+ -- An incomplete type that is not tagged is allowed in an
+ -- access-to-subprogram type only if it is a local declaration
+ -- with a forthcoming completion (3.10.1 (9.2/2)).
+
+ elsif Scope (Formal_Type) /= Scope (Current_Scope) then
+ Error_Msg_N
+ ("invalid use of limited view of type", Param_Spec);
end if;
elsif Ekind (Formal_Type) = E_Void then
and then Null_Exclusion_Present (Param_Spec)
then
if not Is_Access_Type (Formal_Type) then
- Error_Msg_N ("null-exclusion must be applied to an " &
- "access type", Param_Spec);
+ Error_Msg_N
+ ("`NOT NULL` allowed only for an access type", Param_Spec);
+
else
if Can_Never_Be_Null (Formal_Type)
and then Comes_From_Source (Related_Nod)
then
- Error_Msg_N
- ("null-exclusion cannot be applied to " &
- "a null excluding type", Param_Spec);
+ Error_Msg_NE
+ ("`NOT NULL` not allowed (& already excludes null)",
+ Param_Spec,
+ Formal_Type);
end if;
Formal_Type :=
(T => Formal_Type,
Related_Nod => Related_Nod,
Scope_Id => Scope (Current_Scope));
+
+ -- If the designated type of the itype is an itype we
+ -- decorate it with the Has_Delayed_Freeze attribute to
+ -- avoid problems with the backend.
+
+ -- Example:
+ -- type T is access procedure;
+ -- procedure Op (O : not null T);
+
+ if Is_Itype (Directly_Designated_Type (Formal_Type)) then
+ Set_Has_Delayed_Freeze (Formal_Type);
+ end if;
end if;
end if;
return;
end if;
+ -- Iterate over both lists. They may be of different lengths if the two
+ -- specs are not conformant.
+
Fs := First_Formal (Spec);
Fb := First_Formal (Bod);
-
- while Present (Fs) loop
+ while Present (Fs) and then Present (Fb) loop
Generate_Reference (Fs, Fb, 'b');
if Style_Check then
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- multiple interpretations. Interpretations can be added to only one
-- node at a time.
- function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
- -- If T1 and T2 are compatible, return the one that is not
- -- universal or is not a "class" type (any_character, etc).
+ function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id;
+ -- If Typ_1 and Typ_2 are compatible, return the one that is not universal
+ -- or is not a "class" type (any_character, etc).
--------------------
-- Add_One_Interp --
or else Nkind (N) = N_Expanded_Name
or else (Nkind (N) in N_Op and then E = Entity (N))
or else In_Instance
+ or else Ekind (Vis_Type) = E_Anonymous_Access_Type
then
null;
elsif Present (Act2)
and then Nkind (Act2) in N_Op
and then Is_Overloaded (Act2)
- and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
+ and then (Nkind (Right_Opnd (Act2)) = N_Integer_Literal
or else
- Nkind (Right_Opnd (Act1)) = N_Real_Literal)
+ Nkind (Right_Opnd (Act2)) = N_Real_Literal)
and then Has_Compatible_Type (Act2, Standard_Boolean)
then
-- The preference rule on the first actual is not
end if;
end if;
+ -- Check for overloaded CIL convention stuff because the CIL libraries
+ -- do sick things like Console.WriteLine where it matches
+ -- two different overloads, so just pick the first ???
+
+ if Convention (Nam1) = Convention_CIL
+ and then Convention (Nam2) = Convention_CIL
+ and then Ekind (Nam1) = Ekind (Nam2)
+ and then (Ekind (Nam1) = E_Procedure
+ or else Ekind (Nam1) = E_Function)
+ then
+ return It2;
+ end if;
+
-- If the context is universal, the predefined operator is preferred.
-- This includes bounds in numeric type declarations, and expressions
-- in type conversions. If no interpretation yields a universal type,
-- is no rule in 4.6 that allows "access Integer" to be converted to P.
elsif Ada_Version >= Ada_05
- and then Ekind (Etype (L)) = E_Anonymous_Access_Type
+ and then
+ (Ekind (Etype (L)) = E_Anonymous_Access_Type
+ or else
+ Ekind (Etype (L)) = E_Anonymous_Access_Subprogram_Type)
and then Is_Access_Type (Etype (R))
and then Ekind (Etype (R)) /= E_Access_Type
then
return Etype (L);
elsif Ada_Version >= Ada_05
- and then Ekind (Etype (R)) = E_Anonymous_Access_Type
+ and then
+ (Ekind (Etype (R)) = E_Anonymous_Access_Type
+ or else Ekind (Etype (R)) = E_Anonymous_Access_Subprogram_Type)
and then Is_Access_Type (Etype (L))
and then Ekind (Etype (L)) /= E_Access_Type
then
Iface : Entity_Id) return Boolean
is
Target_Typ : Entity_Id;
+ Iface_Typ : Entity_Id;
function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean;
-- Returns True if Typ or some ancestor of Typ implements Iface
+ -------------------------------
+ -- Iface_Present_In_Ancestor --
+ -------------------------------
+
function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is
E : Entity_Id;
AI : Entity_Id;
Elmt : Elmt_Id;
begin
- if Typ = Iface then
+ if Typ = Iface_Typ then
return True;
end if;
while Present (Elmt) loop
AI := Node (Elmt);
- if AI = Iface or else Is_Ancestor (Iface, AI) then
+ if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then
return True;
end if;
-- Check if the current type is a direct derivation of the
-- interface
- if Etype (E) = Iface then
+ if Etype (E) = Iface_Typ then
return True;
end if;
-- Start of processing for Interface_Present_In_Ancestor
begin
+ if Is_Class_Wide_Type (Iface) then
+ Iface_Typ := Etype (Iface);
+ else
+ Iface_Typ := Iface;
+ end if;
+
+ -- Handle subtypes
+
+ Iface_Typ := Base_Type (Iface_Typ);
+
if Is_Access_Type (Typ) then
Target_Typ := Etype (Directly_Designated_Type (Typ));
else
Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
end if;
+ Target_Typ := Base_Type (Target_Typ);
+
-- In case of concurrent types we can't use the Corresponding Record_Typ
-- to look for the interface because it is built by the expander (and
-- hence it is not always available). For this reason we traverse the
-- list of interfaces (available in the parent of the concurrent type)
if Is_Concurrent_Type (Target_Typ) then
- if Present (Interface_List (Parent (Base_Type (Target_Typ)))) then
+ if Present (Interface_List (Parent (Target_Typ))) then
declare
AI : Node_Id;
begin
- AI := First (Interface_List (Parent (Base_Type (Target_Typ))));
+ AI := First (Interface_List (Parent (Target_Typ)));
while Present (AI) loop
- if Etype (AI) = Iface then
+ if Etype (AI) = Iface_Typ then
return True;
elsif Present (Abstract_Interfaces (Etype (AI)))
-- Specific_Type --
-------------------
- function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
+ function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is
+ T1 : constant Entity_Id := Available_View (Typ_1);
+ T2 : constant Entity_Id := Available_View (Typ_2);
B1 : constant Entity_Id := Base_Type (T1);
B2 : constant Entity_Id := Base_Type (T2);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
(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
- -- Typ or some ancestor of Typ implements Iface.
+ -- must be an abstract interface type (or a class-wide abstract interface).
+ -- This function is used to check if Typ or some ancestor of Typ implements
+ -- Iface (returning True only if so).
function Intersect_Types (L, R : Node_Id) return Entity_Id;
-- Find the common interpretation to two analyzed nodes. If one of the