From bf604a5eeb4b942348e8f1cdaf4baf6d77497aec Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 15:41:04 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Hristian Kirtchev * exp_util.adb (Known_Non_Null): Moved to Sem_Util. (Known_Null): Moved to Sem_Util. * exp_util.ads (Known_Non_Null): Moved to Sem_Util. (Known_Null): Moved to Sem_Util. * sem_util.adb Add new enumeration type Null_Status_Kind. (Known_Non_Null): Moved from Exp_Util. Most of the logic in this routine is now carried out by Null_Status. (Known_Null): Moved from Exp_Util. Most of the logic in this routine is now carried out by Null_Status. (Null_Status): New routine. * sem_util.ads (Known_Non_Null): Moved from Exp_Util. (Known_Null): Moved from Exp_Util. 2017-04-25 Ed Schonberg * sem_ch6.adb (Analyze_Expression_Function): Do not report an error on the return type of an expression function that is a completion, if the type is derived from a generic formal type. 2017-04-25 Ed Schonberg * sem_dim.adb (Dimensions_Of_Operand): The dimensions of a type conversion are those of the target type. 2017-04-25 Bob Duff * a-clrefi.adb: Minor cleanup. From-SVN: r247236 --- gcc/ada/ChangeLog | 30 +++++ gcc/ada/a-clrefi.adb | 12 +- gcc/ada/exp_util.adb | 194 ++++++-------------------- gcc/ada/exp_util.ads | 12 -- gcc/ada/sem_ch6.adb | 5 +- gcc/ada/sem_dim.adb | 9 +- gcc/ada/sem_util.adb | 315 +++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_util.ads | 12 ++ 8 files changed, 412 insertions(+), 177 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 61b0f924d5c..5cca5c8b65e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,33 @@ +2017-04-25 Hristian Kirtchev + + * exp_util.adb (Known_Non_Null): Moved to Sem_Util. + (Known_Null): Moved to Sem_Util. + * exp_util.ads (Known_Non_Null): Moved to Sem_Util. + (Known_Null): Moved to Sem_Util. + * sem_util.adb Add new enumeration type Null_Status_Kind. + (Known_Non_Null): Moved from Exp_Util. Most of the logic in + this routine is now carried out by Null_Status. + (Known_Null): Moved from Exp_Util. Most of the logic in this routine + is now carried out by Null_Status. + (Null_Status): New routine. + * sem_util.ads (Known_Non_Null): Moved from Exp_Util. + (Known_Null): Moved from Exp_Util. + +2017-04-25 Ed Schonberg + + * sem_ch6.adb (Analyze_Expression_Function): Do not report an + error on the return type of an expression function that is a + completion, if the type is derived from a generic formal type. + +2017-04-25 Ed Schonberg + + * sem_dim.adb (Dimensions_Of_Operand): The dimensions of a type + conversion are those of the target type. + +2017-04-25 Bob Duff + + * a-clrefi.adb: Minor cleanup. + 2017-04-25 Gary Dismukes * exp_util.adb, exp_util.ads, types.ads: Minor reformatting. diff --git a/gcc/ada/a-clrefi.adb b/gcc/ada/a-clrefi.adb index 5afde3b616c..914d8f4a013 100644 --- a/gcc/ada/a-clrefi.adb +++ b/gcc/ada/a-clrefi.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2007-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- -- @@ -105,7 +105,10 @@ package body Ada.Command_Line.Response_File is ------------- procedure Recurse (File_Name : String) is - FD : File_Descriptor; + -- Open the response file. If not found, fail or report a warning, + -- depending on the value of Ignore_Non_Existing_Files. + + FD : constant File_Descriptor := Open_Read (File_Name, Text); Buffer_Size : constant := 1500; Buffer : String (1 .. Buffer_Size); @@ -222,11 +225,6 @@ package body Ada.Command_Line.Response_File is begin Last_Arg := 0; - -- Open the response file. If not found, fail or report a warning, - -- depending on the value of Ignore_Non_Existing_Files. - - FD := Open_Read (File_Name, Text); - if FD = Invalid_FD then if Ignore_Non_Existing_Files then return; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index a775600adff..04cd7c4980a 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5197,6 +5197,11 @@ package body Exp_Util is is U_Typ : constant Entity_Id := Unique_Entity (Typ); + Calls_OK : Boolean := False; + -- This flag is set to True when expression Expr contains at + -- least one call to a non-dispatching primitive function of + -- Typ. + function Search_Primitive_Calls (N : Node_Id) return Traverse_Result; -- Search for nondispatching calls to primitive functions of type Typ @@ -5204,46 +5209,56 @@ package body Exp_Util is -- Search_Primitive_Calls -- ---------------------------- - function Search_Primitive_Calls (N : Node_Id) return Traverse_Result is + function Search_Primitive_Calls + (N : Node_Id) return Traverse_Result + is + Disp_Typ : Entity_Id; + Subp : Entity_Id; + 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 + -- Detect a function call which could denote a non-dispatching + -- primitive of the input type. + + if Nkind (N) = N_Function_Call + and then Is_Entity_Name (Name (N)) then - -- Do not consider dispatching calls + Subp := Entity (Name (N)); - if Is_Subprogram (Entity (N)) - and then Nkind (Parent (N)) = N_Function_Call - and then Present (Controlling_Argument (Parent (N))) + -- Do not consider function calls with a controlling argument + -- as those are always dispatching calls. + + if Is_Dispatching_Operation (Subp) + and then No (Controlling_Argument (N)) then - return OK; - end if; + Disp_Typ := Find_Dispatching_Type (Subp); - -- If N is a function call, and E is dispatching, search for the - -- controlling type to see if it is Ty. + -- To qualify as a suitable primitive, the dispatching + -- type of the function must be the input type. - 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; + if Present (Disp_Typ) + and then Unique_Entity (Disp_Typ) = U_Typ + then + Calls_OK := True; + + -- There is no need to continue the traversal as one + -- such call suffices. + + return Abandon; + end if; end if; end if; return OK; end Search_Primitive_Calls; - function Search_Calls is new Traverse_Func (Search_Primitive_Calls); + procedure Search_Calls is + new Traverse_Proc (Search_Primitive_Calls); -- Start of processing for Expression_Contains_Primitives_Calls_Of_Type begin - return Search_Calls (Expr) = Abandon; + Search_Calls (Expr); + return Calls_OK; end Expression_Contains_Primitives_Calls_Of; ---------------------- @@ -8938,137 +8953,6 @@ package body Exp_Util is end if; end Known_Non_Negative; - -------------------- - -- Known_Non_Null -- - -------------------- - - function Known_Non_Null (N : Node_Id) return Boolean is - begin - -- Checks for case where N is an entity reference - - if Is_Entity_Name (N) and then Present (Entity (N)) then - declare - E : constant Entity_Id := Entity (N); - Op : Node_Kind; - Val : Node_Id; - - begin - -- First check if we are in decisive conditional - - Get_Current_Value_Condition (N, Op, Val); - - if Known_Null (Val) then - if Op = N_Op_Eq then - return False; - elsif Op = N_Op_Ne then - return True; - end if; - end if; - - -- If OK to do replacement, test Is_Known_Non_Null flag - - if OK_To_Do_Constant_Replacement (E) then - return Is_Known_Non_Null (E); - - -- Otherwise if not safe to do replacement, then say so - - else - return False; - end if; - end; - - -- True if access attribute - - elsif Nkind (N) = N_Attribute_Reference - and then Nam_In (Attribute_Name (N), Name_Access, - Name_Unchecked_Access, - Name_Unrestricted_Access) - then - return True; - - -- True if allocator - - elsif Nkind (N) = N_Allocator then - return True; - - -- For a conversion, true if expression is known non-null - - elsif Nkind (N) = N_Type_Conversion then - return Known_Non_Null (Expression (N)); - - -- Above are all cases where the value could be determined to be - -- non-null. In all other cases, we don't know, so return False. - - else - return False; - end if; - end Known_Non_Null; - - ---------------- - -- Known_Null -- - ---------------- - - function Known_Null (N : Node_Id) return Boolean is - begin - -- Checks for case where N is an entity reference - - if Is_Entity_Name (N) and then Present (Entity (N)) then - declare - E : constant Entity_Id := Entity (N); - Op : Node_Kind; - Val : Node_Id; - - begin - -- Constant null value is for sure null - - if Ekind (E) = E_Constant - and then Known_Null (Constant_Value (E)) - then - return True; - end if; - - -- First check if we are in decisive conditional - - Get_Current_Value_Condition (N, Op, Val); - - if Known_Null (Val) then - if Op = N_Op_Eq then - return True; - elsif Op = N_Op_Ne then - return False; - end if; - end if; - - -- If OK to do replacement, test Is_Known_Null flag - - if OK_To_Do_Constant_Replacement (E) then - return Is_Known_Null (E); - - -- Otherwise if not safe to do replacement, then say so - - else - return False; - end if; - end; - - -- True if explicit reference to null - - elsif Nkind (N) = N_Null then - return True; - - -- For a conversion, true if expression is known null - - elsif Nkind (N) = N_Type_Conversion then - return Known_Null (Expression (N)); - - -- Above are all cases where the value could be determined to be null. - -- In all other cases, we don't know, so return False. - - else - return False; - end if; - end Known_Null; - ----------------------------- -- Make_CW_Equivalent_Type -- ----------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 4dc921add69..b1fded9bcef 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -860,18 +860,6 @@ package Exp_Util is -- that cannot possibly be negative, and if so returns True. A value of -- False means that it is not known if the value is positive or negative. - function Known_Non_Null (N : Node_Id) return Boolean; - -- Given a node N for a subexpression of an access type, determines if - -- this subexpression yields a value that is known at compile time to - -- be non-null and returns True if so. Returns False otherwise. It is - -- an error to call this function if N is not of an access type. - - function Known_Null (N : Node_Id) return Boolean; - -- Given a node N for a subexpression of an access type, determines if this - -- subexpression yields a value that is known at compile time to be null - -- and returns True if so. Returns False otherwise. It is an error to call - -- this function if N is not of an access type. - function Make_Invariant_Call (Expr : Node_Id) return Node_Id; -- Expr is an object of a type which Has_Invariants set (and which thus -- also has an Invariant_Procedure set). If invariants are enabled, this diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 300f6def70c..020ffb8400a 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -382,14 +382,15 @@ package body Sem_Ch6 is -- An entity can only be frozen if it is complete, so if the type -- is still unfrozen it must still be incomplete in some way, e.g. -- a private type without a full view, or a type derived from such - -- in an enclosing scope. Except in a generic context, such use of + -- in an enclosing scope. Except in a generic context (where the + -- type may be a generic formal or derived from such), such use of -- an incomplete type is an error. On the other hand, if this is a -- limited view of a type, the type is declared in another unit and -- frozen there. We must be in a context seeing the nonlimited view -- of the type, which will be installed when the body is compiled. if not Is_Frozen (Ret_Type) - and then not Is_Generic_Type (Ret_Type) + and then not Is_Generic_Type (Root_Type (Ret_Type)) and then not Inside_A_Generic then if From_Limited_With (Ret_Type) diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index c5eda0c4f32..64a5f5b991d 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-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- -- @@ -1376,6 +1376,13 @@ package body Sem_Dim is return Dimensions_Of (Etype (N)); end if; + -- A type conversion may have been inserted to rewrite other + -- expressions, e.g. function returns. Dimensions are those of + -- the target type. + + elsif Nkind (N) = N_Type_Conversion then + return Dimensions_Of (Etype (N)); + -- Otherwise return the default dimensions else diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ee57f279a22..5b552bfcb4f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -100,6 +100,25 @@ package body Sem_Util is -- components in the selected variant to determine whether all of them -- have a default. + type Null_Status_Kind is + (Is_Null, + -- This value indicates that a subexpression is known to have a null + -- value at compile time. + + Is_Non_Null, + -- This value indicates that a subexpression is known to have a non-null + -- value at compile time. + + Unknown); + -- This value indicates that it cannot be determined at compile time + -- whether a subexpression yields a null or non-null value. + + function Null_Status (N : Node_Id) return Null_Status_Kind; + -- Determine whether subexpression N of an access type yields a null value, + -- a non-null value, or the value cannot be determined at compile time. The + -- routine does not take simple flow diagnostics into account, it relies on + -- static facts such as the presence of null exclusions. + function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean; function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean; -- ???We retain the old and new algorithms for Requires_Transient_Scope for @@ -15966,6 +15985,104 @@ package body Sem_Util is end if; end Kill_Size_Check_Code; + -------------------- + -- Known_Non_Null -- + -------------------- + + function Known_Non_Null (N : Node_Id) return Boolean is + Status : constant Null_Status_Kind := Null_Status (N); + + Id : Entity_Id; + Op : Node_Kind; + Val : Node_Id; + + begin + -- The expression yields a non-null value ignoring simple flow analysis + + if Status = Is_Non_Null then + return True; + + -- Otherwise check whether N is a reference to an entity that appears + -- within a conditional construct. + + elsif Is_Entity_Name (N) and then Present (Entity (N)) then + + -- First check if we are in decisive conditional + + Get_Current_Value_Condition (N, Op, Val); + + if Known_Null (Val) then + if Op = N_Op_Eq then + return False; + elsif Op = N_Op_Ne then + return True; + end if; + end if; + + -- If OK to do replacement, test Is_Known_Non_Null flag + + Id := Entity (N); + + if OK_To_Do_Constant_Replacement (Id) then + return Is_Known_Non_Null (Id); + end if; + end if; + + -- Otherwise it is not possible to determine whether N yields a non-null + -- value. + + return False; + end Known_Non_Null; + + ---------------- + -- Known_Null -- + ---------------- + + function Known_Null (N : Node_Id) return Boolean is + Status : constant Null_Status_Kind := Null_Status (N); + + Id : Entity_Id; + Op : Node_Kind; + Val : Node_Id; + + begin + -- The expression yields a null value ignoring simple flow analysis + + if Status = Is_Null then + return True; + + -- Otherwise check whether N is a reference to an entity that appears + -- within a conditional construct. + + elsif Is_Entity_Name (N) and then Present (Entity (N)) then + + -- First check if we are in decisive conditional + + Get_Current_Value_Condition (N, Op, Val); + + if Known_Null (Val) then + if Op = N_Op_Eq then + return True; + elsif Op = N_Op_Ne then + return False; + end if; + end if; + + -- If OK to do replacement, test Is_Known_Null flag + + Id := Entity (N); + + if OK_To_Do_Constant_Replacement (Id) then + return Is_Known_Null (Id); + end if; + end if; + + -- Otherwise it is not possible to determine whether N yields a null + -- value. + + return False; + end Known_Null; + -------------------------- -- Known_To_Be_Assigned -- -------------------------- @@ -18347,6 +18464,204 @@ package body Sem_Util is end loop; end Note_Possible_Modification; + ----------------- + -- Null_Status -- + ----------------- + + function Null_Status (N : Node_Id) return Null_Status_Kind is + function Is_Null_Excluding_Def (Def : Node_Id) return Boolean; + -- Determine whether definition Def carries a null exclusion + + function Null_Status_Of_Entity (Id : Entity_Id) return Null_Status_Kind; + -- Determine the null status of arbitrary entity Id + + function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind; + -- Determine the null status of type Typ + + --------------------------- + -- Is_Null_Excluding_Def -- + --------------------------- + + function Is_Null_Excluding_Def (Def : Node_Id) return Boolean is + begin + return + Nkind_In (Def, N_Access_Definition, + N_Access_Function_Definition, + N_Access_Procedure_Definition, + N_Access_To_Object_Definition, + N_Component_Definition, + N_Derived_Type_Definition) + and then Null_Exclusion_Present (Def); + end Is_Null_Excluding_Def; + + --------------------------- + -- Null_Status_Of_Entity -- + --------------------------- + + function Null_Status_Of_Entity + (Id : Entity_Id) return Null_Status_Kind + is + Decl : constant Node_Id := Declaration_Node (Id); + Def : Node_Id; + + begin + -- The value of an imported or exported entity may be set externally + -- regardless of a null exclusion. As a result, the value cannot be + -- determined statically. + + if Is_Imported (Id) or else Is_Exported (Id) then + return Unknown; + + elsif Nkind_In (Decl, N_Component_Declaration, + N_Discriminant_Specification, + N_Formal_Object_Declaration, + N_Object_Declaration, + N_Object_Renaming_Declaration, + N_Parameter_Specification) + then + -- A component declaration yields a non-null value when either + -- its component definition or access definition carries a null + -- exclusion. + + if Nkind (Decl) = N_Component_Declaration then + Def := Component_Definition (Decl); + + if Is_Null_Excluding_Def (Def) then + return Is_Non_Null; + end if; + + Def := Access_Definition (Def); + + if Present (Def) and then Is_Null_Excluding_Def (Def) then + return Is_Non_Null; + end if; + + -- A formal object declaration yields a non-null value if its + -- access definition carries a null exclusion. If the object is + -- default initialized, then the value depends on the expression. + + elsif Nkind (Decl) = N_Formal_Object_Declaration then + Def := Access_Definition (Decl); + + if Present (Def) and then Is_Null_Excluding_Def (Def) then + return Is_Non_Null; + end if; + + -- A constant may yield a null or non-null value depending on its + -- initialization expression. + + elsif Ekind (Id) = E_Constant then + return Null_Status (Constant_Value (Id)); + + -- The construct yields a non-null value when it has a null + -- exclusion. + + elsif Null_Exclusion_Present (Decl) then + return Is_Non_Null; + + -- An object renaming declaration yields a non-null value if its + -- access definition carries a null exclusion. Otherwise the value + -- depends on the renamed name. + + elsif Nkind (Decl) = N_Object_Renaming_Declaration then + Def := Access_Definition (Decl); + + if Present (Def) and then Is_Null_Excluding_Def (Def) then + return Is_Non_Null; + + else + return Null_Status (Name (Decl)); + end if; + end if; + end if; + + -- At this point the declaration of the entity does not carry a null + -- exclusion and lacks an initialization expression. Check the status + -- of its type. + + return Null_Status_Of_Type (Etype (Id)); + end Null_Status_Of_Entity; + + ------------------------- + -- Null_Status_Of_Type -- + ------------------------- + + function Null_Status_Of_Type (Typ : Entity_Id) return Null_Status_Kind is + Curr : Entity_Id; + Decl : Node_Id; + + begin + -- Traverse the type chain looking for types with null exclusion + + Curr := Typ; + while Present (Curr) and then Etype (Curr) /= Curr loop + Decl := Parent (Curr); + + -- Guard against itypes which do not always have declarations. A + -- type yields a non-null value if it carries a null exclusion. + + if Present (Decl) then + if Nkind (Decl) = N_Full_Type_Declaration + and then Is_Null_Excluding_Def (Type_Definition (Decl)) + then + return Is_Non_Null; + + elsif Nkind (Decl) = N_Subtype_Declaration + and then Null_Exclusion_Present (Decl) + then + return Is_Non_Null; + end if; + end if; + + Curr := Etype (Curr); + end loop; + + -- The type chain does not contain any null excluding types + + return Unknown; + end Null_Status_Of_Type; + + -- Start of processing for Null_Status + + begin + -- An allocator always creates a non-null value + + if Nkind (N) = N_Allocator then + return Is_Non_Null; + + -- Taking the 'Access of something yields a non-null value + + elsif Nkind (N) = N_Attribute_Reference + and then Nam_In (Attribute_Name (N), Name_Access, + Name_Unchecked_Access, + Name_Unrestricted_Access) + then + return Is_Non_Null; + + -- "null" yields null + + elsif Nkind (N) = N_Null then + return Is_Null; + + -- Check the status of the operand of a type conversion + + elsif Nkind (N) = N_Type_Conversion then + return Null_Status (Expression (N)); + + -- The input denotes a reference to an entity. Determine whether the + -- entity or its type yields a null or non-null value. + + elsif Is_Entity_Name (N) and then Present (Entity (N)) then + return Null_Status_Of_Entity (Entity (N)); + end if; + + -- Otherwise it is not possible to determine the null status of the + -- subexpression at compile time without resorting to simple flow + -- analysis. + + return Unknown; + end Null_Status; + -------------------------------------- -- Null_To_Null_Address_Convert_OK -- -------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index c8a484d260b..2b6a362cbc3 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1889,6 +1889,18 @@ package Sem_Util is -- present, this size check code is killed, since the object will not be -- allocated by the program. + function Known_Non_Null (N : Node_Id) return Boolean; + -- Given a node N for a subexpression of an access type, determines if + -- this subexpression yields a value that is known at compile time to + -- be non-null and returns True if so. Returns False otherwise. It is + -- an error to call this function if N is not of an access type. + + function Known_Null (N : Node_Id) return Boolean; + -- Given a node N for a subexpression of an access type, determines if this + -- subexpression yields a value that is known at compile time to be null + -- and returns True if so. Returns False otherwise. It is an error to call + -- this function if N is not of an access type. + function Known_To_Be_Assigned (N : Node_Id) return Boolean; -- The node N is an entity reference. This function determines whether the -- reference is for sure an assignment of the entity, returning True if -- 2.30.2