Skip to content

R
riscv-gcc-1
Commit bf604a5e by Arnaud Charlet
Options

[multiple changes] 

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* 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  <schonberg@adacore.com>

	* 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  <schonberg@adacore.com>

	* sem_dim.adb (Dimensions_Of_Operand): The dimensions of a type
	conversion are those of the target type.

2017-04-25  Bob Duff  <duff@adacore.com>

	* a-clrefi.adb: Minor cleanup.

From-SVN: r247236
parent 178c3cba
Showing with 97 additions and 177 deletions
gcc/ada/ChangeLog
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* 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 <schonberg@adacore.com>
* 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 <schonberg@adacore.com>
* sem_dim.adb (Dimensions_Of_Operand): The dimensions of a type
conversion are those of the target type.
2017-04-25 Bob Duff <duff@adacore.com>
* a-clrefi.adb: Minor cleanup.
2017-04-25 Gary Dismukes <dismukes@adacore.com> 2017-04-25 Gary Dismukes <dismukes@adacore.com>
* exp_util.adb, exp_util.ads, types.ads: Minor reformatting. * exp_util.adb, exp_util.ads, types.ads: Minor reformatting.
......
gcc/ada/a-clrefi.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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 ...@@ -105,7 +105,10 @@ package body Ada.Command_Line.Response_File is
------------- -------------
procedure Recurse (File_Name : String) 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_Size : constant := 1500;
Buffer : String (1 .. Buffer_Size); Buffer : String (1 .. Buffer_Size);
...@@ -222,11 +225,6 @@ package body Ada.Command_Line.Response_File is ...@@ -222,11 +225,6 @@ package body Ada.Command_Line.Response_File is
begin begin
Last_Arg := 0; 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 FD = Invalid_FD then
if Ignore_Non_Existing_Files then if Ignore_Non_Existing_Files then
return; return;
......
gcc/ada/exp_util.adb
...@@ -5197,6 +5197,11 @@ package body Exp_Util is ...@@ -5197,6 +5197,11 @@ package body Exp_Util is
is is
U_Typ : constant Entity_Id := Unique_Entity (Typ); 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; function Search_Primitive_Calls (N : Node_Id) return Traverse_Result;
-- Search for nondispatching calls to primitive functions of type Typ -- Search for nondispatching calls to primitive functions of type Typ
...@@ -5204,46 +5209,56 @@ package body Exp_Util is ...@@ -5204,46 +5209,56 @@ package body Exp_Util is
-- Search_Primitive_Calls -- -- 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 begin
if Nkind (N) = N_Identifier -- Detect a function call which could denote a non-dispatching
and then Present (Entity (N)) -- primitive of the input type.
and then
(Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N))) if Nkind (N) = N_Function_Call
and then Nkind (Parent (N)) = N_Function_Call and then Is_Entity_Name (Name (N))
then then
-- Do not consider dispatching calls Subp := Entity (Name (N));
if Is_Subprogram (Entity (N)) -- Do not consider function calls with a controlling argument
and then Nkind (Parent (N)) = N_Function_Call -- as those are always dispatching calls.
and then Present (Controlling_Argument (Parent (N)))
if Is_Dispatching_Operation (Subp)
and then No (Controlling_Argument (N))
then then
return OK; Disp_Typ := Find_Dispatching_Type (Subp);
end if;
-- If N is a function call, and E is dispatching, search for the -- To qualify as a suitable primitive, the dispatching
-- controlling type to see if it is Ty. -- type of the function must be the input type.
if Is_Subprogram (Entity (N)) if Present (Disp_Typ)
and then Nkind (Parent (N)) = N_Function_Call and then Unique_Entity (Disp_Typ) = U_Typ
and then Is_Dispatching_Operation (Entity (N)) then
and then Present (Find_Dispatching_Type (Entity (N))) Calls_OK := True;
and then
Unique_Entity (Find_Dispatching_Type (Entity (N))) = U_Typ -- There is no need to continue the traversal as one
then -- such call suffices.
return Abandon;
return Abandon;
end if;
end if; end if;
end if; end if;
return OK; return OK;
end Search_Primitive_Calls; 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 -- Start of processing for Expression_Contains_Primitives_Calls_Of_Type
begin begin
return Search_Calls (Expr) = Abandon; Search_Calls (Expr);
return Calls_OK;
end Expression_Contains_Primitives_Calls_Of; end Expression_Contains_Primitives_Calls_Of;
---------------------- ----------------------
...@@ -8938,137 +8953,6 @@ package body Exp_Util is ...@@ -8938,137 +8953,6 @@ package body Exp_Util is
end if; end if;
end Known_Non_Negative; 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 -- -- Make_CW_Equivalent_Type --
----------------------------- -----------------------------
......
gcc/ada/exp_util.ads
...@@ -860,18 +860,6 @@ package Exp_Util is ...@@ -860,18 +860,6 @@ package Exp_Util is
-- that cannot possibly be negative, and if so returns True. A value of -- 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. -- 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; function Make_Invariant_Call (Expr : Node_Id) return Node_Id;
-- Expr is an object of a type which Has_Invariants set (and which thus -- 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 -- also has an Invariant_Procedure set). If invariants are enabled, this
......
gcc/ada/sem_ch6.adb
...@@ -382,14 +382,15 @@ package body Sem_Ch6 is ...@@ -382,14 +382,15 @@ package body Sem_Ch6 is
-- An entity can only be frozen if it is complete, so if the type -- 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. -- 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 -- 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 -- 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 -- 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 -- frozen there. We must be in a context seeing the nonlimited view
-- of the type, which will be installed when the body is compiled. -- of the type, which will be installed when the body is compiled.
if not Is_Frozen (Ret_Type) 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 and then not Inside_A_Generic
then then
if From_Limited_With (Ret_Type) if From_Limited_With (Ret_Type)
......
gcc/ada/sem_dim.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1376,6 +1376,13 @@ package body Sem_Dim is ...@@ -1376,6 +1376,13 @@ package body Sem_Dim is
return Dimensions_Of (Etype (N)); return Dimensions_Of (Etype (N));
end if; 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 -- Otherwise return the default dimensions
else else
......
gcc/ada/sem_util.ads
...@@ -1889,6 +1889,18 @@ package Sem_Util is ...@@ -1889,6 +1889,18 @@ package Sem_Util is
-- present, this size check code is killed, since the object will not be -- present, this size check code is killed, since the object will not be
-- allocated by the program. -- 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; function Known_To_Be_Assigned (N : Node_Id) return Boolean;
-- The node N is an entity reference. This function determines whether the -- The node N is an entity reference. This function determines whether the
-- reference is for sure an assignment of the entity, returning True if -- reference is for sure an assignment of the entity, returning True if
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment