diff options
Diffstat (limited to 'gcc/ada/sem_res.adb')
| -rw-r--r-- | gcc/ada/sem_res.adb | 581 |
1 files changed, 397 insertions, 184 deletions
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index cc55d26d2d5..fdba2bdec03 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,6 +31,7 @@ with Debug_A; use Debug_A; with Einfo; use Einfo; with Errout; use Errout; with Expander; use Expander; +with Exp_Disp; use Exp_Disp; with Exp_Ch7; use Exp_Ch7; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; @@ -357,7 +358,9 @@ package body Sem_Res is procedure Check_Direct_Boolean_Op (N : Node_Id) is begin - if Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean then + if Nkind (N) in N_Op + and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean + then Check_Restriction (No_Direct_Boolean_Operators, N); end if; end Check_Direct_Boolean_Op; @@ -538,6 +541,12 @@ package body Sem_Res is if Paren_Count (N) > 0 then Error_Msg_N ("discriminant in constraint must appear alone", N); + + elsif Nkind (N) = N_Expanded_Name + and then Comes_From_Source (N) + then + Error_Msg_N + ("discriminant must appear alone as a direct name", N); end if; return; @@ -2120,7 +2129,7 @@ package body Sem_Res is if Typ = Any_Real and then Expr_Type = Any_Fixed then - Error_Msg_N ("Illegal context for mixed mode operation", N); + Error_Msg_N ("illegal context for mixed mode operation", N); Set_Etype (N, Universal_Real); Ctx_Type := Universal_Real; end if; @@ -2590,9 +2599,23 @@ package body Sem_Res is if Has_Aliased_Components (Etype (Expression (A))) /= Has_Aliased_Components (Etype (F)) then - Error_Msg_N - ("both component types in a view conversion must be" - & " aliased, or neither", A); + if Ada_Version < Ada_05 then + Error_Msg_N + ("both component types in a view conversion must be" + & " aliased, or neither", A); + + -- Ada 2005: rule is relaxed (see AI-363) + + elsif Has_Aliased_Components (Etype (F)) + and then + not Has_Aliased_Components (Etype (Expression (A))) + then + Error_Msg_N + ("view conversion operand must have aliased " & + "components", N); + Error_Msg_N + ("\since target type has aliased components", N); + end if; elsif not Same_Ancestor (Etype (F), Etype (Expression (A))) and then @@ -2600,8 +2623,8 @@ package body Sem_Res is or else Is_By_Reference_Type (Etype (Expression (A)))) then Error_Msg_N - ("view conversion between unrelated by_reference " - & "array types not allowed (\A\I-00246)?", A); + ("view conversion between unrelated by reference " & + "array types not allowed (\'A'I-00246)", A); end if; end if; @@ -2620,19 +2643,16 @@ package body Sem_Res is or else Is_Limited_Type (Etype (Expression (A)))) then Error_Msg_N - ("Conversion between unrelated limited array types " - & "not allowed (\A\I-00246)?", A); - - -- Disable explanation (which produces additional errors) - -- until AI is approved and warning becomes an error. + ("conversion between unrelated limited array types " & + "not allowed (\A\I-00246)", A); - -- if Is_Limited_Type (Etype (F)) then - -- Explain_Limited_Type (Etype (F), A); - -- end if; + if Is_Limited_Type (Etype (F)) then + Explain_Limited_Type (Etype (F), A); + end if; - -- if Is_Limited_Type (Etype (Expression (A))) then - -- Explain_Limited_Type (Etype (Expression (A)), A); - -- end if; + if Is_Limited_Type (Etype (Expression (A))) then + Explain_Limited_Type (Etype (Expression (A)), A); + end if; end if; Resolve (A, Etype (F)); @@ -2668,9 +2688,9 @@ package body Sem_Res is Check_Unset_Reference (A); end if; - -- In Ada 83 we cannot pass an OUT parameter as an IN - -- or IN OUT actual to a nested call, since this is a - -- case of reading an out parameter, which is not allowed. + -- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT + -- actual to a nested call, since this is case of reading an + -- out parameter, which is not allowed. if Ada_Version = Ada_83 and then Is_Entity_Name (A) @@ -3035,6 +3055,46 @@ package body Sem_Res is end if; end if; + -- Ada 2005 (AI-344): A class-wide allocator requires an accessibility + -- check that the level of the type of the created object is not deeper + -- than the level of the allocator's access type, since extensions can + -- now occur at deeper levels than their ancestor types. This is a + -- static accessibility level check; a run-time check is also needed in + -- the case of an initialized allocator with a class-wide argument (see + -- Expand_Allocator_Expression). + + if Ada_Version >= Ada_05 + and then Is_Class_Wide_Type (Designated_Type (Typ)) + then + declare + Exp_Typ : Entity_Id; + + begin + if Nkind (E) = N_Qualified_Expression then + Exp_Typ := Etype (E); + elsif Nkind (E) = N_Subtype_Indication then + Exp_Typ := Entity (Subtype_Mark (Original_Node (E))); + else + Exp_Typ := Entity (E); + end if; + + if Type_Access_Level (Exp_Typ) > Type_Access_Level (Typ) then + if In_Instance_Body then + Error_Msg_N ("?type in allocator has deeper level than" & + " designated class-wide type", E); + Error_Msg_N ("?Program_Error will be raised at run time", E); + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Typ); + else + Error_Msg_N ("type in allocator has deeper level than" & + " designated class-wide type", E); + end if; + end if; + end; + end if; + -- Check for allocation from an empty storage pool if No_Pool_Assigned (Typ) then @@ -3126,8 +3186,8 @@ package body Sem_Res is if Universal_Interpretation (N) = Universal_Integer then -- A universal integer literal is resolved as standard integer - -- except in the case of a fixed-point result, where we leave - -- it as universal (to be handled by Exp_Fixd later on) + -- except in the case of a fixed-point result, where we leave it + -- as universal (to be handled by Exp_Fixd later on) if Is_Fixed_Point_Type (T) then Resolve (N, Universal_Integer); @@ -3209,11 +3269,11 @@ package body Sem_Res is Get_Next_Interp (Index, It); end loop; - -- Reanalyze the literal with the fixed type of the context. - -- If context is Universal_Fixed, we are within a conversion, - -- leave the literal as a universal real because there is no - -- usable fixed type, and the target of the conversion plays - -- no role in the resolution. + -- Reanalyze the literal with the fixed type of the context. If + -- context is Universal_Fixed, we are within a conversion, leave + -- the literal as a universal real because there is no usable + -- fixed type, and the target of the conversion plays no role in + -- the resolution. declare Op2 : Node_Id; @@ -3466,11 +3526,11 @@ package body Sem_Res is W : Node_Id; begin - -- The context imposes a unique interpretation with type Typ on - -- a procedure or function call. Find the entity of the subprogram - -- that yields the expected type, and propagate the corresponding - -- formal constraints on the actuals. The caller has established - -- that an interpretation exists, and emitted an error if not unique. + -- The context imposes a unique interpretation with type Typ on a + -- procedure or function call. Find the entity of the subprogram that + -- yields the expected type, and propagate the corresponding formal + -- constraints on the actuals. The caller has established that an + -- interpretation exists, and emitted an error if not unique. -- First deal with the case of a call to an access-to-subprogram, -- dereference made explicit in Analyze_Call. @@ -3480,9 +3540,9 @@ package body Sem_Res is Nam := Etype (Subp); else - -- Find the interpretation whose type (a subprogram type) - -- has a return type that is compatible with the context. - -- Analysis of the node has established that one exists. + -- Find the interpretation whose type (a subprogram type) has a + -- return type that is compatible with the context. Analysis of + -- the node has established that one exists. Get_First_Interp (Subp, I, It); Nam := Empty; @@ -3507,18 +3567,18 @@ package body Sem_Res is Resolve (Subp, Nam); end if; - -- For an indirect call, we always invalidate checks, since we - -- do not know whether the subprogram is local or global. Yes - -- we could do better here, e.g. by knowing that there are no - -- local subprograms, but it does not seem worth the effort. - -- Similarly, we kill al knowledge of current constant values. + -- For an indirect call, we always invalidate checks, since we do not + -- know whether the subprogram is local or global. Yes we could do + -- better here, e.g. by knowing that there are no local subprograms, + -- but it does not seem worth the effort. Similarly, we kill al + -- knowledge of current constant values. Kill_Current_Values; - -- If this is a procedure call which is really an entry call, do - -- the conversion of the procedure call to an entry call. Protected - -- operations use the same circuitry because the name in the call - -- can be an arbitrary expression with special resolution rules. + -- If this is a procedure call which is really an entry call, do the + -- conversion of the procedure call to an entry call. Protected + -- operations use the same circuitry because the name in the call can be + -- an arbitrary expression with special resolution rules. elsif Nkind (Subp) = N_Selected_Component or else Nkind (Subp) = N_Indexed_Component @@ -3589,12 +3649,12 @@ package body Sem_Res is Error_Msg_N ("cannot call thread body directly", N); end if; - -- If the subprogram is not global, then kill all checks. This is - -- a bit conservative, since in many cases we could do better, but - -- it is not worth the effort. Similarly, we kill constant values. - -- However we do not need to do this for internal entities (unless - -- they are inherited user-defined subprograms), since they are not - -- in the business of molesting global values. + -- If the subprogram is not global, then kill all checks. This is a bit + -- conservative, since in many cases we could do better, but it is not + -- worth the effort. Similarly, we kill constant values. However we do + -- not need to do this for internal entities (unless they are inherited + -- user-defined subprograms), since they are not in the business of + -- molesting global values. if not Is_Library_Level_Entity (Nam) and then (Comes_From_Source (Nam) @@ -3604,43 +3664,47 @@ package body Sem_Res is Kill_Current_Values; end if; - -- Check for call to obsolescent subprogram + -- Deal with call to obsolescent subprogram. Note that we always allow + -- such calls in the compiler itself and the run-time, since we assume + -- that we know what we are doing in such cases. For example, the calls + -- in Ada.Characters.Handling to its own obsolescent subprograms are + -- just fine. - if Warn_On_Obsolescent_Feature - and then Is_Subprogram (Nam) - and then Is_Obsolescent (Nam) - then - Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam); + if Is_Obsolescent (Nam) and then not GNAT_Mode then + Check_Restriction (No_Obsolescent_Features, N); - -- Output additional warning if present + if Warn_On_Obsolescent_Feature then + Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam); - W := Obsolescent_Warning (Nam); + -- Output additional warning if present - if Present (W) then - Name_Buffer (1) := '|'; - Name_Buffer (2) := '?'; - Name_Len := 2; + W := Obsolescent_Warning (Nam); - -- Add characters to message, protecting all of them + if Present (W) then + Name_Buffer (1) := '|'; + Name_Buffer (2) := '?'; + Name_Len := 2; - for J in 1 .. String_Length (Strval (W)) loop - Add_Char_To_Name_Buffer ('''); - Add_Char_To_Name_Buffer - (Get_Character (Get_String_Char (Strval (W), J))); - end loop; + -- Add characters to message, and output message + + for J in 1 .. String_Length (Strval (W)) loop + Add_Char_To_Name_Buffer ('''); + Add_Char_To_Name_Buffer + (Get_Character (Get_String_Char (Strval (W), J))); + end loop; - Error_Msg_N (Name_Buffer (1 .. Name_Len), N); + Error_Msg_N (Name_Buffer (1 .. Name_Len), N); + end if; end if; end if; - -- Check that a procedure call does not occur in the context - -- of the entry call statement of a conditional or timed - -- entry call. Note that the case of a call to a subprogram - -- renaming of an entry will also be rejected. The test - -- for N not being an N_Entry_Call_Statement is defensive, - -- covering the possibility that the processing of entry - -- calls might reach this point due to later modifications - -- of the code above. + -- Check that a procedure call does not occur in the context of the + -- entry call statement of a conditional or timed entry call. Note that + -- the case of a call to a subprogram renaming of an entry will also be + -- rejected. The test for N not being an N_Entry_Call_Statement is + -- defensive, covering the possibility that the processing of entry + -- calls might reach this point due to later modifications of the code + -- above. if Nkind (Parent (N)) = N_Entry_Call_Alternative and then Nkind (N) /= N_Entry_Call_Statement @@ -3662,34 +3726,33 @@ package body Sem_Res is Error_Msg_N ("\cannot call operation that may modify it", N); end if; - -- Freeze the subprogram name if not in default expression. Note - -- that we freeze procedure calls as well as function calls. - -- Procedure calls are not frozen according to the rules (RM - -- 13.14(14)) because it is impossible to have a procedure call to - -- a non-frozen procedure in pure Ada, but in the code that we - -- generate in the expander, this rule needs extending because we - -- can generate procedure calls that need freezing. + -- Freeze the subprogram name if not in default expression. Note that we + -- freeze procedure calls as well as function calls. Procedure calls are + -- not frozen according to the rules (RM 13.14(14)) because it is + -- impossible to have a procedure call to a non-frozen procedure in pure + -- Ada, but in the code that we generate in the expander, this rule + -- needs extending because we can generate procedure calls that need + -- freezing. if Is_Entity_Name (Subp) and then not In_Default_Expression then Freeze_Expression (Subp); end if; - -- For a predefined operator, the type of the result is the type - -- imposed by context, except for a predefined operation on universal - -- fixed. Otherwise The type of the call is the type returned by the - -- subprogram being called. + -- For a predefined operator, the type of the result is the type imposed + -- by context, except for a predefined operation on universal fixed. + -- Otherwise The type of the call is the type returned by the subprogram + -- being called. if Is_Predefined_Op (Nam) then if Etype (N) /= Universal_Fixed then Set_Etype (N, Typ); end if; - -- If the subprogram returns an array type, and the context - -- requires the component type of that array type, the node is - -- really an indexing of the parameterless call. Resolve as such. - -- A pathological case occurs when the type of the component is - -- an access to the array type. In this case the call is truly - -- ambiguous. + -- If the subprogram returns an array type, and the context requires the + -- component type of that array type, the node is really an indexing of + -- the parameterless call. Resolve as such. A pathological case occurs + -- when the type of the component is an access to the array type. In + -- this case the call is truly ambiguous. elsif Needs_No_Actuals (Nam) and then @@ -3760,10 +3823,10 @@ package body Sem_Res is Set_Is_Overloaded (Subp, False); Set_Is_Overloaded (N, False); - -- If we are calling the current subprogram from immediately within - -- its body, then that is the case where we can sometimes detect - -- cases of infinite recursion statically. Do not try this in case - -- restriction No_Recursion is in effect anyway. + -- If we are calling the current subprogram from immediately within its + -- body, then that is the case where we can sometimes detect cases of + -- infinite recursion statically. Do not try this in case restriction + -- No_Recursion is in effect anyway. Scop := Current_Scope; @@ -4018,8 +4081,6 @@ package body Sem_Res is T : Entity_Id; begin - Check_Direct_Boolean_Op (N); - -- If this is an intrinsic operation which is not predefined, use -- the types of its declared arguments to resolve the possibly -- overloaded operands. Otherwise the operands are unambiguous and @@ -4059,6 +4120,7 @@ package body Sem_Res is Check_Unset_Reference (R); Generate_Operator_Reference (N, T); Eval_Relational_Op (N); + Check_Direct_Boolean_Op (N); end if; end if; end Resolve_Comparison_Op; @@ -4213,7 +4275,7 @@ package body Sem_Res is null; else Error_Msg_N - ("Invalid use of subtype mark in expression or call", N); + ("invalid use of subtype mark in expression or call", N); end if; -- Check discriminant use if entity is discriminant in current scope, @@ -4636,7 +4698,7 @@ package body Sem_Res is elsif Ekind (Scope (Nam)) = E_Task_Type and then not In_Open_Scopes (Scope (Nam)) then - Error_Msg_N ("Task has no entry with this name", Entry_Name); + Error_Msg_N ("task has no entry with this name", Entry_Name); end if; end if; @@ -4752,8 +4814,6 @@ package body Sem_Res is -- Start of processing for Resolve_Equality_Op begin - Check_Direct_Boolean_Op (N); - Set_Etype (N, Base_Type (Typ)); Generate_Reference (T, N, ' '); @@ -4822,6 +4882,8 @@ package body Sem_Res is then Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); end if; + + Check_Direct_Boolean_Op (N); end if; end Resolve_Equality_Op; @@ -4837,20 +4899,35 @@ package body Sem_Res is It : Interp; begin - -- Now that we know the type, check that this is not a - -- dereference of an uncompleted type. Note that this - -- is not entirely correct, because dereferences of - -- private types are legal in default expressions. - -- This consideration also applies to similar checks - -- for allocators, qualified expressions, and type - -- conversions. ??? - - Check_Fully_Declared (Typ, N); + -- Now that we know the type, check that this is not dereference of an + -- uncompleted type. Note that this is not entirely correct, because + -- dereferences of private types are legal in default expressions. This + -- exception is taken care of in Check_Fully_Declared. + + -- This consideration also applies to similar checks for allocators, + -- qualified expressions, and type conversions. + + -- An additional exception concerns other per-object expressions that + -- are not directly related to component declarations, in particular + -- representation pragmas for tasks. These will be per-object + -- expressions if they depend on discriminants or some global entity. + -- If the task has access discriminants, the designated type may be + -- incomplete at the point the expression is resolved. This resolution + -- takes place within the body of the initialization procedure, where + -- the discriminant is replaced by its discriminal. + + if Is_Entity_Name (Prefix (N)) + and then Ekind (Entity (Prefix (N))) = E_In_Parameter + then + null; + else + Check_Fully_Declared (Typ, N); + end if; if Is_Overloaded (P) then - -- Use the context type to select the prefix that has the - -- correct designated type. + -- Use the context type to select the prefix that has the correct + -- designated type. Get_First_Interp (P, I, It); while Present (It.Typ) loop @@ -4863,13 +4940,12 @@ package body Sem_Res is if Present (It.Typ) then Resolve (P, It.Typ); else - -- If no interpretation covers the designated type of the - -- prefix, this is the pathological case where not all - -- implementations of the prefix allow the interpretation - -- of the node as a call. Now that the expected type is known, - -- Remove other interpretations from prefix, rewrite it as - -- a call, and resolve again, so that the proper call node - -- is generated. + -- If no interpretation covers the designated type of the prefix, + -- this is the pathological case where not all implementations of + -- the prefix allow the interpretation of the node as a call. Now + -- that the expected type is known, Remove other interpretations + -- from prefix, rewrite it as a call, and resolve again, so that + -- the proper call node is generated. Get_First_Interp (P, I, It); while Present (It.Typ) loop @@ -4903,14 +4979,13 @@ package body Sem_Res is Apply_Access_Check (N); end if; - -- If the designated type is a packed unconstrained array type, - -- and the explicit dereference is not in the context of an - -- attribute reference, then we must compute and set the actual - -- subtype, since it is needed by Gigi. The reason we exclude - -- the attribute case is that this is handled fine by Gigi, and - -- in fact we use such attributes to build the actual subtype. - -- We also exclude generated code (which builds actual subtypes - -- directly if they are needed). + -- If the designated type is a packed unconstrained array type, and the + -- explicit dereference is not in the context of an attribute reference, + -- then we must compute and set the actual subtype, since it is needed + -- by Gigi. The reason we exclude the attribute case is that this is + -- handled fine by Gigi, and in fact we use such attributes to build the + -- actual subtype. We also exclude generated code (which builds actual + -- subtypes directly if they are needed). if Is_Array_Type (Etype (N)) and then Is_Packed (Etype (N)) @@ -4921,9 +4996,9 @@ package body Sem_Res is Set_Etype (N, Get_Actual_Subtype (N)); end if; - -- Note: there is no Eval processing required for an explicit - -- deference, because the type is known to be an allocators, and - -- allocator expressions can never be static. + -- Note: there is no Eval processing required for an explicit deference, + -- because the type is known to be an allocators, and allocator + -- expressions can never be static. end Resolve_Explicit_Dereference; @@ -4940,8 +5015,8 @@ package body Sem_Res is begin if Is_Overloaded (Name) then - -- Use the context type to select the prefix that yields the - -- correct component type. + -- Use the context type to select the prefix that yields the correct + -- component type. declare I : Interp_Index; @@ -4953,6 +5028,9 @@ package body Sem_Res is begin Get_First_Interp (P, I, It); + -- the task has access discriminants, the designated type may be + -- incomplete at the point the expression is resolved. This resolution + -- takes place within the body of the initialization proc while Present (It.Typ) loop if (Is_Array_Type (It.Typ) @@ -5009,10 +5087,10 @@ package body Sem_Res is Index := First_Index (Array_Type); Expr := First (Expressions (N)); - -- The prefix may have resolved to a string literal, in which case - -- its etype has a special representation. This is only possible - -- currently if the prefix is a static concatenation, written in - -- functional notation. + -- The prefix may have resolved to a string literal, in which case its + -- etype has a special representation. This is only possible currently + -- if the prefix is a static concatenation, written in functional + -- notation. if Ekind (Array_Type) = E_String_Literal_Subtype then Resolve (Expr, Standard_Positive); @@ -5067,9 +5145,9 @@ package body Sem_Res is Set_Entity (N, Op); Set_Is_Overloaded (N, False); - -- If the operand type is private, rewrite with suitable - -- conversions on the operands and the result, to expose - -- the proper underlying numeric type. + -- If the operand type is private, rewrite with suitable conversions on + -- the operands and the result, to expose the proper underlying numeric + -- type. if Is_Private_Type (Typ) then Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd (N)); @@ -5167,11 +5245,9 @@ package body Sem_Res is B_Typ : Entity_Id; begin - Check_Direct_Boolean_Op (N); - - -- Predefined operations on scalar types yield the base type. On - -- the other hand, logical operations on arrays yield the type of - -- the arguments (and the context). + -- Predefined operations on scalar types yield the base type. On the + -- other hand, logical operations on arrays yield the type of the + -- arguments (and the context). if Is_Array_Type (Typ) then B_Typ := Typ; @@ -5211,6 +5287,7 @@ package body Sem_Res is Set_Etype (N, B_Typ); Generate_Operator_Reference (N, B_Typ); Eval_Logical_Op (N); + Check_Direct_Boolean_Op (N); end Resolve_Logical_Op; --------------------------- @@ -5269,8 +5346,8 @@ package body Sem_Res is procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is begin - -- Handle restriction against anonymous null access values - -- This restriction can be turned off using -gnatdh. + -- Handle restriction against anonymous null access values This + -- restriction can be turned off using -gnatdh. -- Ada 2005 (AI-231): Remove restriction @@ -5417,9 +5494,9 @@ package body Sem_Res is Explain_Limited_Type (Btyp, N); end if; - -- If the operands are themselves concatenations, resolve them as - -- such directly. This removes several layers of recursion and allows - -- GNAT to handle larger multiple concatenations. + -- If the operands are themselves concatenations, resolve them as such + -- directly. This removes several layers of recursion and allows GNAT to + -- handle larger multiple concatenations. if Nkind (Op1) = N_Op_Concat and then not Is_Array_Type (Component_Type (Typ)) @@ -5468,8 +5545,8 @@ package body Sem_Res is begin -- Catch attempts to do fixed-point exponentation with universal - -- operands, which is a case where the illegality is not caught - -- during normal operator analysis. + -- operands, which is a case where the illegality is not caught during + -- normal operator analysis. if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then Error_Msg_N ("exponentiation not available for fixed point", N); @@ -5560,9 +5637,9 @@ package body Sem_Res is -- Start of processing for Resolve_Op_Not begin - -- Predefined operations on scalar types yield the base type. On - -- the other hand, logical operations on arrays yield the type of - -- the arguments (and the context). + -- Predefined operations on scalar types yield the base type. On the + -- other hand, logical operations on arrays yield the type of the + -- arguments (and the context). if Is_Array_Type (Typ) then B_Typ := Typ; @@ -5669,12 +5746,12 @@ package body Sem_Res is Check_Unset_Reference (H); -- We have to check the bounds for being within the base range as - -- required for a non-static context. Normally this is automatic - -- and done as part of evaluating expressions, but the N_Range - -- node is an exception, since in GNAT we consider this node to - -- be a subexpression, even though in Ada it is not. The circuit - -- in Sem_Eval could check for this, but that would put the test - -- on the main evaluation path for expressions. + -- required for a non-static context. Normally this is automatic and + -- done as part of evaluating expressions, but the N_Range node is an + -- exception, since in GNAT we consider this node to be a subexpression, + -- even though in Ada it is not. The circuit in Sem_Eval could check for + -- this, but that would put the test on the main evaluation path for + -- expressions. Check_Non_Static_Context (L); Check_Non_Static_Context (H); @@ -5756,8 +5833,6 @@ package body Sem_Res is Realval => Small_Value (Typ) * Cint)); Set_Is_Static_Expression (N, Stat); - - end if; -- In all cases, set the corresponding integer field @@ -6389,8 +6464,8 @@ package body Sem_Res is ----------------------------- procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is - Target_Type : constant Entity_Id := Etype (N); - Conv_OK : constant Boolean := Conversion_OK (N); + Conv_OK : constant Boolean := Conversion_OK (N); + Target_Type : Entity_Id := Etype (N); Operand : Node_Id; Opnd_Type : Entity_Id; Rop : Node_Id; @@ -6525,6 +6600,43 @@ package body Sem_Res is ("?useless conversion, & has this type", N, Entity (Orig_N)); end if; end if; + + -- Ada 2005 (AI-251): Handle conversions to abstract interface types + + if Ada_Version >= Ada_05 then + if Is_Access_Type (Target_Type) then + Target_Type := Directly_Designated_Type (Target_Type); + end if; + + if Is_Class_Wide_Type (Target_Type) then + Target_Type := Etype (Target_Type); + end if; + + if Is_Interface (Target_Type) then + if Is_Class_Wide_Type (Opnd_Type) then + Opnd_Type := Etype (Opnd_Type); + end if; + + if not Interface_Present_In_Ancestor + (Typ => Opnd_Type, + Iface => Target_Type) + then + if Nkind (Operand) = N_Attribute_Reference then + Error_Msg_Name_1 := Chars (Prefix (Operand)); + else + Error_Msg_Name_1 := Chars (Operand); + end if; + + Error_Msg_Name_2 := Chars (Target_Type); + Error_Msg_NE + ("(Ada 2005) % does not implement interface %", + Operand, Target_Type); + + else + Expand_Interface_Conversion (N); + end if; + end if; + end if; end Resolve_Type_Conversion; ---------------------- @@ -6998,6 +7110,13 @@ package body Sem_Res is return Conversion_Check (False, "downward conversion of tagged objects not allowed"); + + -- Ada 2005 (AI-251): The conversion of a tagged type to an + -- abstract interface type is always valid + + elsif Is_Interface (Target_Type) then + return True; + else Error_Msg_NE ("invalid tagged conversion, not compatible with}", @@ -7162,6 +7281,94 @@ package body Sem_Res is return True; + -- Ada 2005 (AI-251) + + elsif (Ekind (Target_Type) = E_General_Access_Type + or else Ekind (Target_Type) = E_Anonymous_Access_Type) + and then Is_Interface (Directly_Designated_Type (Target_Type)) + then + -- Check the static accessibility rule of 4.6(17). Note that the + -- check is not enforced when within an instance body, since the RM + -- requires such cases to be caught at run time. + + if Ekind (Target_Type) /= E_Anonymous_Access_Type then + if Type_Access_Level (Opnd_Type) > + Type_Access_Level (Target_Type) + then + -- In an instance, this is a run-time check, but one we know + -- will fail, so generate an appropriate warning. The raise + -- will be generated by Expand_N_Type_Conversion. + + if In_Instance_Body then + Error_Msg_N + ("?cannot convert local pointer to non-local access type", + Operand); + Error_Msg_N + ("?Program_Error will be raised at run time", Operand); + + else + Error_Msg_N + ("cannot convert local pointer to non-local access type", + Operand); + return False; + end if; + + -- Special accessibility checks are needed in the case of access + -- discriminants declared for a limited type. + + elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type + and then not Is_Local_Anonymous_Access (Opnd_Type) + then + -- When the operand is a selected access discriminant the check + -- needs to be made against the level of the object denoted by + -- the prefix of the selected name. (Object_Access_Level + -- handles checking the prefix of the operand for this case.) + + if Nkind (Operand) = N_Selected_Component + and then Object_Access_Level (Operand) + > Type_Access_Level (Target_Type) + then + -- In an instance, this is a run-time check, but one we + -- know will fail, so generate an appropriate warning. + -- The raise will be generated by Expand_N_Type_Conversion. + + if In_Instance_Body then + Error_Msg_N + ("?cannot convert access discriminant to non-local" & + " access type", Operand); + Error_Msg_N + ("?Program_Error will be raised at run time", Operand); + + else + Error_Msg_N + ("cannot convert access discriminant to non-local" & + " access type", Operand); + return False; + end if; + end if; + + -- The case of a reference to an access discriminant from + -- within a limited type declaration (which will appear as + -- a discriminal) is always illegal because the level of the + -- discriminant is considered to be deeper than any (namable) + -- access type. + + if Is_Entity_Name (Operand) + and then not Is_Local_Anonymous_Access (Opnd_Type) + and then (Ekind (Entity (Operand)) = E_In_Parameter + or else Ekind (Entity (Operand)) = E_Constant) + and then Present (Discriminal_Link (Entity (Operand))) + then + Error_Msg_N + ("discriminant has deeper accessibility level than target", + Operand); + return False; + end if; + end if; + end if; + + return True; + elsif (Ekind (Target_Type) = E_General_Access_Type or else Ekind (Target_Type) = E_Anonymous_Access_Type) and then @@ -7181,11 +7388,13 @@ package body Sem_Res is return False; end if; - -- Check the static accessibility rule of 4.6(17). Note that - -- the check is not enforced when within an instance body, since - -- the RM requires such cases to be caught at run time. + -- Check the static accessibility rule of 4.6(17). Note that the + -- check is not enforced when within an instance body, since the RM + -- requires such cases to be caught at run time. - if Ekind (Target_Type) /= E_Anonymous_Access_Type then + if Ekind (Target_Type) /= E_Anonymous_Access_Type + or else Is_Local_Anonymous_Access (Target_Type) + then if Type_Access_Level (Opnd_Type) > Type_Access_Level (Target_Type) then @@ -7207,13 +7416,17 @@ package body Sem_Res is return False; end if; - elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type then + -- Special accessibility checks are needed in the case of access + -- discriminants declared for a limited type. + + elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type + and then not Is_Local_Anonymous_Access (Opnd_Type) + then - -- When the operand is a selected access discriminant - -- the check needs to be made against the level of the - -- object denoted by the prefix of the selected name. - -- (Object_Access_Level handles checking the prefix - -- of the operand for this case.) + -- When the operand is a selected access discriminant the check + -- needs to be made against the level of the object denoted by + -- the prefix of the selected name. (Object_Access_Level + -- handles checking the prefix of the operand for this case.) if Nkind (Operand) = N_Selected_Component and then Object_Access_Level (Operand) @@ -7238,11 +7451,11 @@ package body Sem_Res is end if; end if; - -- The case of a reference to an access discriminant - -- from within a type declaration (which will appear - -- as a discriminal) is always illegal because the - -- level of the discriminant is considered to be - -- deeper than any (namable) access type. + -- The case of a reference to an access discriminant from + -- within a limited type declaration (which will appear as + -- a discriminal) is always illegal because the level of the + -- discriminant is considered to be deeper than any (namable) + -- access type. if Is_Entity_Name (Operand) and then (Ekind (Entity (Operand)) = E_In_Parameter |