From 07733aa11e136aa6e1fa24e12e662489a9225bf2 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Thu, 11 Jan 2018 08:52:51 +0000 Subject: [PATCH] [Ada] Warning on use of predefined operations on an actual fixed-point type The compiler warns when a generic actual is a fixed-point type, because arithmetic operations in the instance will use the predefined operations on it, even if the type has user-defined primitive operations (unless formsl surprograms for these operations appear in the generic). This patch refines this warning to exclude the case where the formsal type is private, because in this case there can be no suspicious arithmetic operastions in the generic unit. 2018-01-11 Ed Schonberg gcc/ada/ * sem_ch12.adb (Check_Fixed_Point_Type): Do not apply check if the formsl type corresponding to the actual fixed point type is private, because in this case there can be no suspicious arithmetic operations in the generic unless they reference a formal subprogram. Clarify warning. gcc/testsuite/ * gnat.dg/fixedpnt2.adb, gnat.dg/fixedpnt2.ads: New testcase. From-SVN: r256504 --- gcc/ada/ChangeLog | 8 ++++++++ gcc/ada/sem_ch12.adb | 14 ++++++++++++-- gcc/testsuite/ChangeLog | 4 ++++ gcc/testsuite/gnat.dg/fixedpnt2.adb | 25 +++++++++++++++++++++++++ gcc/testsuite/gnat.dg/fixedpnt2.ads | 23 +++++++++++++++++++++++ 5 files changed, 72 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/fixedpnt2.adb create mode 100644 gcc/testsuite/gnat.dg/fixedpnt2.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 01239868b12..ec9eeaa1ad6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,11 @@ +2018-01-11 Ed Schonberg + + * sem_ch12.adb (Check_Fixed_Point_Type): Do not apply check if the + formsl type corresponding to the actual fixed point type is private, + because in this case there can be no suspicious arithmetic operations + in the generic unless they reference a formal subprogram. Clarify + warning. + 2018-01-11 Javier Miranda * exp_util.adb (Remove_Side_Effects): No action done for functions diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 0cfb4119104..b2f4db10260 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1279,7 +1279,8 @@ package body Sem_Ch12 is if No (Formal) then Error_Msg_Sloc := Sloc (Node (Elem)); Error_Msg_NE - ("?instance does not use primitive operation&#", + ("?instance uses predefined operation, " + & "not primitive operation&#", Actual, Node (Elem)); end if; end if; @@ -1717,7 +1718,16 @@ package body Sem_Ch12 is (Formal, Match, Analyzed_Formal, Assoc_List), Assoc_List); - if Is_Fixed_Point_Type (Entity (Match)) then + -- Warn when an actual is a fixed-point with user- + -- defined promitives. The warning is superfluous + -- if the fornal is private, because there can be + -- no arithmetic operations in the generic so there + -- no danger of confusion. + + if Is_Fixed_Point_Type (Entity (Match)) + and then not Is_Private_Type + (Defining_Identifier (Analyzed_Formal)) + then Check_Fixed_Point_Actual (Match); end if; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1792495e035..66e77cc4e2b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-01-11 Ed Schonberg + + * gnat.dg/fixedpnt2.adb, gnat.dg/fixedpnt2.ads: New testcase. + 2018-01-11 Justin Squirek * gnat.dg/loopvar.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/fixedpnt2.adb b/gcc/testsuite/gnat.dg/fixedpnt2.adb new file mode 100644 index 00000000000..5ce88002ce6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/fixedpnt2.adb @@ -0,0 +1,25 @@ +-- { dg-do compile } + +with Ada.Unchecked_Conversion; + +package body Fixedpnt2 is + + function To_Integer_64 is + new Ada.Unchecked_Conversion (Source => My_Type, + Target => T_Integer_64); + + function To_T is + new Ada.Unchecked_Conversion (Source => T_Integer_64, + Target => My_Type); + + function "*" (Left : in T_Integer_32; + Right : in My_Type) + return My_Type is + (To_T (S => T_Integer_64 (Left) * To_Integer_64 (S => Right))); + + function "*" (Left : in My_Type; + Right : in T_Integer_32) + return My_Type is + (To_T (S => To_Integer_64 (S => Left) * T_Integer_64 (Right))); + +end Fixedpnt2; diff --git a/gcc/testsuite/gnat.dg/fixedpnt2.ads b/gcc/testsuite/gnat.dg/fixedpnt2.ads new file mode 100644 index 00000000000..c412a6fcfbd --- /dev/null +++ b/gcc/testsuite/gnat.dg/fixedpnt2.ads @@ -0,0 +1,23 @@ +package Fixedpnt2 is + + type T_Integer_32 is range -2 ** 31 .. 2 ** 31 - 1 + with Size => 32; + + type T_Integer_64 is range -2 ** 63 .. 2 ** 63 - 1 + with Size => 64; + + C_Unit : constant := 0.001; -- One millisecond. + C_First : constant := (-2 ** 63) * C_Unit; + C_Last : constant := (2 ** 63 - 1) * C_Unit; + + type My_Type is + delta C_Unit range C_First .. C_Last + with Size => 64, + Small => C_Unit; + + function "*" (Left : in T_Integer_32; Right : in My_Type) + return My_Type; + function "*" (Left : in My_Type; Right : in T_Integer_32) + return My_Type; + +end Fixedpnt2; -- 2.30.2