diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0302b488863..9368c08b9f2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2016-06-22 Hristian Kirtchev + + * lib-xref-spark_specific.adb, a-cuprqu.ads, sem_ch6.adb: Minor + reformatting. + +2016-06-22 Eric Botcazou + + * sem_util.ads (Address_Value): Declare new function. + * sem_util.adb (Address_Value): New function extracted + unmodified from Apply_Address_Clause_Check, which returns the + underlying value of the expression of an address clause. + * checks.adb (Compile_Time_Bad_Alignment): Delete. + (Apply_Address_Clause_Check): Call Address_Value on + the expression. Do not issue the main warning here and + issue the secondary warning only when the value of the + expression is not known at compile time. + * sem_ch13.adb (Address_Clause_Check_Record): Add A component and + adjust the description. + (Analyze_Attribute_Definition_Clause): In the case + of an address, move up the code creating an entry in the table of + address clauses. Also create an entry for an absolute address. + (Validate_Address_Clauses): Issue the warning for absolute + addresses here too. Tweak condition associated with overlays + for consistency. + 2016-06-22 Ed Schonberg * sem_ch13.adb (Is_Predicate_Static): An inherited predicate diff --git a/gcc/ada/a-cuprqu.ads b/gcc/ada/a-cuprqu.ads index 44735e0bed0..591673e7d60 100644 --- a/gcc/ada/a-cuprqu.ads +++ b/gcc/ada/a-cuprqu.ads @@ -123,10 +123,10 @@ package Ada.Containers.Unbounded_Priority_Queues is overriding function Peak_Use return Count_Type; private - Q_Elems : Set; + Q_Elems : Set; -- Elements of the queue - Max_Length : Count_Type := 0; + Max_Length : Count_Type := 0; -- The current length of the queue is the Length of Q_Elems. This is the -- maximum value of that, so far. Updated by Enqueue. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index cd8d144f1b8..157bd065bd9 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -638,36 +638,12 @@ package body Checks is AC : constant Node_Id := Address_Clause (E); Loc : constant Source_Ptr := Sloc (AC); Typ : constant Entity_Id := Etype (E); - Aexp : constant Node_Id := Expression (AC); Expr : Node_Id; -- Address expression (not necessarily the same as Aexp, for example -- when Aexp is a reference to a constant, in which case Expr gets -- reset to reference the value expression of the constant). - procedure Compile_Time_Bad_Alignment; - -- Post error warnings when alignment is known to be incompatible. Note - -- that we do not go as far as inserting a raise of Program_Error since - -- this is an erroneous case, and it may happen that we are lucky and an - -- underaligned address turns out to be OK after all. - - -------------------------------- - -- Compile_Time_Bad_Alignment -- - -------------------------------- - - procedure Compile_Time_Bad_Alignment is - begin - if Address_Clause_Overlay_Warnings then - Error_Msg_FE - ("?o?specified address for& may be inconsistent with alignment", - Aexp, E); - Error_Msg_FE - ("\?o?program execution may be erroneous (RM 13.3(27))", - Aexp, E); - Set_Address_Warning_Posted (AC); - end if; - end Compile_Time_Bad_Alignment; - -- Start of processing for Apply_Address_Clause_Check begin @@ -690,43 +666,11 @@ package body Checks is -- Obtain expression from address clause - Expr := Expression (AC); + Expr := Address_Value (Expression (AC)); - -- The following loop digs for the real expression to use in the check - - loop - -- For constant, get constant expression - - if Is_Entity_Name (Expr) - and then Ekind (Entity (Expr)) = E_Constant - then - Expr := Constant_Value (Entity (Expr)); - - -- For unchecked conversion, get result to convert - - elsif Nkind (Expr) = N_Unchecked_Type_Conversion then - Expr := Expression (Expr); - - -- For (common case) of To_Address call, get argument - - elsif Nkind (Expr) = N_Function_Call - and then Is_Entity_Name (Name (Expr)) - and then Is_RTE (Entity (Name (Expr)), RE_To_Address) - then - Expr := First (Parameter_Associations (Expr)); - - if Nkind (Expr) = N_Parameter_Association then - Expr := Explicit_Actual_Parameter (Expr); - end if; - - -- We finally have the real expression - - else - exit; - end if; - end loop; - - -- See if we know that Expr has a bad alignment at compile time + -- See if we know that Expr has an acceptable value at compile time. If + -- it hasn't or we don't know, we defer issuing the warning until the + -- end of the compilation to take into account back end annotations. if Compile_Time_Known_Value (Expr) and then (Known_Alignment (E) or else Known_Alignment (Typ)) @@ -742,9 +686,7 @@ package body Checks is AL := Alignment (E); end if; - if Expr_Value (Expr) mod AL /= 0 then - Compile_Time_Bad_Alignment; - else + if Expr_Value (Expr) mod AL = 0 then return; end if; end; @@ -818,12 +760,11 @@ package body Checks is Warning_Msg := No_Error_Msg; Analyze (First (Actions (N)), Suppress => All_Checks); - -- If the address clause generated a warning message (for example, + -- If the above raise action generated a warning message (for example -- from Warn_On_Non_Local_Exception mode with the active restriction -- No_Exception_Propagation). if Warning_Msg /= No_Error_Msg then - -- If the expression has a known at compile time value, then -- once we know the alignment of the type, we can check if the -- exception will be raised or not, and if not, we don't need @@ -832,13 +773,13 @@ package body Checks is if Compile_Time_Known_Value (Expr) then Alignment_Warnings.Append ((E => E, A => Expr_Value (Expr), W => Warning_Msg)); + else + -- Add explanation of the warning generated by the check + + Error_Msg_N + ("\address value may be incompatible with alignment " + & "of object?X?", AC); end if; - - -- Add explanation of the warning that is generated by the check - - Error_Msg_N - ("\address value may be incompatible with alignment " - & "of object?X?", AC); end if; return; diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index ce4ded82d50..fca2eea1f6c 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -932,34 +932,34 @@ package body SPARK_Specific is declare Cunit1 : Node_Id renames Cunit (Sdep_Table (D1)); Cunit2 : Node_Id renames Cunit (Sdep_Table (D1 + 1)); + begin -- Both Cunit point to compilation unit nodes - pragma Assert (Nkind (Cunit1) = N_Compilation_Unit - and then - Nkind (Cunit2) = N_Compilation_Unit); + + pragma Assert + (Nkind (Cunit1) = N_Compilation_Unit + and then Nkind (Cunit2) = N_Compilation_Unit); -- Do not depend on the sorting order, which is based on -- Unit_Name and for library-level instances of nested -- generic-packages they are equal. -- If declaration comes before the body then just set D2 + if Nkind (Unit (Cunit1)) = N_Package_Declaration - and then - Nkind (Unit (Cunit2)) = N_Package_Body + and then Nkind (Unit (Cunit2)) = N_Package_Body then D2 := D1 + 1; -- If body comes before declaration then set D2 and adjust D1 elsif Nkind (Unit (Cunit1)) = N_Package_Body - and then - Nkind (Unit (Cunit2)) = N_Package_Declaration + and then Nkind (Unit (Cunit2)) = N_Package_Declaration then D2 := D1; D1 := D1 + 1; else - raise Program_Error; end if; end; @@ -978,6 +978,8 @@ package body SPARK_Specific is Dspec => D2); end if; + -- ??? this needs a comment + D1 := Pos'Max (D1, D2) + 1; end loop; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 599ce451c1e..3c1c1b69e1a 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -273,9 +273,10 @@ package body Sem_Ch13 is -- for X'Address use Expr - -- where Expr is of the form Y'Address or recursively is a reference to a - -- constant of either of these forms, and X and Y are entities of objects, - -- then if Y has a smaller alignment than X, that merits a warning about + -- where Expr has a value known at compile time or is of the form Y'Address + -- or recursively is a reference to a constant initialized with either of + -- these forms, and the value of Expr is not a multiple of X's alignment, + -- or if Y has a smaller alignment than X, then that merits a warning about -- possible bad alignment. The following table collects address clauses of -- this kind. We put these in a table so that they can be checked after the -- back end has completed annotation of the alignments of objects, since we @@ -286,13 +287,16 @@ package body Sem_Ch13 is -- The address clause X : Entity_Id; - -- The entity of the object overlaying Y + -- The entity of the object subject to the address clause + + A : Uint; + -- The value of the address in the first case Y : Entity_Id; - -- The entity of the object being overlaid + -- The entity of the object being overlaid in the second case Off : Boolean; - -- Whether the address is offset within Y + -- Whether the address is offset within Y in the second case end record; package Address_Clause_Checks is new Table.Table ( @@ -4849,6 +4853,40 @@ package body Sem_Ch13 is Set_Overlays_Constant (U_Ent); end if; + -- If the address clause is of the form: + + -- for X'Address use Y'Address; + + -- or + + -- C : constant Address := Y'Address; + -- ... + -- for X'Address use C; + + -- then we make an entry in the table to check the size + -- and alignment of the overlaying variable. But we defer + -- this check till after code generation to take full + -- advantage of the annotation done by the back end. + + -- If the entity has a generic type, the check will be + -- performed in the instance if the actual type justifies + -- it, and we do not insert the clause in the table to + -- prevent spurious warnings. + + -- Note: we used to test Comes_From_Source and only give + -- this warning for source entities, but we have removed + -- this test. It really seems bogus to generate overlays + -- that would trigger this warning in generated code. + -- Furthermore, by removing the test, we handle the + -- aspect case properly. + + if Is_Object (O_Ent) + and then not Is_Generic_Type (Etype (U_Ent)) + and then Address_Clause_Overlay_Warnings + then + Address_Clause_Checks.Append + ((N, U_Ent, No_Uint, O_Ent, Off)); + end if; else -- If this is not an overlay, mark a variable as being -- volatile to prevent unwanted optimizations. It's a @@ -4861,6 +4899,21 @@ package body Sem_Ch13 is if Ekind (U_Ent) = E_Variable then Set_Treat_As_Volatile (U_Ent); end if; + + -- Make an entry in the table for an absolute address as + -- above to check that the value is compatible with the + -- alignment of the object. + + declare + Addr : constant Node_Id := Address_Value (Expr); + begin + if Compile_Time_Known_Value (Addr) + and then Address_Clause_Overlay_Warnings + then + Address_Clause_Checks.Append + ((N, U_Ent, Expr_Value (Addr), Empty, False)); + end if; + end; end if; -- Overlaying controlled objects is erroneous. Emit warning @@ -4950,41 +5003,6 @@ package body Sem_Ch13 is -- the variable, it is somewhere else. Kill_Size_Check_Code (U_Ent); - - -- If the address clause is of the form: - - -- for Y'Address use X'Address - - -- or - - -- Const : constant Address := X'Address; - -- ... - -- for Y'Address use Const; - - -- then we make an entry in the table for checking the size - -- and alignment of the overlaying variable. We defer this - -- check till after code generation to take full advantage - -- of the annotation done by the back end. - - -- If the entity has a generic type, the check will be - -- performed in the instance if the actual type justifies - -- it, and we do not insert the clause in the table to - -- prevent spurious warnings. - - -- Note: we used to test Comes_From_Source and only give - -- this warning for source entities, but we have removed - -- this test. It really seems bogus to generate overlays - -- that would trigger this warning in generated code. - -- Furthermore, by removing the test, we handle the - -- aspect case properly. - - if Present (O_Ent) - and then Is_Object (O_Ent) - and then not Is_Generic_Type (Etype (U_Ent)) - and then Address_Clause_Overlay_Warnings - then - Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off)); - end if; end; -- Not a valid entity for an address clause @@ -13183,15 +13201,15 @@ package body Sem_Ch13 is if not Address_Warning_Posted (ACCR.N) then Expr := Original_Node (Expression (ACCR.N)); - -- Get alignments + -- Get alignments, sizes and offset, if any X_Alignment := Alignment (ACCR.X); - Y_Alignment := Alignment (ACCR.Y); - - -- Similarly obtain sizes and offset - X_Size := Esize (ACCR.X); - Y_Size := Esize (ACCR.Y); + + if Present (ACCR.Y) then + Y_Alignment := Alignment (ACCR.Y); + Y_Size := Esize (ACCR.Y); + end if; if ACCR.Off and then Nkind (Expr) = N_Attribute_Reference @@ -13202,9 +13220,27 @@ package body Sem_Ch13 is X_Offs := Uint_0; end if; + -- Check for known value not multiple of alignment + + if No (ACCR.Y) then + if not Alignment_Checks_Suppressed (ACCR.X) + and then X_Alignment /= 0 + and then ACCR.A mod X_Alignment /= 0 + then + Error_Msg_NE + ("??specified address for& is inconsistent with " + & "alignment", ACCR.N, ACCR.X); + Error_Msg_N + ("\??program execution may be erroneous (RM 13.3(27))", + ACCR.N); + + Error_Msg_Uint_1 := X_Alignment; + Error_Msg_NE ("\??alignment of & is ^", ACCR.N, ACCR.X); + end if; + -- Check for large object overlaying smaller one - if Y_Size > Uint_0 + elsif Y_Size > Uint_0 and then X_Size > Uint_0 and then X_Offs + X_Size > Y_Size then @@ -13232,7 +13268,7 @@ package body Sem_Ch13 is -- Note: we do not check the alignment if we gave a size -- warning, since it would likely be redundant. - elsif not Alignment_Checks_Suppressed (ACCR.Y) + elsif not Alignment_Checks_Suppressed (ACCR.X) and then Y_Alignment /= Uint_0 and then (Y_Alignment < X_Alignment diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 0a60d048d4c..81b0ca787e4 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -10808,8 +10808,8 @@ package body Sem_Ch6 is and then not Is_Class_Wide_Type (Formal_Type) then if not Nkind_In - (Parent (T), N_Access_Function_Definition, - N_Access_Procedure_Definition) + (Parent (T), N_Access_Function_Definition, + N_Access_Procedure_Definition) then Append_Elmt (Current_Scope, Private_Dependents (Base_Type (Formal_Type))); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index de0f987d4a3..8ff3535c2b0 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -286,6 +286,49 @@ package body Sem_Util is end if; end Address_Integer_Convert_OK; + ------------------- + -- Address_Value -- + ------------------- + + function Address_Value (N : Node_Id) return Node_Id is + Expr : Node_Id := N; + + begin + loop + -- For constant, get constant expression + + if Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Constant + then + Expr := Constant_Value (Entity (Expr)); + + -- For unchecked conversion, get result to convert + + elsif Nkind (Expr) = N_Unchecked_Type_Conversion then + Expr := Expression (Expr); + + -- For (common case) of To_Address call, get argument + + elsif Nkind (Expr) = N_Function_Call + and then Is_Entity_Name (Name (Expr)) + and then Is_RTE (Entity (Name (Expr)), RE_To_Address) + then + Expr := First (Parameter_Associations (Expr)); + + if Nkind (Expr) = N_Parameter_Association then + Expr := Explicit_Actual_Parameter (Expr); + end if; + + -- We finally have the real expression + + else + exit; + end if; + end loop; + + return Expr; + end Address_Value; + ----------------- -- Addressable -- ----------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index d0bb92d9b48..711c321e132 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -65,6 +65,9 @@ package Sem_Util is -- and one of the types is (a descendant of) System.Address (and this type -- is private), and the other type is any integer type. + function Address_Value (N : Node_Id) return Node_Id; + -- Return the underlying value of the expression N of an address clause + function Addressable (V : Uint) return Boolean; function Addressable (V : Int) return Boolean; pragma Inline (Addressable);