diff options
author | Ed Schonberg <schonberg@adacore.com> | 2007-04-06 11:26:20 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2007-04-06 11:26:20 +0200 |
commit | aab883ecd1e8d05346815ae041e7c9c9e1cb7431 (patch) | |
tree | e9bd15814fc83fc88fc867340d4292acea3c954e /gcc/ada | |
parent | da931119f4caeba05e524717a2ee3492aecb5bb0 (diff) | |
download | gcc-aab883ecd1e8d05346815ae041e7c9c9e1cb7431.zip gcc-aab883ecd1e8d05346815ae041e7c9c9e1cb7431.tar.gz gcc-aab883ecd1e8d05346815ae041e7c9c9e1cb7431.tar.bz2 |
sem_ch4.adb (Try_Primitive_Operation): The call is legal if the prefix type is a discriminated subtype of the type of...
2007-04-06 Ed Schonberg <schonberg@adacore.com>
Bob Duff <duff@adacore.com>
Gary Dismukes <dismukes@adacore.com>
* sem_ch4.adb (Try_Primitive_Operation): The call is legal if the
prefix type is a discriminated subtype of the type of the formal.
(Analyze_Allocator): Collect all coextensions regardless of the context.
Whether they can be allocated statically is determined in exp_ch4.
(Analyze_Selected_Component): If the prefix is a limited view and the
non-limited view is available, use the non-limited one.
(Operator_Check): For "X'Access = Y'Access" (which is ambiguous, and
therefore illegal), suggest a qualified expression rather than a type
conversion, because a type conversion would be illegal in this context.
(Anayze_Allocator): Trace recursively all nested allocators so that all
coextensions are on the corresponding list for the root. Do no mark
coextensions if the root allocator is within a declaration for a stack-
allocated object, because the access discriminants will be allocated on
the stack as well.
(Analyze_Call): Remove restriction on calls to limited functions for the
cases of generic actuals for formal objects, defaults for formal objects
and defaults for record components.
(Analyze_Allocator): Before analysis, chain coextensions on the proper
element list. Their expansion is delayed until the enclosing allocator
is processed and its finalization list constructed.
(Try_Primitive_Operation): If the prefix is a concurrent type, looks
for an operation with the given name among the primitive operations of
the corresponding record type.
(Analyze_Selected_Component): If the prefix is a task type that
implements an interface, and there is no entry with the given name,
check whether there is another primitive operation (e.g. a function)
with that name.
(Try_Object_Operation, Analyze_One_Call, Try_Indexed_Call): Handle
properly the indexing of a function call written in prefix form, where
the function returns an array type, and all parameters of the function
except the first have defaults.
(Analyze_Equality_Op): If this is a call to an implicit inequality, keep
the original operands, rather than relocating them, for efficiency and
to work properly when an operand is overloaded.
(Analyze_Allocator,Operator_Check,Remove_Abstract_Operations): Split
Is_Abstract flag into Is_Abstract_Subprogram and Is_Abstract_Type.
(Analyze_Selected_Component): If the prefix is a private extension, only
scan the visible components, not those of the full view.
(Try_Primitive_Operation): If the operation is a procedure, collect all
possible interpretations, as for a function, because in the presence of
classwide parameters several primitive operations of the type can match
the given arguments.
From-SVN: r123594
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/sem_ch4.adb | 252 |
1 files changed, 184 insertions, 68 deletions
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 6d8e81e..14f7c10 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -234,25 +234,28 @@ package body Sem_Ch4 is -- operation is not a candidate interpretation. function Try_Indexed_Call - (N : Node_Id; - Nam : Entity_Id; - Typ : Entity_Id) return Boolean; - -- If a function has defaults for all its actuals, a call to it may - -- in fact be an indexing on the result of the call. Try_Indexed_Call - -- attempts the interpretation as an indexing, prior to analysis as - -- a call. If both are possible, the node is overloaded with both - -- interpretations (same symbol but two different types). + (N : Node_Id; + Nam : Entity_Id; + Typ : Entity_Id; + Skip_First : Boolean) return Boolean; + -- If a function has defaults for all its actuals, a call to it may in fact + -- be an indexing on the result of the call. Try_Indexed_Call attempts the + -- interpretation as an indexing, prior to analysis as a call. If both are + -- possible, the node is overloaded with both interpretations (same symbol + -- but two different types). If the call is written in prefix form, the + -- prefix becomes the first parameter in the call, and only the remaining + -- actuals must be checked for the presence of defaults. function Try_Indirect_Call (N : Node_Id; Nam : Entity_Id; Typ : Entity_Id) return Boolean; - -- Similarly, a function F that needs no actuals can return an access - -- to a subprogram, and the call F (X) interpreted as F.all (X). In - -- this case the call may be overloaded with both interpretations. + -- Similarly, a function F that needs no actuals can return an access to a + -- subprogram, and the call F (X) interpreted as F.all (X). In this case + -- the call may be overloaded with both interpretations. function Try_Object_Operation (N : Node_Id) return Boolean; - -- Ada 2005 (AI-252): Give support to the object operation notation + -- Ada 2005 (AI-252): Support the object.operation notation ------------------------ -- Ambiguous_Operands -- @@ -343,10 +346,48 @@ 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 + Acc_Type := Create_Itype (E_Allocator_Type, N); Set_Etype (Acc_Type, Acc_Type); Init_Size_Align (Acc_Type); @@ -383,7 +424,7 @@ package body Sem_Ch4 is Set_Etype (E, Type_Id); - -- Case where no qualified expression is present + -- Case where allocator has a subtype indication else declare @@ -507,7 +548,7 @@ package body Sem_Ch4 is end; end if; - if Is_Abstract (Type_Id) then + if Is_Abstract_Type (Type_Id) then Error_Msg_N ("cannot allocate abstract object", E); end if; @@ -904,8 +945,8 @@ package body Sem_Ch4 is elsif not Is_Overloaded (N) and then Is_Entity_Name (Nam) then - -- Resolution yields a single interpretation. Verify that - -- is has the proper capitalization. + -- Resolution yields a single interpretation. Verify that the + -- reference has capitalization consistent with the declaration. Set_Entity_With_Style_Check (Nam, Entity (Nam)); Generate_Reference (Entity (Nam), Nam); @@ -918,21 +959,17 @@ package body Sem_Ch4 is End_Interp_List; end if; - -- Check for not-yet-implemented cases of AI-318. - -- We only need to check for inherently limited types, - -- because other limited types will be returned by copy, - -- which works just fine. + -- Check for not-yet-implemented cases of AI-318. We only need to check + -- for inherently limited types, because other limited types will be + -- returned by copy, which works just fine. if Ada_Version >= Ada_05 and then not Debug_Flag_Dot_L and then Is_Inherently_Limited_Type (Etype (N)) and then (Nkind (Parent (N)) = N_Selected_Component - or else Nkind (Parent (N)) = N_Indexed_Component - or else Nkind (Parent (N)) = N_Slice - or else Nkind (Parent (N)) = N_Attribute_Reference - or else Nkind (Parent (N)) = N_Component_Declaration - or else Nkind (Parent (N)) = N_Formal_Object_Declaration - or else Nkind (Parent (N)) = N_Generic_Association) + or else Nkind (Parent (N)) = N_Indexed_Component + or else Nkind (Parent (N)) = N_Slice + or else Nkind (Parent (N)) = N_Attribute_Reference) then Error_Msg_N ("(Ada 2005) limited function call in this context" & " is not yet implemented", N); @@ -1183,8 +1220,8 @@ package body Sem_Ch4 is Make_Op_Not (Loc, Right_Opnd => Make_Op_Eq (Loc, - Left_Opnd => Relocate_Node (Left_Opnd (N)), - Right_Opnd => Relocate_Node (Right_Opnd (N))))); + Left_Opnd => Left_Opnd (N), + Right_Opnd => Right_Opnd (N)))); Set_Entity (Right_Opnd (N), Op_Id); Analyze (N); @@ -1678,7 +1715,7 @@ package body Sem_Ch4 is then U_N := Entity (P); - if Ekind (U_N) in Type_Kind then + if Is_Type (U_N) then -- Reformat node as a type conversion @@ -1947,6 +1984,18 @@ package body Sem_Ch4 is is Actuals : constant List_Id := Parameter_Associations (N); Prev_T : constant Entity_Id := Etype (N); + Must_Skip : constant Boolean := Skip_First + or else Nkind (Original_Node (N)) = N_Selected_Component + or else + (Nkind (Original_Node (N)) = N_Indexed_Component + and then Nkind (Prefix (Original_Node (N))) + = N_Selected_Component); + -- The first formal must be omitted from the match when trying to find + -- a primitive operation that is a possible interpretation, and also + -- after the call has been rewritten, because the corresponding actual + -- is already known to be compatible, and because this may be an + -- indexing of a call with default parameters. + Formal : Entity_Id; Actual : Node_Id; Is_Indexed : Boolean := False; @@ -2000,18 +2049,26 @@ package body Sem_Ch4 is -- If the subprogram has no formals, or if all the formals have -- defaults, and the return type is an array type, the node may -- denote an indexing of the result of a parameterless call. + -- In Ada 2005, the subprogram may have one non-defaulted formal, + -- and the call may have been written in prefix notation, so that + -- the rebuilt parameter list has more than one actual. - if Needs_No_Actuals (Nam) - and then Present (Actuals) + if Present (Actuals) + and then + (Needs_No_Actuals (Nam) + or else + (Needs_One_Actual (Nam) + and then Present (Next_Actual (First (Actuals))))) then if Is_Array_Type (Subp_Type) then - Is_Indexed := Try_Indexed_Call (N, Nam, Subp_Type); + Is_Indexed := Try_Indexed_Call (N, Nam, Subp_Type, Must_Skip); elsif Is_Access_Type (Subp_Type) and then Is_Array_Type (Designated_Type (Subp_Type)) then Is_Indexed := - Try_Indexed_Call (N, Nam, Designated_Type (Subp_Type)); + Try_Indexed_Call + (N, Nam, Designated_Type (Subp_Type), Must_Skip); -- The prefix can also be a parameterless function that returns an -- access to subprogram. in which case this is an indirect call. @@ -2131,7 +2188,7 @@ package body Sem_Ch4 is -- skip first actual, which may be rewritten later as an -- explicit dereference. - if Skip_First then + if Must_Skip then Next_Actual (Actual); Next_Formal (Formal); end if; @@ -2618,16 +2675,33 @@ package body Sem_Ch4 is Prefix_Type := Designated_Type (Prefix_Type); - -- (Ada 2005): if the prefix is the limited view of a type, and - -- the context already includes the full view, use the full view - -- in what follows, either to retrieve a component of to find - -- a primitive operation. + end if; - if Is_Incomplete_Type (Prefix_Type) - and then From_With_Type (Prefix_Type) - and then Present (Non_Limited_View (Prefix_Type)) - then - Prefix_Type := Non_Limited_View (Prefix_Type); + -- (Ada 2005): if the prefix is the limited view of a type, and + -- the context already includes the full view, use the full view + -- in what follows, either to retrieve a component of to find + -- a primitive operation. If the prefix is an explicit dereference, + -- set the type of the prefix to reflect this transformation. + + if Is_Incomplete_Type (Prefix_Type) + and then From_With_Type (Prefix_Type) + and then Present (Non_Limited_View (Prefix_Type)) + then + Prefix_Type := Non_Limited_View (Prefix_Type); + + if Nkind (N) = N_Explicit_Dereference then + Set_Etype (Prefix (N), Prefix_Type); + end if; + + elsif Ekind (Prefix_Type) = E_Class_Wide_Type + and then From_With_Type (Prefix_Type) + and then Present (Non_Limited_View (Etype (Prefix_Type))) + then + Prefix_Type := + Class_Wide_Type (Non_Limited_View (Etype (Prefix_Type))); + + if Nkind (N) = N_Explicit_Dereference then + Set_Etype (Prefix (N), Prefix_Type); end if; end if; @@ -2804,6 +2878,13 @@ package body Sem_Ch4 is return; end if; + -- If the prefix is a private extension, check only the visible + -- components of the partial view. + + if Ekind (Prefix_Type) = E_Record_Type_With_Private then + exit when Comp = Last_Entity (Prefix_Type); + end if; + Next_Entity (Comp); end loop; @@ -2822,7 +2903,6 @@ package body Sem_Ch4 is end if; elsif Is_Private_Type (Prefix_Type) then - -- Allow access only to discriminants of the type. If the type has -- no full view, gigi uses the parent type for the components, so we -- do the same here. @@ -2848,6 +2928,15 @@ package body Sem_Ch4 is Set_Original_Discriminant (Sel, Comp); end if; + -- Before declararing an error, check whether this is tagged + -- private type and a call to a primitive operation. + + elsif Ada_Version >= Ada_05 + and then Is_Tagged_Type (Prefix_Type) + and then Try_Object_Operation (N) + then + return; + else Error_Msg_NE ("invisible selector for }", @@ -2915,6 +3004,18 @@ package body Sem_Ch4 is Comp = First_Private_Entity (Base_Type (Prefix_Type)); end loop; + -- If there is no visible entry with the given name, and the task + -- 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 + and then Is_Tagged_Type (Prefix_Type) + and then Try_Object_Operation (N) + then + return; + end if; + Set_Is_Overloaded (N, Is_Overloaded (Sel)); else @@ -4528,7 +4629,7 @@ package body Sem_Ch4 is Error_Msg_N ("two access attributes cannot be compared directly", N); Error_Msg_N - ("\they must be converted to an explicit type for comparison", + ("\use qualified expression for one of the operands", N); return; @@ -4589,7 +4690,7 @@ package body Sem_Ch4 is then if not Is_Immediately_Visible (Op_Id) and then not In_Use (Scope (Op_Id)) - and then not Is_Abstract (Op_Id) + and then not Is_Abstract_Subprogram (Op_Id) and then not Is_Hidden (Op_Id) and then Ekind (Scope (Op_Id)) = E_Package and then @@ -4712,8 +4813,8 @@ package body Sem_Ch4 is Get_First_Interp (N, I, It); while Present (It.Nam) loop - if not Is_Type (It.Nam) - and then Is_Abstract (It.Nam) + if Is_Overloadable (It.Nam) + and then Is_Abstract_Subprogram (It.Nam) and then not Is_Dispatching_Operation (It.Nam) then Abstract_Op := It.Nam; @@ -4932,9 +5033,10 @@ package body Sem_Ch4 is ---------------------- function Try_Indexed_Call - (N : Node_Id; - Nam : Entity_Id; - Typ : Entity_Id) return Boolean + (N : Node_Id; + Nam : Entity_Id; + Typ : Entity_Id; + Skip_First : Boolean) return Boolean is Actuals : constant List_Id := Parameter_Associations (N); Actual : Node_Id; @@ -4942,6 +5044,14 @@ package body Sem_Ch4 is begin Actual := First (Actuals); + + -- If the call was originally written in prefix form, skip the first + -- actual, which is obviously not defaulted. + + if Skip_First then + Next (Actual); + end if; + Index := First_Index (Typ); while Present (Actual) and then Present (Index) loop @@ -5085,6 +5195,10 @@ package body Sem_Ch4 is Rewrite (First_Actual, Obj); end if; + if Is_Overloaded (Call_Node) then + Save_Interps (Call_Node, Node_To_Replace); + end if; + Rewrite (Node_To_Replace, Call_Node); Analyze (Node_To_Replace); end Complete_Object_Operation; @@ -5290,9 +5404,10 @@ package body Sem_Ch4 is Typ : constant Entity_Id := Etype (First_Formal (Op)); begin - -- Simple case + -- Simple case. Object may be a subtype of the tagged type. - return Base_Type (Obj_Type) = Typ + return Obj_Type = Typ + or else Base_Type (Obj_Type) = Typ -- Prefix can be dereferenced @@ -5314,8 +5429,17 @@ package body Sem_Ch4 is -- 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))); + else + Elmt := First_Elmt (Primitive_Operations (Obj_Type)); + end if; - Elmt := First_Elmt (Primitive_Operations (Obj_Type)); while Present (Elmt) loop Prim_Op := Node (Elmt); @@ -5355,24 +5479,16 @@ package body Sem_Ch4 is Success => Success, Skip_First => True); - if Success then + if Success + or else Needs_One_Actual (Prim_Op) + then Op_Exists := True; - - -- If the operation is a procedure call, there can only - -- be one candidate and we found it. If it is a function - -- we must collect all interpretations, because there - -- may be several primitive operations that differ only - -- in the return type. - - if Nkind (Call_Node) = N_Procedure_Call_Statement then - exit; - end if; end if; - elsif Ekind (Prim_Op) = E_Function then + else - -- Collect remaining function interpretations, to be - -- resolved from context. + -- More than one interpretation, collect for subsequent + -- disambiguation. Add_One_Interp (Prim_Op_Ref, Prim_Op, Etype (Prim_Op)); end if; |