[Ada] various ada 2005 fixes
Arnaud Charlet
charlet@adacore.com
Thu Jun 7 14:09:00 GMT 2007
Tested on i686-linux, committed on trunk
This patch improves the management of class-wide types visible through
limited-with clauses. The following program now compiles without errors.
--
package pkg1 is
type I1 is interface;
type I2 is interface;
type T is new I1 and I2 with null record;
end;
--
package pkg1.impl is
end;
--
limited with Pkg1;
package Pkg2 is
function Test (Obj : pkg1.T'Class) return access pkg1.I2'Class;
end;
--
with Pkg1;
package body Pkg2 is
function Test (Obj : Pkg1.T'Class) return access pkg1.I2'Class is
begin
return null;
end;
end;
--
Command: gcc -c pkg2.adb
In Ada2005 anonymous access types with compatible designated types can be
compared for equality, The operator is defined in standard and immediately
visible, unless a proper user-defined operator exists. Cases of ambiguity are
resolved later.
gnat.dg/anon2.adb must compile quietly.
Rule 3.10.1 (8 1/2) of Ada 2005 allows a tagged incomplete view of a type
to be used as the subtype of a parameter in a formal part of a subprogram
declaration. The formal part can be processed by Gigi before the full
view is encountered. Therefore Is_By_Reference_Type must return true for
the tagged incomplete view, as it does for any tagged types, in order for
Gigi to correctly translate the subprogram declaration.
gnat.dg/ref_type.adb must compile silently.
Also, the equality function declared on universal access types applies as well
to access to subprogram types, to enforce the legality rule of 4.5.2(9.2).. The
code had omitted to include access to subprograms, when finding a common type
to which to convert operands of some binary operator.
gnat.dg/equal_access.adb must compile quietly.
If the first formal of a primitive operation is an access parameter, the
prefix in a call is allowed to be an object of the designated type, and
an implicit 'Access is created for the first actual. However this is not
legal if the object is not aliased. This patch simply improves on the
error message generated for this case.
Compilation of cl.adb in Ada 2005 mode must procedure the following.
--
cl.adb:12:05: object in prefixed call to "CW_Proc" must be aliased
(RM-2005 4.3.1 (13))
cl.adb:13:05: object in prefixed call to "Prim_Proc" must be aliased
(RM-2005 4.3.1 (13))
--
package pref is
type Base is tagged null record;
procedure CW_Proc (Obj : access Base'Class);
procedure Prim_Proc (Obj : access Base);
end pref;
--
with Pref; use Pref;
procedure Cl is
A : access Base := new Base;
A_O : Base := A.all;
--
BC_A : access Base'Class := new Base;
BC_O : Base'Class :=BC_A.all;
--
begin
BC_A.CW_Proc;
BC_O.CW_Proc; -- error : not Aliased.
A_O.Prim_Proc; -- error : not Aliased.
A.Prim_Proc;
end Cl;
Finally, prefixed notation combined with implicit dereference and
implicit 'access can lead to ambiguous calls between primitive operations
that do not hide each other.
Compilation of Client below must produce the following output:
--
client.adb:12:09: ambiguous call to "CW_Proc"
client.adb:12:09: possible interpretation at prefix.ads:6
client.adb:12:09: possible interpretation (with implicit dereference)
at prefix.ads:5
client.adb:13:09: ambiguous call to "CW_Proc"
client.adb:13:09: possible interpretation (with implicit Access)
at prefix.ads:6
client.adb:13:09: possible interpretation at prefix.ads:5
client.adb:14:08: ambiguous call to "Prim_Proc"
client.adb:14:08: possible interpretation at prefix.ads:7
client.adb:14:08: possible interpretation (with implicit Access)
at prefix.ads:8
client.adb:15:06: ambiguous call to "Prim_Proc"
client.adb:15:06: possible interpretation (with implicit dereference)
at prefix.ads:7
client.adb:15:06: possible interpretation at prefix.ads:8
--
package Prefix is
type Base is tagged null record;
--
procedure CW_Proc (Obj : Base'Class);
procedure CW_Proc (Obj : access Base'Class);
procedure Prim_Proc (Obj : Base);
procedure Prim_Proc (Obj : access Base);
end Prefix;
--
with Prefix; use Prefix;
procedure Client is
A : access Base := new Base;
A_O : aliased Base := A.all;
--
BC_A : access Base'Class := new Base;
BC_O : aliased Base'Class :=BC_A.all;
--
begin
-- if A_O'access= null then raise program_error; end if;
BC_A.CW_Proc;
BC_O.CW_Proc;
A_O.Prim_Proc;
A.Prim_Proc;
end Client;
2007-06-06 Javier Miranda <miranda@adacore.com>
Ed Schonberg <schonberg@adacore.com>
Robert Dewar <dewar@adacore.com>
Eric Botcazou <ebotcazou@adacore.com>
Arnaud Charlet <charlet@adacore.com>
* einfo.ads, einfo.adb (Available_View): New synthesized attribute
applicable 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.
New attributes Static_Initialization and Static_Elaboration_Desired.
Remove the pragma Thread_Body, and the associated flag
Is_Thread_Body in entities, and all related code.
(Suppress_Value_Tracking_On_Call): New flag
E_Exception has Esize and Alignment fields
(Universal_Aliasing): New function.
(Set_Universal_Aliasing): New procedure.
(Write_Entity_Flags): Deal with Universal_Aliasing flag.
(Check_Nested_Access): New procedure.
(Has_Up_Level_Access, Set_Has_Up_Level_Access): New procedures.
(Find_Direct_Name, Note_Possible_Modification): Use Check_Nested_Access.
(Related_Interface): New attribute. Present in dispatch table pointer
components of records. Set to point to the entity of the corresponding
interface type.
(Is_By_Reference_Type): Recurse on the full view of an incomplete type.
(Original_Access_Type): Remove, not needed.
(Root_Type): Handle properly subtypes of class-wide-types.
Update comments.
* sem_ch4.adb (Analyze_Explicit_Dereference): Add support for
class-wide types visible through limited-with clauses.
(Try_Primitive_Operation): When examining all primitive operations of a
tagged type, do not consider subprograms labeled as hidden unless they
belong to a private generic type with a tagged parent.
(Try_Object_Operation): Extensive rewriting, to handle properly various
overloading cases, when several ancestors may have class-wide operations
that are possible candidates, and when the overloaded functions return
array types and have defaulted parameters so that the call may be
interpreted as an indexing.
(Analyze_Allocator): Remove Mark_Allocator and its invocation.
(Process_Function_Call): use Next, rather than Next_Actual, to analyze
successive actuals before analyzing the call itself.
(Try_Primitive_Operation): A primitive operation is compatible with the
prefix if the prefix has a synchronized type and the type of the formal
is its corresponding record, as can be the case when the primitive
operation is declared outside of the body of the type.
(Traverse_Homonyms): New subprocedure of Try_Class_Wide_Operation, to
perform homonym traversal, looking for class-wide operation matches
(formerly done in statements of Try_Class_Wide_Operation). Matches on
access parameters are now restricted to anonymous access types.
(Mark_Allocator): An allocator with a discriminant association parent is
a coextension.
(Try_One_Prefix_Interpretation): If the type of the object is
incomplete, as can be happen when it is a limited view obtained through
a limited_with_clause, the selected component is not part of a prefixed
call.
(Complete_Object_Operation): Diagnose properly an object that is not
aliased when the corresponding controlling formal is an access
parameter.
(Try_Primitive_Operation, Try_Class_Wide_Operation): Diagnose properly
ambiguous calls in prefixed notation, where two primitives differ only
in that the controlling argument of one is an access parameter.
* sem_ch6.adb (Has_Single_Return): Add guard in code that determines
whether a function that returns an unconstrained type can be inlined.
(Process_Formals): Diagnose properly the illegal use of an incomplete
type in the profile of an access_to_subprogram declaration.
(Check_Synchronized_Overriding): Nothing check for concurrent types, the
operations are attached to the corresponding record.
(Analyze_Subprogram_Specification): Add variables Formal and Formal_Typ.
When processing a primitive of a concurrent type which implements an
interface change the type of all controlling formals to that of the
corresponding record type.
(Check_Synchronized_Overriding): Relax the conditional logic when trying
to determine the tagged type to which a primitive belongs.
(Check_Conventions): Capture condition to ignore a primitive operation
(which is shared between the loop in Check_Conventions and the one in
Check_Convention) in a new local function Skip_Check.
(Check_Convention): Rename Prim_Op to Second_Prim_Op to avoid possible
confusion with Check_Conventions' own Prim_Op local variable.
(Create_Extra_Formals): Test for a tagged result type rather than a
controlling result when determining whether to add a BIP_Alloc_Form
formal and a BIP_Final_List formal to the function.
(Check_Conformance); For parameters that are anonymous access types,
subtype conformance requires that the not null and the constant
indicators must match
(Check_Synchronized_Overriding): New parameter Formal_Typ. Add machinery
to retrieve the appropriate type when processing a concurrent type
declared within a generic. Minor comment reformatting. Change invocation
of Overrides_Synchronized_Primitive to Find_Overridden_Synchronized_Pri-
mitive.
(Analyze_Subprogram_Body): If the return type of a function is an
anonymous access to the limited view of a class-wide type, and the
non-limited view of the type is available, update the type of the
function so that code can be generated.
(Process_Formals): In case of access-subtype itype whose designated
type is also an itype (situation that happens now with access to
subprograms) we mark the access-type itype with the Has_Delayed_Freeze
attribute to avoid backend problems.
(Check_Return_Subtype_Indication): Replace R_Type with R_Stm_Type in
init of R_Stm_Type_Is_Anon_Access. Also check that base types of the
anonymous types' designated types are same before testing
Subtypes_Statically_Match.
(Create_Extra_Formals): Test for a named access parameter that is a
controlling formal as an additional condition for adding an
accessibility level formal. This can occur in the subp type created for
dispatching calls in Expand_Dispatching_Call, and allows calling
Create_Extra_Formals from that procedure rather than special-casing the
extra formals there.
(Create_Extra_Formals): Add BIP_Alloc_Form and BIP_Final_List formals
when the function has a controlling result.
(Check_Returns): Add much more knowledge of the optimization of local
raise statements to gotos, to retain proper warnings in this case.
(Check_Statement_Sequence): Ignore N_Push_xxx_Label and N_Pop_xxx_Label
nodes when looking for last statement.
* sem_type.ads, sem_type.adb (Specific_Type): Add support for
class-wide types visible through limited with clauses.
(Add_One_Interp): If the operands are anonymous access types, the
predefined operator on universal_access is immediately visibles
(Find_Unique_Type): Handle anonymous access to subprogram types just as
other anonymous access types.
(Disambiguate): Take into account CIL convention.
(Interface_Present_In_Ancestor): Add support for class-wide interfaces.
-------------- next part --------------
Index: einfo.ads
===================================================================
--- einfo.ads (revision 124068)
+++ einfo.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- 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- --
@@ -31,6 +31,7 @@
-- --
------------------------------------------------------------------------------
+with Namet; use Namet;
with Snames; use Snames;
with Types; use Types;
with Uintp; use Uintp;
@@ -329,8 +330,10 @@ package Einfo is
-- 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
@@ -357,15 +360,16 @@ package Einfo is
-- 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
@@ -383,6 +387,13 @@ package Einfo is
-- 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.
@@ -458,11 +469,19 @@ package Einfo is
-- 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
@@ -969,8 +988,9 @@ package Einfo is
-- 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-
@@ -1342,8 +1362,8 @@ package Einfo is
-- 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
@@ -1448,6 +1468,11 @@ package Einfo is
-- 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
@@ -1543,7 +1568,7 @@ package Einfo is
-- 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
@@ -1640,8 +1665,10 @@ package Einfo is
-- 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
@@ -2219,8 +2246,9 @@ package Einfo is
-- 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
@@ -2229,8 +2257,9 @@ package Einfo is
-- 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
@@ -2488,8 +2517,9 @@ package Einfo is
-- 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
@@ -2511,10 +2541,6 @@ package Einfo is
-- 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
@@ -2921,12 +2947,6 @@ package Einfo is
-- 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
@@ -3111,11 +3131,16 @@ package Einfo is
-- 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
@@ -3310,6 +3335,19 @@ package Einfo is
-- 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,
@@ -3354,6 +3392,12 @@ package Einfo is
-- 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
@@ -3414,6 +3458,15 @@ package Einfo is
-- 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
@@ -4310,6 +4363,7 @@ package Einfo is
-- Referenced_As_LHS (Flag36)
-- Suppress_Elaboration_Warnings (Flag148)
-- Suppress_Style_Checks (Flag165)
+ -- Suppress_Value_Tracking_On_Call (Flag217)
-- Was_Hidden (Flag196)
-- Declaration_Node (synth)
@@ -4354,6 +4408,7 @@ package Einfo is
-- 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)
@@ -4368,7 +4423,6 @@ package Einfo is
-- 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)
@@ -4388,6 +4442,7 @@ package Einfo is
-- 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)
@@ -4409,14 +4464,12 @@ package Einfo is
-- 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)
@@ -4511,6 +4564,7 @@ package Einfo is
-- 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)
@@ -4540,6 +4594,7 @@ package Einfo is
-- 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)
@@ -4639,6 +4694,7 @@ package Einfo is
-- (plus type attributes)
-- E_Exception
+ -- Esize (Uint12)
-- Alignment (Uint14)
-- Renamed_Entity (Node18)
-- Register_Exception_Call (Node20)
@@ -4709,7 +4765,6 @@ package Einfo is
-- 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)
@@ -4883,6 +4938,7 @@ package Einfo is
-- 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)
@@ -4933,6 +4989,7 @@ package Einfo is
-- 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)
@@ -4964,7 +5021,6 @@ package Einfo is
-- 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)
@@ -5025,6 +5081,7 @@ package Einfo is
-- 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)
@@ -5052,6 +5109,7 @@ package Einfo is
-- 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)
@@ -5157,6 +5215,7 @@ package Einfo is
-- 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)
@@ -5515,6 +5574,7 @@ package Einfo is
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;
@@ -5630,7 +5690,6 @@ package Einfo is
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;
@@ -5672,7 +5731,6 @@ package Einfo is
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;
@@ -5695,6 +5753,7 @@ package Einfo is
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;
@@ -5716,6 +5775,8 @@ package Einfo is
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;
@@ -5723,9 +5784,11 @@ package Einfo is
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;
@@ -5798,6 +5861,7 @@ package Einfo is
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;
@@ -6035,6 +6099,7 @@ package Einfo is
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);
@@ -6157,7 +6222,6 @@ package Einfo is
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);
@@ -6199,7 +6263,6 @@ package Einfo is
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);
@@ -6222,6 +6285,7 @@ package Einfo is
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);
@@ -6243,6 +6307,8 @@ package Einfo is
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);
@@ -6250,9 +6316,11 @@ package Einfo is
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);
@@ -6641,6 +6709,7 @@ package Einfo is
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);
@@ -6767,7 +6836,6 @@ package Einfo is
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);
@@ -6812,7 +6880,6 @@ package Einfo is
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);
@@ -6836,6 +6903,7 @@ package Einfo is
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);
@@ -6857,6 +6925,8 @@ package Einfo is
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);
@@ -6864,9 +6934,11 @@ package Einfo is
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);
@@ -7012,7 +7084,6 @@ package Einfo is
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);
@@ -7028,10 +7099,12 @@ package Einfo is
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);
@@ -7122,7 +7195,6 @@ package Einfo is
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);
@@ -7135,6 +7207,7 @@ package Einfo is
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);
@@ -7163,7 +7236,6 @@ package Einfo is
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);
@@ -7186,6 +7258,7 @@ package Einfo is
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);
@@ -7207,6 +7280,8 @@ package Einfo is
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);
@@ -7214,9 +7289,11 @@ package Einfo is
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);
Index: einfo.adb
===================================================================
--- einfo.adb (revision 124068)
+++ einfo.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- 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- --
@@ -35,7 +35,6 @@ pragma Style_Checks (All_Checks);
-- 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;
@@ -220,6 +219,8 @@ package body Einfo is
-- Overridden_Operation Node26
-- Package_Instantiation Node26
+ -- Related_Interface Node26
+ -- Static_Initialization Node26
-- Wrapped_Entity Node27
@@ -318,7 +319,7 @@ package body Einfo is
-- 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
@@ -470,8 +471,26 @@ package body Einfo is
-- 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 --
@@ -1387,7 +1406,6 @@ package body Einfo is
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;
@@ -1412,6 +1430,15 @@ package body Einfo is
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));
@@ -1734,7 +1761,6 @@ package body Einfo is
function Is_Limited_Interface (Id : E) return B is
begin
- pragma Assert (Is_Interface (Id));
return Flag197 (Id);
end Is_Limited_Interface;
@@ -1897,11 +1923,6 @@ package body Einfo is
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);
@@ -2144,14 +2165,6 @@ package body Einfo is
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));
@@ -2282,6 +2295,12 @@ package body Einfo is
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);
@@ -2404,6 +2423,19 @@ package body Einfo is
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
@@ -2441,6 +2473,11 @@ package body Einfo is
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);
@@ -2458,6 +2495,12 @@ package body Einfo is
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);
@@ -3445,6 +3488,15 @@ package body Einfo is
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);
@@ -3919,7 +3971,8 @@ package body Einfo is
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;
@@ -4137,11 +4190,6 @@ package body Einfo is
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));
@@ -4394,14 +4442,6 @@ package body Einfo is
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));
@@ -4532,6 +4572,12 @@ package body Einfo is
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);
@@ -4656,6 +4702,19 @@ package body Einfo is
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);
@@ -4696,6 +4755,11 @@ package body Einfo is
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);
@@ -4713,6 +4777,12 @@ package body Einfo is
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);
@@ -5082,6 +5152,28 @@ package body Einfo is
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 --
---------------
@@ -5816,6 +5908,8 @@ package body Einfo is
-- 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);
@@ -5828,7 +5922,6 @@ package body Einfo is
elsif Is_Private_Type (Btype) then
declare
Utyp : constant Entity_Id := Underlying_Type (Btype);
-
begin
if No (Utyp) then
return False;
@@ -5837,6 +5930,17 @@ package body Einfo is
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;
@@ -6027,9 +6131,12 @@ package body Einfo is
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)
@@ -6455,6 +6562,9 @@ package body Einfo is
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
@@ -6933,6 +7043,7 @@ package body Einfo is
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));
@@ -7019,7 +7130,6 @@ package body Einfo is
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));
@@ -7056,11 +7166,14 @@ package body Einfo is
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));
@@ -7360,6 +7473,7 @@ package body Einfo is
E_Component |
E_Constant |
E_Discriminant |
+ E_Exception |
E_In_Parameter |
E_In_Out_Parameter |
E_Out_Parameter |
@@ -7434,6 +7548,7 @@ package body Einfo is
when Type_Kind |
Formal_Kind |
E_Constant |
+ E_Exception |
E_Variable |
E_Loop_Parameter =>
Write_Str ("Alignment");
@@ -7822,10 +7937,6 @@ package body Einfo is
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;
@@ -8003,13 +8114,21 @@ package body Einfo is
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??");
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 124068)
+++ sem_ch4.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- 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- --
@@ -346,45 +346,8 @@ package body Sem_Ch4 is
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
@@ -1293,10 +1256,10 @@ package body Sem_Ch4 is
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));
@@ -1308,7 +1271,23 @@ package body Sem_Ch4 is
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
@@ -1466,11 +1445,31 @@ package body Sem_Ch4 is
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);
@@ -2448,7 +2447,9 @@ package body Sem_Ch4 is
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);
@@ -3008,12 +3009,29 @@ package body Sem_Ch4 is
-- 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));
@@ -5099,7 +5117,11 @@ package body Sem_Ch4 is
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;
@@ -5111,18 +5133,27 @@ package body Sem_Ch4 is
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
@@ -5134,29 +5165,91 @@ package body Sem_Ch4 is
-- 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.
@@ -5170,8 +5263,21 @@ package body Sem_Ch4 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
+
+ -- 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);
- if not Is_Access_Type (Formal_Type)
+ elsif not Is_Access_Type (Formal_Type)
and then Is_Access_Type (Etype (Obj))
then
Rewrite (First_Actual,
@@ -5189,28 +5295,85 @@ package body Sem_Ch4 is
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);
@@ -5252,13 +5415,13 @@ package body Sem_Ch4 is
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;
@@ -5283,7 +5446,7 @@ package body Sem_Ch4 is
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)
@@ -5293,7 +5456,7 @@ package body Sem_Ch4 is
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;
@@ -5306,20 +5469,41 @@ package body Sem_Ch4 is
(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;
-
- 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 : 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;
- Anc_Type := Obj_Type;
+ begin
+ Error := False;
- loop
Cls_Type := Class_Wide_Type (Anc_Type);
Hom := Current_Entity (Subprog);
@@ -5334,49 +5518,188 @@ package body Sem_Ch4 is
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_Name (Call_Node, Hom_Ref);
-
- Analyze_One_Call
- (N => Call_Node,
- Nam => Hom,
- Report => Report_Error,
- Success => Success,
- Skip_First => True);
+ Set_Is_Overloaded (Call_Node, False);
+ Success := False;
- if Success then
+ 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));
+
+ Set_Name (Call_Node, Hom_Ref);
+
+ 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);
+ else
+ Analyze_One_Call
+ (N => Call_Node,
+ Nam => Hom,
+ Report => Report_Error,
+ Success => Success,
+ Skip_First => True);
- return 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 --
+ -------------------------
+
+ 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;
- -- Examine other ancestor types
+ -- 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 --
-----------------------------
@@ -5387,9 +5710,15 @@ package body Sem_Ch4 is
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
@@ -5404,39 +5733,42 @@ package body Sem_Ch4 is
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;
@@ -5456,21 +5788,31 @@ package body Sem_Ch4 is
-- 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,
@@ -5479,18 +5821,29 @@ package body Sem_Ch4 is
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;
@@ -5498,46 +5851,19 @@ package body Sem_Ch4 is
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)));
@@ -5547,29 +5873,38 @@ package body Sem_Ch4 is
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)
-
- or else
- Try_Class_Wide_Operation
- (Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace)
- then
+ if not Is_Overloaded (Obj) then
+ Try_One_Prefix_Interpretation (Obj_Type);
+
+ 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
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb (revision 124068)
+++ sem_ch6.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- 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- --
@@ -163,7 +163,7 @@ package body Sem_Ch6 is
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
@@ -286,7 +286,7 @@ package body Sem_Ch6 is
-- 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:
@@ -526,11 +526,11 @@ package body Sem_Ch6 is
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
@@ -545,10 +545,15 @@ package body Sem_Ch6 is
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;
@@ -560,10 +565,30 @@ package body Sem_Ch6 is
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);
@@ -742,7 +767,7 @@ package body Sem_Ch6 is
-- 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;
@@ -1265,6 +1290,11 @@ package body Sem_Ch6 is
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)
@@ -1801,7 +1831,7 @@ package body Sem_Ch6 is
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.
@@ -1835,12 +1865,12 @@ package body Sem_Ch6 is
(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)
@@ -1848,6 +1878,7 @@ package body Sem_Ch6 is
declare
E : Entity_Id;
Etyp : Entity_Id;
+ Rtyp : Entity_Id;
begin
-- Check the type of the formals
@@ -1891,6 +1922,24 @@ package body Sem_Ch6 is
" 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;
@@ -2060,12 +2109,15 @@ package body Sem_Ch6 is
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
@@ -2165,9 +2217,9 @@ package body Sem_Ch6 is
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);
@@ -2249,7 +2301,7 @@ package body Sem_Ch6 is
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;
@@ -2299,6 +2351,8 @@ package body Sem_Ch6 is
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
@@ -2321,30 +2375,31 @@ package body Sem_Ch6 is
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;
@@ -2657,6 +2712,7 @@ package body Sem_Ch6 is
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;
@@ -2836,7 +2892,7 @@ package body Sem_Ch6 is
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);
@@ -2987,7 +3043,7 @@ package body Sem_Ch6 is
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
@@ -3010,7 +3066,7 @@ package body Sem_Ch6 is
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
@@ -3161,50 +3217,49 @@ package body Sem_Ch6 is
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
@@ -3218,12 +3273,11 @@ package body Sem_Ch6 is
-- 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;
@@ -3245,7 +3299,7 @@ package body Sem_Ch6 is
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
@@ -3274,7 +3328,7 @@ package body Sem_Ch6 is
-- 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
@@ -3313,14 +3367,22 @@ package body Sem_Ch6 is
-----------------------
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 --
@@ -3331,8 +3393,8 @@ package body Sem_Ch6 is
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 --
@@ -3343,9 +3405,8 @@ package body Sem_Ch6 is
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);
@@ -3370,42 +3431,46 @@ package body Sem_Ch6 is
-- 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;
@@ -3414,21 +3479,19 @@ package body Sem_Ch6 is
-- 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);
@@ -3792,6 +3855,13 @@ package body Sem_Ch6 is
-- 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;
@@ -3811,6 +3881,7 @@ package body Sem_Ch6 is
procedure Check_Statement_Sequence (L : List_Id) is
Last_Stm : Node_Id;
+ Stm : Node_Id;
Kind : Node_Kind;
Raise_Exception_Call : Boolean;
@@ -3824,6 +3895,65 @@ package body Sem_Ch6 is
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
@@ -3843,7 +3973,9 @@ package body Sem_Ch6 is
((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;
@@ -4236,13 +4368,20 @@ package body Sem_Ch6 is
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 --
@@ -4255,7 +4394,7 @@ package body Sem_Ch6 is
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 ???.
@@ -4263,27 +4402,36 @@ package body Sem_Ch6 is
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.
-
- elsif From_With_Type (T1)
- and then Ekind (T1) = E_Incomplete_Type
- and then T2 = Non_Limited_View (T1)
+ else
+ return False;
+ end if;
+ end Base_Types_Match;
+
+ -------------------------------
+ -- 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
@@ -4298,9 +4446,13 @@ package body Sem_Ch6 is
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 Matches_Limited_With_View (T1, T2) then
+ return True;
- if Base_Types_Match (Type_1, Type_2) then
+ elsif Base_Types_Match (Type_1, Type_2) then
return Ctype <= Mode_Conformant
or else Subtypes_Statically_Match (Type_1, Type_2);
@@ -4327,7 +4479,7 @@ package body Sem_Ch6 is
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 :=
@@ -4587,7 +4739,12 @@ package body Sem_Ch6 is
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
@@ -4597,7 +4754,9 @@ package body Sem_Ch6 is
-- 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
@@ -4648,10 +4807,15 @@ package body Sem_Ch6 is
-- 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.
+ -- 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) then
+ if not Is_Constrained (Result_Subt)
+ or else Is_Tagged_Type (Underlying_Type (Result_Subt))
+ then
Discard :=
Add_Extra_Formal
(E, Standard_Natural,
@@ -4669,10 +4833,13 @@ package body Sem_Ch6 is
-- 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
@@ -5027,7 +5194,7 @@ package body Sem_Ch6 is
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;
@@ -5767,6 +5934,7 @@ package body Sem_Ch6 is
First_Hom : Entity_Id;
Overridden_Subp : out Entity_Id)
is
+ Formal_Typ : Entity_Id;
Ifaces_List : Elist_Id;
In_Scope : Boolean;
Typ : Entity_Id;
@@ -5783,8 +5951,9 @@ package body Sem_Ch6 is
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))
@@ -5793,27 +5962,49 @@ package body Sem_Ch6 is
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;
@@ -6163,7 +6354,7 @@ package body Sem_Ch6 is
-- 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);
@@ -6538,10 +6729,23 @@ package body Sem_Ch6 is
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
@@ -6558,15 +6762,17 @@ package body Sem_Ch6 is
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 :=
@@ -6574,6 +6780,18 @@ package body Sem_Ch6 is
(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;
@@ -6702,10 +6920,12 @@ package body Sem_Ch6 is
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
Index: sem_type.ads
===================================================================
--- sem_type.ads (revision 124068)
+++ sem_type.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- 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- --
@@ -207,8 +207,9 @@ package Sem_Type is
(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
Index: sem_type.adb
===================================================================
--- sem_type.adb (revision 124068)
+++ sem_type.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- 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- --
@@ -167,9 +167,9 @@ package body Sem_Type is
-- 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 --
@@ -344,6 +344,7 @@ package body Sem_Type is
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;
@@ -1332,9 +1333,9 @@ package body Sem_Type is
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
@@ -1451,6 +1452,19 @@ package body Sem_Type is
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,
@@ -1869,14 +1883,19 @@ package body Sem_Type is
-- 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
@@ -2058,17 +2077,22 @@ package body Sem_Type is
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;
@@ -2091,7 +2115,7 @@ package body Sem_Type is
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;
@@ -2109,7 +2133,7 @@ package body Sem_Type is
-- 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;
@@ -2128,6 +2152,16 @@ package body Sem_Type is
-- 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
@@ -2138,20 +2172,22 @@ package body Sem_Type is
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)))
@@ -2674,7 +2710,9 @@ package body Sem_Type is
-- 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);
More information about the Gcc-patches
mailing list