diff options
Diffstat (limited to 'gcc/ada/sem_ch4.adb')
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 168 |
1 files changed, 130 insertions, 38 deletions
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 421cd81b5c3..83d71aa8aa2 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -413,8 +413,8 @@ package body Sem_Ch4 is if Comes_From_Source (N) then Check_Restriction (No_Allocators, N); - -- Processing for No_Allocators_After_Elaboration, loop to look at - -- enclosing context, checking task case and main subprogram case. + -- Processing for No_Standard_Allocators_After_Elaboration, loop to + -- look at enclosing context, checking task/main subprogram case. C := N; P := Parent (C); @@ -431,7 +431,8 @@ package body Sem_Ch4 is -- violation of No_Allocators_After_Elaboration we can detect. if Nkind (Original_Node (Parent (P))) = N_Task_Body then - Check_Restriction (No_Allocators_After_Elaboration, N); + Check_Restriction + (No_Standard_Allocators_After_Elaboration, N); exit; end if; @@ -866,6 +867,11 @@ package body Sem_Ch4 is -- Flag indicates whether an interpretation of the prefix is a -- parameterless call that returns an access_to_subprogram. + procedure Check_Ghost_Function_Call; + -- Verify the legality of a call to a ghost function. Such calls can + -- appear only in assertion expressions except subtype predicates or + -- from within another ghost function. + procedure Check_Mixed_Parameter_And_Named_Associations; -- Check that parameter and named associations are not mixed. This is -- a restriction in SPARK mode. @@ -880,6 +886,38 @@ package body Sem_Ch4 is procedure No_Interpretation; -- Output error message when no valid interpretation exists + ------------------------------- + -- Check_Ghost_Function_Call -- + ------------------------------- + + procedure Check_Ghost_Function_Call is + S : Entity_Id; + + begin + -- The ghost function appears inside an assertion expression + + if In_Assertion_Expression (N) then + return; + + else + S := Current_Scope; + while Present (S) and then S /= Standard_Standard loop + + -- The call appears inside another ghost function + + if Is_Ghost_Function (S) then + return; + end if; + + S := Scope (S); + end loop; + end if; + + Error_Msg_N + ("call to ghost function must appear in assertion expression or " + & "another ghost function", N); + end Check_Ghost_Function_Call; + -------------------------------------------------- -- Check_Mixed_Parameter_And_Named_Associations -- -------------------------------------------------- @@ -970,6 +1008,12 @@ package body Sem_Ch4 is Check_Mixed_Parameter_And_Named_Associations; end if; + -- Mark a function that appears inside an assertion expression + + if Nkind (N) = N_Function_Call and then In_Assertion_Expr > 0 then + Set_In_Assertion_Expression (N); + end if; + -- Initialize the type of the result of the call to the error type, -- which will be reset if the type is successfully resolved. @@ -1076,6 +1120,8 @@ package body Sem_Ch4 is Set_Etype (Nam_Ent, Etype (N)); end if; + -- Overloaded call + else -- An overloaded selected component must denote overloaded operations -- of a concurrent type. The interpretations are attached to the @@ -1160,9 +1206,9 @@ package body Sem_Ch4 is Get_Next_Interp (X, It); end loop; - -- If the name is the result of a function call, it can only - -- be a call to a function returning an access to subprogram. - -- Insert explicit dereference. + -- If the name is the result of a function call, it can only be a + -- call to a function returning an access to subprogram. Insert + -- explicit dereference. if Nkind (Nam) = N_Function_Call then Insert_Explicit_Dereference (Nam); @@ -1241,6 +1287,13 @@ package body Sem_Ch4 is End_Interp_List; end if; + + -- A call to a ghost function is allowed only in assertion expressions, + -- excluding subtype predicates, or from within another ghost function. + + if Is_Ghost_Function (Get_Subprogram_Entity (N)) then + Check_Ghost_Function_Call; + end if; end Analyze_Call; ----------------------------- @@ -1248,14 +1301,8 @@ package body Sem_Ch4 is ----------------------------- procedure Analyze_Case_Expression (N : Node_Id) is - Expr : constant Node_Id := Expression (N); - FirstX : constant Node_Id := Expression (First (Alternatives (N))); - Alt : Node_Id; - Exp_Type : Entity_Id; - Exp_Btype : Entity_Id; - - Dont_Care : Boolean; - Others_Present : Boolean; + function Has_Static_Predicate (Subtyp : Entity_Id) return Boolean; + -- Determine whether subtype Subtyp has aspect Static_Predicate procedure Non_Static_Choice_Error (Choice : Node_Id); -- Error routine invoked by the generic instantiation below when @@ -1270,6 +1317,28 @@ package body Sem_Ch4 is Process_Associated_Node => No_OP); use Case_Choices_Processing; + -------------------------- + -- Has_Static_Predicate -- + -------------------------- + + function Has_Static_Predicate (Subtyp : Entity_Id) return Boolean is + Item : Node_Id; + + begin + Item := First_Rep_Item (Subtyp); + while Present (Item) loop + if Nkind (Item) = N_Aspect_Specification + and then Chars (Identifier (Item)) = Name_Static_Predicate + then + return True; + end if; + + Next_Rep_Item (Item); + end loop; + + return False; + end Has_Static_Predicate; + ----------------------------- -- Non_Static_Choice_Error -- ----------------------------- @@ -1280,6 +1349,17 @@ package body Sem_Ch4 is ("choice given in case expression is not static!", Choice); end Non_Static_Choice_Error; + -- Local variables + + Expr : constant Node_Id := Expression (N); + FirstX : constant Node_Id := Expression (First (Alternatives (N))); + Alt : Node_Id; + Exp_Type : Entity_Id; + Exp_Btype : Entity_Id; + + Dont_Care : Boolean; + Others_Present : Boolean; + -- Start of processing for Analyze_Case_Expression begin @@ -1364,9 +1444,22 @@ package body Sem_Ch4 is Exp_Type := Exp_Btype; end if; + -- The case expression alternatives cover the range of a static subtype + -- subject to aspect Static_Predicate. Do not check the choices when the + -- case expression has not been fully analyzed yet because this may lead + -- to bogus errors. + + if Is_Static_Subtype (Exp_Type) + and then Has_Static_Predicate (Exp_Type) + and then In_Spec_Expression + then + null; + -- Call instantiated Analyze_Choices which does the rest of the work - Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present); + else + Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present); + end if; if Exp_Type = Universal_Integer and then not Others_Present then Error_Msg_N @@ -1896,13 +1989,15 @@ package body Sem_Ch4 is begin A := First (Actions (N)); - loop + while Present (A) loop Analyze (A); Next (A); - exit when No (A); end loop; - -- This test needs a comment ??? + -- We currently hijack Expression_With_Actions with a VOID type and + -- a NULL statement in the Expression. This will ultimately be replaced + -- by a proper separate N_Compound_Statement node, at which point the + -- test below can go away??? if Nkind (Expression (N)) = N_Null_Statement then Set_Etype (N, Standard_Void_Type); @@ -4016,13 +4111,11 @@ package body Sem_Ch4 is and then Nkind (Name) /= N_Selected_Component) or else (Nkind (Parent_N) = N_Attribute_Reference - and then (Attribute_Name (Parent_N) = Name_First - or else - Attribute_Name (Parent_N) = Name_Last - or else - Attribute_Name (Parent_N) = Name_Length - or else - Attribute_Name (Parent_N) = Name_Range))) + and then + Nam_In (Attribute_Name (Parent_N), Name_First, + Name_Last, + Name_Length, + Name_Range))) then Set_Etype (N, Etype (Comp)); @@ -4685,9 +4778,9 @@ package body Sem_Ch4 is elsif Nkind (Expr) = N_Attribute_Reference and then - (Attribute_Name (Expr) = Name_Access or else - Attribute_Name (Expr) = Name_Unchecked_Access or else - Attribute_Name (Expr) = Name_Unrestricted_Access) + Nam_In (Attribute_Name (Expr), Name_Access, + Name_Unchecked_Access, + Name_Unrestricted_Access) then Error_Msg_N ("argument of conversion cannot be access", N); Error_Msg_N ("\use qualified expression instead", N); @@ -4942,8 +5035,7 @@ package body Sem_Ch4 is -- Start of processing for Check_Arithmetic_Pair begin - if Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then - + if Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then if Is_Numeric_Type (T1) and then Is_Numeric_Type (T2) and then (Covers (T1 => T1, T2 => T2) @@ -4953,11 +5045,9 @@ package body Sem_Ch4 is Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); end if; - elsif Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide then - + elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) then if Is_Fixed_Point_Type (T1) - and then (Is_Fixed_Point_Type (T2) - or else T2 = Universal_Real) + and then (Is_Fixed_Point_Type (T2) or else T2 = Universal_Real) then -- If Treat_Fixed_As_Integer is set then the Etype is already set -- and no further processing is required (this is the case of an @@ -4995,7 +5085,7 @@ package body Sem_Ch4 is elsif Is_Fixed_Point_Type (T1) and then (Base_Type (T2) = Base_Type (Standard_Integer) - or else T2 = Universal_Integer) + or else T2 = Universal_Integer) then Add_One_Interp (N, Op_Id, T1); @@ -5012,7 +5102,7 @@ package body Sem_Ch4 is elsif Is_Fixed_Point_Type (T2) and then (Base_Type (T1) = Base_Type (Standard_Integer) - or else T1 = Universal_Integer) + or else T1 = Universal_Integer) and then Op_Name = Name_Op_Multiply then Add_One_Interp (N, Op_Id, T2); @@ -6622,11 +6712,13 @@ package body Sem_Ch4 is Func_Name := Empty; if Is_Variable (Prefix) then - Func_Name := Find_Aspect (Etype (Prefix), Aspect_Variable_Indexing); + Func_Name := + Find_Value_Of_Aspect (Etype (Prefix), Aspect_Variable_Indexing); end if; if No (Func_Name) then - Func_Name := Find_Aspect (Etype (Prefix), Aspect_Constant_Indexing); + Func_Name := + Find_Value_Of_Aspect (Etype (Prefix), Aspect_Constant_Indexing); end if; -- If aspect does not exist the expression is illegal. Error is |