From: Arnaud Charlet Date: Tue, 25 Apr 2017 13:33:16 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=28ccbd3ff85e3208f4b6ccd990d75834267426db;p=gcc.git [multiple changes] 2017-04-25 Claire Dross * exp_util.ads (Expression_Contains_Primitives_Calls_Of): New function used in GNATprove to know if an expression contains non-dispatching calls on primitives of a tagged type. 2017-04-25 Bob Duff * rtsfind.adb (Initialize): Initialize First_Implicit_With. Building the compiler with Normalize_Scalars and validity checking finds this being used as an uninitialized variable. From-SVN: r247231 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fc2de1da12c..add3c602571 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2017-04-25 Claire Dross + + * exp_util.ads (Expression_Contains_Primitives_Calls_Of): New + function used in GNATprove to know if an expression contains + non-dispatching calls on primitives of a tagged type. + +2017-04-25 Bob Duff + + * rtsfind.adb (Initialize): Initialize + First_Implicit_With. Building the compiler with Normalize_Scalars + and validity checking finds this being used as an uninitialized + variable. + 2017-04-25 Hristian Kirtchev * contracts.adb (Analyze_Entry_Or_Subprogram_Body_Contract): diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 16e33e8ebb7..414e9d77a55 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5187,6 +5187,65 @@ package body Exp_Util is end if; end Expand_Subtype_From_Expr; + --------------------------------------------- + -- Expression_Contains_Primitives_Calls_Of -- + --------------------------------------------- + + function Expression_Contains_Primitives_Calls_Of + (Expr : Node_Id; + Typ : Entity_Id) return Boolean + is + U_Typ : constant Entity_Id := Unique_Entity (Typ); + + function Search_Primitive_Calls (N : Node_Id) return Traverse_Result; + -- Search for non-dispatching calls to primitive functions of type Typ + + ---------------------------- + -- Search_Primitive_Calls -- + ---------------------------- + + function Search_Primitive_Calls (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + and then + (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N))) + and then Nkind (Parent (N)) = N_Function_Call + then + -- Do not consider dispatching calls + + if Is_Subprogram (Entity (N)) + and then Nkind (Parent (N)) = N_Function_Call + and then Present (Controlling_Argument (Parent (N))) + then + return OK; + end if; + + -- If N is a function call, and E is dispatching, search for the + -- controlling type to see if it is Ty. + + if Is_Subprogram (Entity (N)) + and then Nkind (Parent (N)) = N_Function_Call + and then Is_Dispatching_Operation (Entity (N)) + and then Present (Find_Dispatching_Type (Entity (N))) + and then + Unique_Entity (Find_Dispatching_Type (Entity (N))) = U_Typ + then + return Abandon; + end if; + end if; + + return OK; + end Search_Primitive_Calls; + + function Search_Calls is new Traverse_Func (Search_Primitive_Calls); + + -- Start of processing for Expression_Contains_Primitives_Calls_Of_Type + + begin + return Search_Calls (Expr) = Abandon; + end Expression_Contains_Primitives_Calls_Of; + ---------------------- -- Finalize_Address -- ---------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 5b44d6929a2..532cca73693 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -556,6 +556,12 @@ package Exp_Util is -- class-wide). Set Related_Id to request an external name for the subtype -- rather than an internal temporary. + function Expression_Contains_Primitives_Calls_Of + (Expr : Node_Id; + Typ : Entity_Id) return Boolean; + -- Return True if the expression Expr contains a non-dispatching call to a + -- function which is a primitive of the tagged type Typ. + function Finalize_Address (Typ : Entity_Id) return Entity_Id; -- Locate TSS primitive Finalize_Address in type Typ. Return Empty if the -- subprogram is not available. diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 0c8a3ee43c0..faeffd263b1 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -642,6 +642,7 @@ package body Rtsfind is for J in RTU_Id loop RT_Unit_Table (J).Entity := Empty; + RT_Unit_Table (J).First_Implicit_With := Empty; end loop; for J in RE_Id loop @@ -959,7 +960,7 @@ package body Rtsfind is -- from the enumeration literal name in type RTU_Id. U.Uname := Get_Unit_Name (U_Id); - U. First_Implicit_With := Empty; + U.First_Implicit_With := Empty; -- Now do the load call, note that setting Error_Node to Empty is -- a signal to Load_Unit that we will regard a failure to find the