+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>
* exp_util.adb, exp_util.ads, types.ads: Minor reformatting.
-- --
-- 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- --
-------------
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);
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;
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
-- 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;
----------------------
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 --
-----------------------------
-- 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
-- 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)
-- --
-- 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- --
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
-- 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
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 --
--------------------------
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 --
--------------------------------------
-- 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
projects / gcc.git / commitdiff