Google Git
Sign in
gnu / gcc / refs/heads/releases/gcc-9 / . / gcc / ada / sem_util.adb
blob: eedfaf1376ee4156e2465da7e2ab9acfbdc384bb [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ U T I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2019, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Treepr; -- ???For debugging code below
with Aspects; use Aspects;
with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
with Elists; use Elists;
with Errout; use Errout;
with Erroutc; use Erroutc;
with Exp_Ch11; use Exp_Ch11;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet.Sp; use Namet.Sp;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Output; use Output;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Warn; use Sem_Warn;
with Sem_Type; use Sem_Type;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Stand; use Stand;
with Style;
with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uname; use Uname;
with GNAT.HTable; use GNAT.HTable;
package body Sem_Util is
---------------------------
-- Local Data Structures --
---------------------------
Invalid_Binder_Values : array (Scalar_Id) of Entity_Id := (others => Empty);
-- A collection to hold the entities of the variables declared in package
-- System.Scalar_Values which describe the invalid values of scalar types.
Invalid_Binder_Values_Set : Boolean := False;
-- This flag prevents multiple attempts to initialize Invalid_Binder_Values
Invalid_Floats : array (Float_Scalar_Id) of Ureal := (others => No_Ureal);
-- A collection to hold the invalid values of float types as specified by
-- pragma Initialize_Scalars.
Invalid_Integers : array (Integer_Scalar_Id) of Uint := (others => No_Uint);
-- A collection to hold the invalid values of integer types as specified
-- by pragma Initialize_Scalars.
-----------------------
-- Local Subprograms --
-----------------------
function Build_Component_Subtype
(C : List_Id;
Loc : Source_Ptr;
T : Entity_Id) return Node_Id;
-- This function builds the subtype for Build_Actual_Subtype_Of_Component
-- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
-- Loc is the source location, T is the original subtype.
procedure Examine_Array_Bounds
(Typ : Entity_Id;
All_Static : out Boolean;
Has_Empty : out Boolean);
-- Inspect the index constraints of array type Typ. Flag All_Static is set
-- when all ranges are static. Flag Has_Empty is set only when All_Static
-- is set and indicates that at least one range is empty.
function Has_Enabled_Property
(Item_Id : Entity_Id;
Property : Name_Id) return Boolean;
-- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
-- Determine whether an abstract state or a variable denoted by entity
-- Item_Id has enabled property Property.
function Has_Null_Extension (T : Entity_Id) return Boolean;
-- T is a derived tagged type. Check whether the type extension is null.
-- If the parent type is fully initialized, T can be treated as such.
function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
-- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
-- with discriminants whose default values are static, examine only the
-- 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
-- the time being. New_Requires_Transient_Scope is used by default; the
-- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope
-- instead. The intent is to use this temporarily to measure before/after
-- efficiency. Note: when this temporary code is removed, the documentation
-- of dQ in debug.adb should be removed.
procedure Results_Differ
(Id : Entity_Id;
Old_Val : Boolean;
New_Val : Boolean);
-- ???Debugging code. Called when the Old_Val and New_Val differ. This
-- routine will be removed eventially when New_Requires_Transient_Scope
-- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is
-- eliminated.
function Subprogram_Name (N : Node_Id) return String;
-- Return the fully qualified name of the enclosing subprogram for the
-- given node N, with file:line:col information appended, e.g.
-- "subp:file:line:col", corresponding to the source location of the
-- body of the subprogram.
------------------------------
-- Abstract_Interface_List --
------------------------------
function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
Nod : Node_Id;
begin
if Is_Concurrent_Type (Typ) then
-- If we are dealing with a synchronized subtype, go to the base
-- type, whose declaration has the interface list.
Nod := Declaration_Node (Base_Type (Typ));
if Nkind_In (Nod, N_Full_Type_Declaration,
N_Private_Type_Declaration)
then
return Empty_List;
end if;
elsif Ekind (Typ) = E_Record_Type_With_Private then
if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
Nod := Type_Definition (Parent (Typ));
elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
if Present (Full_View (Typ))
and then
Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration
then
Nod := Type_Definition (Parent (Full_View (Typ)));
-- If the full-view is not available we cannot do anything else
-- here (the source has errors).
else
return Empty_List;
end if;
-- Support for generic formals with interfaces is still missing ???
elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
return Empty_List;
else
pragma Assert
(Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
Nod := Parent (Typ);
end if;
elsif Ekind (Typ) = E_Record_Subtype then
Nod := Type_Definition (Parent (Etype (Typ)));
elsif Ekind (Typ) = E_Record_Subtype_With_Private then
-- Recurse, because parent may still be a private extension. Also
-- note that the full view of the subtype or the full view of its
-- base type may (both) be unavailable.
return Abstract_Interface_List (Etype (Typ));
elsif Ekind (Typ) = E_Record_Type then
if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
Nod := Formal_Type_Definition (Parent (Typ));
else
Nod := Type_Definition (Parent (Typ));
end if;
-- Otherwise the type is of a kind which does not implement interfaces
else
return Empty_List;
end if;
return Interface_List (Nod);
end Abstract_Interface_List;
--------------------------------
-- Add_Access_Type_To_Process --
--------------------------------
procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
L : Elist_Id;
begin
Ensure_Freeze_Node (E);
L := Access_Types_To_Process (Freeze_Node (E));
if No (L) then
L := New_Elmt_List;
Set_Access_Types_To_Process (Freeze_Node (E), L);
end if;
Append_Elmt (A, L);
end Add_Access_Type_To_Process;
--------------------------
-- Add_Block_Identifier --
--------------------------
procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
begin
pragma Assert (Nkind (N) = N_Block_Statement);
-- The block already has a label, return its entity
if Present (Identifier (N)) then
Id := Entity (Identifier (N));
-- Create a new block label and set its attributes
else
Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
Set_Etype (Id, Standard_Void_Type);
Set_Parent (Id, N);
Set_Identifier (N, New_Occurrence_Of (Id, Loc));
Set_Block_Node (Id, Identifier (N));
end if;
end Add_Block_Identifier;
----------------------------
-- Add_Global_Declaration --
----------------------------
procedure Add_Global_Declaration (N : Node_Id) is
Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
begin
if No (Declarations (Aux_Node)) then
Set_Declarations (Aux_Node, New_List);
end if;
Append_To (Declarations (Aux_Node), N);
Analyze (N);
end Add_Global_Declaration;
--------------------------------
-- Address_Integer_Convert_OK --
--------------------------------
function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is
begin
if Allow_Integer_Address
and then ((Is_Descendant_Of_Address (T1)
and then Is_Private_Type (T1)
and then Is_Integer_Type (T2))
or else
(Is_Descendant_Of_Address (T2)
and then Is_Private_Type (T2)
and then Is_Integer_Type (T1)))
then
return True;
else
return False;
end if;
end Address_Integer_Convert_OK;
-------------------
-- Address_Value --
-------------------
function Address_Value (N : Node_Id) return Node_Id is
Expr : Node_Id := N;
begin
loop
-- For constant, get constant expression
if Is_Entity_Name (Expr)
and then Ekind (Entity (Expr)) = E_Constant
then
Expr := Constant_Value (Entity (Expr));
-- For unchecked conversion, get result to convert
elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
Expr := Expression (Expr);
-- For (common case) of To_Address call, get argument
elsif Nkind (Expr) = N_Function_Call
and then Is_Entity_Name (Name (Expr))
and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
then
Expr := First (Parameter_Associations (Expr));
if Nkind (Expr) = N_Parameter_Association then
Expr := Explicit_Actual_Parameter (Expr);
end if;
-- We finally have the real expression
else
exit;
end if;
end loop;
return Expr;
end Address_Value;
-----------------
-- Addressable --
-----------------
-- For now, just 8/16/32/64
function Addressable (V : Uint) return Boolean is
begin
return V = Uint_8 or else
V = Uint_16 or else
V = Uint_32 or else
V = Uint_64;
end Addressable;
function Addressable (V : Int) return Boolean is
begin
return V = 8 or else
V = 16 or else
V = 32 or else
V = 64;
end Addressable;
---------------------------------
-- Aggregate_Constraint_Checks --
---------------------------------
procedure Aggregate_Constraint_Checks
(Exp : Node_Id;
Check_Typ : Entity_Id)
is
Exp_Typ : constant Entity_Id := Etype (Exp);
begin
if Raises_Constraint_Error (Exp) then
return;
end if;
-- Ada 2005 (AI-230): Generate a conversion to an anonymous access
-- component's type to force the appropriate accessibility checks.
-- Ada 2005 (AI-231): Generate conversion to the null-excluding type to
-- force the corresponding run-time check
if Is_Access_Type (Check_Typ)
and then Is_Local_Anonymous_Access (Check_Typ)
then
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
-- What follows is really expansion activity, so check that expansion
-- is on and is allowed. In GNATprove mode, we also want check flags to
-- be added in the tree, so that the formal verification can rely on
-- those to be present. In GNATprove mode for formal verification, some
-- treatment typically only done during expansion needs to be performed
-- on the tree, but it should not be applied inside generics. Otherwise,
-- this breaks the name resolution mechanism for generic instances.
if not Expander_Active
and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
then
return;
end if;
if Is_Access_Type (Check_Typ)
and then Can_Never_Be_Null (Check_Typ)
and then not Can_Never_Be_Null (Exp_Typ)
then
Install_Null_Excluding_Check (Exp);
end if;
-- First check if we have to insert discriminant checks
if Has_Discriminants (Exp_Typ) then
Apply_Discriminant_Check (Exp, Check_Typ);
-- Next emit length checks for array aggregates
elsif Is_Array_Type (Exp_Typ) then
Apply_Length_Check (Exp, Check_Typ);
-- Finally emit scalar and string checks. If we are dealing with a
-- scalar literal we need to check by hand because the Etype of
-- literals is not necessarily correct.
elsif Is_Scalar_Type (Exp_Typ)
and then Compile_Time_Known_Value (Exp)
then
if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
Apply_Compile_Time_Constraint_Error
(Exp, "value not in range of}??", CE_Range_Check_Failed,
Ent => Base_Type (Check_Typ),
Typ => Base_Type (Check_Typ));
elsif Is_Out_Of_Range (Exp, Check_Typ) then
Apply_Compile_Time_Constraint_Error
(Exp, "value not in range of}??", CE_Range_Check_Failed,
Ent => Check_Typ,
Typ => Check_Typ);
elsif not Range_Checks_Suppressed (Check_Typ) then
Apply_Scalar_Range_Check (Exp, Check_Typ);
end if;
-- Verify that target type is also scalar, to prevent view anomalies
-- in instantiations.
elsif (Is_Scalar_Type (Exp_Typ)
or else Nkind (Exp) = N_String_Literal)
and then Is_Scalar_Type (Check_Typ)
and then Exp_Typ /= Check_Typ
then
if Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) = E_Constant
then
-- If expression is a constant, it is worthwhile checking whether
-- it is a bound of the type.
if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
or else
(Is_Entity_Name (Type_High_Bound (Check_Typ))
and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
then
return;
else
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
-- Could use a comment on this case ???
else
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
end if;
end Aggregate_Constraint_Checks;
-----------------------
-- Alignment_In_Bits --
-----------------------
function Alignment_In_Bits (E : Entity_Id) return Uint is
begin
return Alignment (E) * System_Storage_Unit;
end Alignment_In_Bits;
--------------------------------------
-- All_Composite_Constraints_Static --
--------------------------------------
function All_Composite_Constraints_Static
(Constr : Node_Id) return Boolean
is
begin
if No (Constr) or else Error_Posted (Constr) then
return True;
end if;
case Nkind (Constr) is
when N_Subexpr =>
if Nkind (Constr) in N_Has_Entity
and then Present (Entity (Constr))
then
if Is_Type (Entity (Constr)) then
return
not Is_Discrete_Type (Entity (Constr))
or else Is_OK_Static_Subtype (Entity (Constr));
end if;
elsif Nkind (Constr) = N_Range then
return
Is_OK_Static_Expression (Low_Bound (Constr))
and then
Is_OK_Static_Expression (High_Bound (Constr));
elsif Nkind (Constr) = N_Attribute_Reference
and then Attribute_Name (Constr) = Name_Range
then
return
Is_OK_Static_Expression
(Type_Low_Bound (Etype (Prefix (Constr))))
and then
Is_OK_Static_Expression
(Type_High_Bound (Etype (Prefix (Constr))));
end if;
return
not Present (Etype (Constr)) -- previous error
or else not Is_Discrete_Type (Etype (Constr))
or else Is_OK_Static_Expression (Constr);
when N_Discriminant_Association =>
return All_Composite_Constraints_Static (Expression (Constr));
when N_Range_Constraint =>
return
All_Composite_Constraints_Static (Range_Expression (Constr));
when N_Index_Or_Discriminant_Constraint =>
declare
One_Cstr : Entity_Id;
begin
One_Cstr := First (Constraints (Constr));
while Present (One_Cstr) loop
if not All_Composite_Constraints_Static (One_Cstr) then
return False;
end if;
Next (One_Cstr);
end loop;
end;
return True;
when N_Subtype_Indication =>
return
All_Composite_Constraints_Static (Subtype_Mark (Constr))
and then
All_Composite_Constraints_Static (Constraint (Constr));
when others =>
raise Program_Error;
end case;
end All_Composite_Constraints_Static;
------------------------
-- Append_Entity_Name --
------------------------
procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is
Temp : Bounded_String;
procedure Inner (E : Entity_Id);
-- Inner recursive routine, keep outer routine nonrecursive to ease
-- debugging when we get strange results from this routine.
-----------
-- Inner --
-----------
procedure Inner (E : Entity_Id) is
Scop : Node_Id;
begin
-- If entity has an internal name, skip by it, and print its scope.
-- Note that we strip a final R from the name before the test; this
-- is needed for some cases of instantiations.
declare
E_Name : Bounded_String;
begin
Append (E_Name, Chars (E));
if E_Name.Chars (E_Name.Length) = 'R' then
E_Name.Length := E_Name.Length - 1;
end if;
if Is_Internal_Name (E_Name) then
Inner (Scope (E));
return;
end if;
end;
Scop := Scope (E);
-- Just print entity name if its scope is at the outer level
if Scop = Standard_Standard then
null;
-- If scope comes from source, write scope and entity
elsif Comes_From_Source (Scop) then
Append_Entity_Name (Temp, Scop);
Append (Temp, '.');
-- If in wrapper package skip past it
elsif Present (Scop) and then Is_Wrapper_Package (Scop) then
Append_Entity_Name (Temp, Scope (Scop));
Append (Temp, '.');
-- Otherwise nothing to output (happens in unnamed block statements)
else
null;
end if;
-- Output the name
declare
E_Name : Bounded_String;
begin
Append_Unqualified_Decoded (E_Name, Chars (E));
-- Remove trailing upper-case letters from the name (useful for
-- dealing with some cases of internal names generated in the case
-- of references from within a generic).
while E_Name.Length > 1
and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z'
loop
E_Name.Length := E_Name.Length - 1;
end loop;
-- Adjust casing appropriately (gets name from source if possible)
Adjust_Name_Case (E_Name, Sloc (E));
Append (Temp, E_Name);
end;
end Inner;
-- Start of processing for Append_Entity_Name
begin
Inner (E);
Append (Buf, Temp);
end Append_Entity_Name;
---------------------------------
-- Append_Inherited_Subprogram --
---------------------------------
procedure Append_Inherited_Subprogram (S : Entity_Id) is
Par : constant Entity_Id := Alias (S);
-- The parent subprogram
Scop : constant Entity_Id := Scope (Par);
-- The scope of definition of the parent subprogram
Typ : constant Entity_Id := Defining_Entity (Parent (S));
-- The derived type of which S is a primitive operation
Decl : Node_Id;
Next_E : Entity_Id;
begin
if Ekind (Current_Scope) = E_Package
and then In_Private_Part (Current_Scope)
and then Has_Private_Declaration (Typ)
and then Is_Tagged_Type (Typ)
and then Scop = Current_Scope
then
-- The inherited operation is available at the earliest place after
-- the derived type declaration (RM 7.3.1 (6/1)). This is only
-- relevant for type extensions. If the parent operation appears
-- after the type extension, the operation is not visible.
Decl := First
(Visible_Declarations
(Package_Specification (Current_Scope)));
while Present (Decl) loop
if Nkind (Decl) = N_Private_Extension_Declaration
and then Defining_Entity (Decl) = Typ
then
if Sloc (Decl) > Sloc (Par) then
Next_E := Next_Entity (Par);
Link_Entities (Par, S);
Link_Entities (S, Next_E);
return;
else
exit;
end if;
end if;
Next (Decl);
end loop;
end if;
-- If partial view is not a type extension, or it appears before the
-- subprogram declaration, insert normally at end of entity list.
Append_Entity (S, Current_Scope);
end Append_Inherited_Subprogram;
-----------------------------------------
-- Apply_Compile_Time_Constraint_Error --
-----------------------------------------
procedure Apply_Compile_Time_Constraint_Error
(N : Node_Id;
Msg : String;
Reason : RT_Exception_Code;
Ent : Entity_Id := Empty;
Typ : Entity_Id := Empty;
Loc : Source_Ptr := No_Location;
Rep : Boolean := True;
Warn : Boolean := False)
is
Stat : constant Boolean := Is_Static_Expression (N);
R_Stat : constant Node_Id :=
Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
Rtyp : Entity_Id;
begin
if No (Typ) then
Rtyp := Etype (N);
else
Rtyp := Typ;
end if;
Discard_Node
(Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
-- In GNATprove mode, do not replace the node with an exception raised.
-- In such a case, either the call to Compile_Time_Constraint_Error
-- issues an error which stops analysis, or it issues a warning in
-- a few cases where a suitable check flag is set for GNATprove to
-- generate a check message.
if not Rep or GNATprove_Mode then
return;
end if;
-- Now we replace the node by an N_Raise_Constraint_Error node
-- This does not need reanalyzing, so set it as analyzed now.
Rewrite (N, R_Stat);
Set_Analyzed (N, True);
Set_Etype (N, Rtyp);
Set_Raises_Constraint_Error (N);
-- Now deal with possible local raise handling
Possible_Local_Raise (N, Standard_Constraint_Error);
-- If the original expression was marked as static, the result is
-- still marked as static, but the Raises_Constraint_Error flag is
-- always set so that further static evaluation is not attempted.
if Stat then
Set_Is_Static_Expression (N);
end if;
end Apply_Compile_Time_Constraint_Error;
---------------------------
-- Async_Readers_Enabled --
---------------------------
function Async_Readers_Enabled (Id : Entity_Id) return Boolean is
begin
return Has_Enabled_Property (Id, Name_Async_Readers);
end Async_Readers_Enabled;
---------------------------
-- Async_Writers_Enabled --
---------------------------
function Async_Writers_Enabled (Id : Entity_Id) return Boolean is
begin
return Has_Enabled_Property (Id, Name_Async_Writers);
end Async_Writers_Enabled;
--------------------------------------
-- Available_Full_View_Of_Component --
--------------------------------------
function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
ST : constant Entity_Id := Scope (T);
SCT : constant Entity_Id := Scope (Component_Type (T));
begin
return In_Open_Scopes (ST)
and then In_Open_Scopes (SCT)
and then Scope_Depth (ST) >= Scope_Depth (SCT);
end Available_Full_View_Of_Component;
-------------------
-- Bad_Attribute --
-------------------
procedure Bad_Attribute
(N : Node_Id;
Nam : Name_Id;
Warn : Boolean := False)
is
begin
Error_Msg_Warn := Warn;
Error_Msg_N ("unrecognized attribute&<<", N);
-- Check for possible misspelling
Error_Msg_Name_1 := First_Attribute_Name;
while Error_Msg_Name_1 <= Last_Attribute_Name loop
if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then
Error_Msg_N -- CODEFIX
("\possible misspelling of %<<", N);
exit;
end if;
Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
end loop;
end Bad_Attribute;
--------------------------------
-- Bad_Predicated_Subtype_Use --
--------------------------------
procedure Bad_Predicated_Subtype_Use
(Msg : String;
N : Node_Id;
Typ : Entity_Id;
Suggest_Static : Boolean := False)
is
Gen : Entity_Id;
begin
-- Avoid cascaded errors
if Error_Posted (N) then
return;
end if;
if Inside_A_Generic then
Gen := Current_Scope;
while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop
Gen := Scope (Gen);
end loop;
if No (Gen) then
return;
end if;
if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then
Set_No_Predicate_On_Actual (Typ);
end if;
elsif Has_Predicates (Typ) then
if Is_Generic_Actual_Type (Typ) then
-- The restriction on loop parameters is only that the type
-- should have no dynamic predicates.
if Nkind (Parent (N)) = N_Loop_Parameter_Specification
and then not Has_Dynamic_Predicate_Aspect (Typ)
and then Is_OK_Static_Subtype (Typ)
then
return;
end if;
Gen := Current_Scope;
while not Is_Generic_Instance (Gen) loop
Gen := Scope (Gen);
end loop;
pragma Assert (Present (Gen));
if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_FE (Msg & "<<", N, Typ);
Error_Msg_F ("\Program_Error [<<", N);
Insert_Action (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Bad_Predicated_Generic_Type));
else
Error_Msg_FE (Msg & "<<", N, Typ);
end if;
else
Error_Msg_FE (Msg, N, Typ);
end if;
-- Emit an optional suggestion on how to remedy the error if the
-- context warrants it.
if Suggest_Static and then Has_Static_Predicate (Typ) then
Error_Msg_FE ("\predicate of & should be marked static", N, Typ);
end if;
end if;
end Bad_Predicated_Subtype_Use;
-----------------------------------------
-- Bad_Unordered_Enumeration_Reference --
-----------------------------------------
function Bad_Unordered_Enumeration_Reference
(N : Node_Id;
T : Entity_Id) return Boolean
is
begin
return Is_Enumeration_Type (T)
and then Warn_On_Unordered_Enumeration_Type
and then not Is_Generic_Type (T)
and then Comes_From_Source (N)
and then not Has_Pragma_Ordered (T)
and then not In_Same_Extended_Unit (N, T);
end Bad_Unordered_Enumeration_Reference;
----------------------------
-- Begin_Keyword_Location --
----------------------------
function Begin_Keyword_Location (N : Node_Id) return Source_Ptr is
HSS : Node_Id;
begin
pragma Assert (Nkind_In (N, N_Block_Statement,
N_Entry_Body,
N_Package_Body,
N_Subprogram_Body,
N_Task_Body));
HSS := Handled_Statement_Sequence (N);
-- When the handled sequence of statements comes from source, the
-- location of the "begin" keyword is that of the sequence itself.
-- Note that an internal construct may inherit a source sequence.
if Comes_From_Source (HSS) then
return Sloc (HSS);
-- The parser generates an internal handled sequence of statements to
-- capture the location of the "begin" keyword if present in the source.
-- Since there are no source statements, the location of the "begin"
-- keyword is effectively that of the "end" keyword.
elsif Comes_From_Source (N) then
return Sloc (HSS);
-- Otherwise the construct is internal and should carry the location of
-- the original construct which prompted its creation.
else
return Sloc (N);
end if;
end Begin_Keyword_Location;
--------------------------
-- Build_Actual_Subtype --
--------------------------
function Build_Actual_Subtype
(T : Entity_Id;
N : Node_Or_Entity_Id) return Node_Id
is
Loc : Source_Ptr;
-- Normally Sloc (N), but may point to corresponding body in some cases
Constraints : List_Id;
Decl : Node_Id;
Discr : Entity_Id;
Hi : Node_Id;
Lo : Node_Id;
Subt : Entity_Id;
Disc_Type : Entity_Id;
Obj : Node_Id;
begin
Loc := Sloc (N);
if Nkind (N) = N_Defining_Identifier then
Obj := New_Occurrence_Of (N, Loc);
-- If this is a formal parameter of a subprogram declaration, and
-- we are compiling the body, we want the declaration for the
-- actual subtype to carry the source position of the body, to
-- prevent anomalies in gdb when stepping through the code.
if Is_Formal (N) then
declare
Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
begin
if Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
then
Loc := Sloc (Corresponding_Body (Decl));
end if;
end;
end if;
else
Obj := N;
end if;
if Is_Array_Type (T) then
Constraints := New_List;
for J in 1 .. Number_Dimensions (T) loop
-- Build an array subtype declaration with the nominal subtype and
-- the bounds of the actual. Add the declaration in front of the
-- local declarations for the subprogram, for analysis before any
-- reference to the formal in the body.
Lo :=
Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, J)));
Hi :=
Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, J)));
Append (Make_Range (Loc, Lo, Hi), Constraints);
end loop;
-- If the type has unknown discriminants there is no constrained
-- subtype to build. This is never called for a formal or for a
-- lhs, so returning the type is ok ???
elsif Has_Unknown_Discriminants (T) then
return T;
else
Constraints := New_List;
-- Type T is a generic derived type, inherit the discriminants from
-- the parent type.
if Is_Private_Type (T)
and then No (Full_View (T))
-- T was flagged as an error if it was declared as a formal
-- derived type with known discriminants. In this case there
-- is no need to look at the parent type since T already carries
-- its own discriminants.
and then not Error_Posted (T)
then
Disc_Type := Etype (Base_Type (T));
else
Disc_Type := T;
end if;
Discr := First_Discriminant (Disc_Type);
while Present (Discr) loop
Append_To (Constraints,
Make_Selected_Component (Loc,
Prefix =>
Duplicate_Subexpr_No_Checks (Obj),
Selector_Name => New_Occurrence_Of (Discr, Loc)));
Next_Discriminant (Discr);
end loop;
end if;
Subt := Make_Temporary (Loc, 'S', Related_Node => N);
Set_Is_Internal (Subt);
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Subt,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (T, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constraints)));
Mark_Rewrite_Insertion (Decl);
return Decl;
end Build_Actual_Subtype;
---------------------------------------
-- Build_Actual_Subtype_Of_Component --
---------------------------------------
function Build_Actual_Subtype_Of_Component
(T : Entity_Id;
N : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
P : constant Node_Id := Prefix (N);
D : Elmt_Id;
Id : Node_Id;
Index_Typ : Entity_Id;
Desig_Typ : Entity_Id;
-- This is either a copy of T, or if T is an access type, then it is
-- the directly designated type of this access type.
function Build_Actual_Array_Constraint return List_Id;
-- If one or more of the bounds of the component depends on
-- discriminants, build actual constraint using the discriminants
-- of the prefix.
function Build_Actual_Record_Constraint return List_Id;
-- Similar to previous one, for discriminated components constrained
-- by the discriminant of the enclosing object.
-----------------------------------
-- Build_Actual_Array_Constraint --
-----------------------------------
function Build_Actual_Array_Constraint return List_Id is
Constraints : constant List_Id := New_List;
Indx : Node_Id;
Hi : Node_Id;
Lo : Node_Id;
Old_Hi : Node_Id;
Old_Lo : Node_Id;
begin
Indx := First_Index (Desig_Typ);
while Present (Indx) loop
Old_Lo := Type_Low_Bound (Etype (Indx));
Old_Hi := Type_High_Bound (Etype (Indx));
if Denotes_Discriminant (Old_Lo) then
Lo :=
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (P),
Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
else
Lo := New_Copy_Tree (Old_Lo);
-- The new bound will be reanalyzed in the enclosing
-- declaration. For literal bounds that come from a type
-- declaration, the type of the context must be imposed, so
-- insure that analysis will take place. For non-universal
-- types this is not strictly necessary.
Set_Analyzed (Lo, False);
end if;
if Denotes_Discriminant (Old_Hi) then
Hi :=
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (P),
Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
else
Hi := New_Copy_Tree (Old_Hi);
Set_Analyzed (Hi, False);
end if;
Append (Make_Range (Loc, Lo, Hi), Constraints);
Next_Index (Indx);
end loop;
return Constraints;
end Build_Actual_Array_Constraint;
------------------------------------
-- Build_Actual_Record_Constraint --
------------------------------------
function Build_Actual_Record_Constraint return List_Id is
Constraints : constant List_Id := New_List;
D : Elmt_Id;
D_Val : Node_Id;
begin
D := First_Elmt (Discriminant_Constraint (Desig_Typ));
while Present (D) loop
if Denotes_Discriminant (Node (D)) then
D_Val := Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (P),
Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
else
D_Val := New_Copy_Tree (Node (D));
end if;
Append (D_Val, Constraints);
Next_Elmt (D);
end loop;
return Constraints;
end Build_Actual_Record_Constraint;
-- Start of processing for Build_Actual_Subtype_Of_Component
begin
-- Why the test for Spec_Expression mode here???
if In_Spec_Expression then
return Empty;
-- More comments for the rest of this body would be good ???
elsif Nkind (N) = N_Explicit_Dereference then
if Is_Composite_Type (T)
and then not Is_Constrained (T)
and then not (Is_Class_Wide_Type (T)
and then Is_Constrained (Root_Type (T)))
and then not Has_Unknown_Discriminants (T)
then
-- If the type of the dereference is already constrained, it is an
-- actual subtype.
if Is_Array_Type (Etype (N))
and then Is_Constrained (Etype (N))
then
return Empty;
else
Remove_Side_Effects (P);
return Build_Actual_Subtype (T, N);
end if;
else
return Empty;
end if;
end if;
if Ekind (T) = E_Access_Subtype then
Desig_Typ := Designated_Type (T);
else
Desig_Typ := T;
end if;
if Ekind (Desig_Typ) = E_Array_Subtype then
Id := First_Index (Desig_Typ);
while Present (Id) loop
Index_Typ := Underlying_Type (Etype (Id));
if Denotes_Discriminant (Type_Low_Bound (Index_Typ))
or else
Denotes_Discriminant (Type_High_Bound (Index_Typ))
then
Remove_Side_Effects (P);
return
Build_Component_Subtype
(Build_Actual_Array_Constraint, Loc, Base_Type (T));
end if;
Next_Index (Id);
end loop;
elsif Is_Composite_Type (Desig_Typ)
and then Has_Discriminants (Desig_Typ)
and then not Has_Unknown_Discriminants (Desig_Typ)
then
if Is_Private_Type (Desig_Typ)
and then No (Discriminant_Constraint (Desig_Typ))
then
Desig_Typ := Full_View (Desig_Typ);
end if;
D := First_Elmt (Discriminant_Constraint (Desig_Typ));
while Present (D) loop
if Denotes_Discriminant (Node (D)) then
Remove_Side_Effects (P);
return
Build_Component_Subtype (
Build_Actual_Record_Constraint, Loc, Base_Type (T));
end if;
Next_Elmt (D);
end loop;
end if;
-- If none of the above, the actual and nominal subtypes are the same
return Empty;
end Build_Actual_Subtype_Of_Component;
---------------------------------
-- Build_Class_Wide_Clone_Body --
---------------------------------
procedure Build_Class_Wide_Clone_Body
(Spec_Id : Entity_Id;
Bod : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Bod);
Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id);
Clone_Body : Node_Id;
begin
-- The declaration of the class-wide clone was created when the
-- corresponding class-wide condition was analyzed.
Clone_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Subprogram_Spec (Parent (Clone_Id)),
Declarations => Declarations (Bod),
Handled_Statement_Sequence => Handled_Statement_Sequence (Bod));
-- The new operation is internal and overriding indicators do not apply
-- (the original primitive may have carried one).
Set_Must_Override (Specification (Clone_Body), False);
-- If the subprogram body is the proper body of a stub, insert the
-- subprogram after the stub, i.e. the same declarative region as
-- the original sugprogram.
if Nkind (Parent (Bod)) = N_Subunit then
Insert_After (Corresponding_Stub (Parent (Bod)), Clone_Body);
else
Insert_Before (Bod, Clone_Body);
end if;
Analyze (Clone_Body);
end Build_Class_Wide_Clone_Body;
---------------------------------
-- Build_Class_Wide_Clone_Call --
---------------------------------
function Build_Class_Wide_Clone_Call
(Loc : Source_Ptr;
Decls : List_Id;
Spec_Id : Entity_Id;
Spec : Node_Id) return Node_Id
is
Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id);
Par_Type : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
Actuals : List_Id;
Call : Node_Id;
Formal : Entity_Id;
New_Body : Node_Id;
New_F_Spec : Entity_Id;
New_Formal : Entity_Id;
begin
Actuals := Empty_List;
Formal := First_Formal (Spec_Id);
New_F_Spec := First (Parameter_Specifications (Spec));
-- Build parameter association for call to class-wide clone.
while Present (Formal) loop
New_Formal := Defining_Identifier (New_F_Spec);
-- If controlling argument and operation is inherited, add conversion
-- to parent type for the call.
if Etype (Formal) = Par_Type
and then not Is_Empty_List (Decls)
then
Append_To (Actuals,
Make_Type_Conversion (Loc,
New_Occurrence_Of (Par_Type, Loc),
New_Occurrence_Of (New_Formal, Loc)));
else
Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
end if;
Next_Formal (Formal);
Next (New_F_Spec);
end loop;
if Ekind (Spec_Id) = E_Procedure then
Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Clone_Id, Loc),
Parameter_Associations => Actuals);
else
Call :=
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Clone_Id, Loc),
Parameter_Associations => Actuals));
end if;
New_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Subprogram_Spec (Spec),
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Call),
End_Label => Make_Identifier (Loc, Chars (Spec_Id))));
return New_Body;
end Build_Class_Wide_Clone_Call;
---------------------------------
-- Build_Class_Wide_Clone_Decl --
---------------------------------
procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Spec_Id);
Clone_Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_External_Name (Chars (Spec_Id), Suffix => "CL"));
Decl : Node_Id;
Spec : Node_Id;
begin
Spec := Copy_Subprogram_Spec (Parent (Spec_Id));
Set_Must_Override (Spec, False);
Set_Must_Not_Override (Spec, False);
Set_Defining_Unit_Name (Spec, Clone_Id);
Decl := Make_Subprogram_Declaration (Loc, Spec);
Append (Decl, List_Containing (Unit_Declaration_Node (Spec_Id)));
-- Link clone to original subprogram, for use when building body and
-- wrapper call to inherited operation.
Set_Class_Wide_Clone (Spec_Id, Clone_Id);
end Build_Class_Wide_Clone_Decl;
-----------------------------
-- Build_Component_Subtype --
-----------------------------
function Build_Component_Subtype
(C : List_Id;
Loc : Source_Ptr;
T : Entity_Id) return Node_Id
is
Subt : Entity_Id;
Decl : Node_Id;
begin
-- Unchecked_Union components do not require component subtypes
if Is_Unchecked_Union (T) then
return Empty;
end if;
Subt := Make_Temporary (Loc, 'S');
Set_Is_Internal (Subt);
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Subt,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => C)));
Mark_Rewrite_Insertion (Decl);
return Decl;
end Build_Component_Subtype;
---------------------------
-- Build_Default_Subtype --
---------------------------
function Build_Default_Subtype
(T : Entity_Id;
N : Node_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (N);
Disc : Entity_Id;
Bas : Entity_Id;
-- The base type that is to be constrained by the defaults
begin
if not Has_Discriminants (T) or else Is_Constrained (T) then
return T;
end if;
Bas := Base_Type (T);
-- If T is non-private but its base type is private, this is the
-- completion of a subtype declaration whose parent type is private
-- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
-- are to be found in the full view of the base. Check that the private
-- status of T and its base differ.
if Is_Private_Type (Bas)
and then not Is_Private_Type (T)
and then Present (Full_View (Bas))
then
Bas := Full_View (Bas);
end if;
Disc := First_Discriminant (T);
if No (Discriminant_Default_Value (Disc)) then
return T;
end if;
declare
Act : constant Entity_Id := Make_Temporary (Loc, 'S');
Constraints : constant List_Id := New_List;
Decl : Node_Id;
begin
while Present (Disc) loop
Append_To (Constraints,
New_Copy_Tree (Discriminant_Default_Value (Disc)));
Next_Discriminant (Disc);
end loop;
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Act,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Bas, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constraints)));
Insert_Action (N, Decl);
-- If the context is a component declaration the subtype declaration
-- will be analyzed when the enclosing type is frozen, otherwise do
-- it now.
if Ekind (Current_Scope) /= E_Record_Type then
Analyze (Decl);
end if;
return Act;
end;
end Build_Default_Subtype;
--------------------------------------------
-- Build_Discriminal_Subtype_Of_Component --
--------------------------------------------
function Build_Discriminal_Subtype_Of_Component
(T : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (T);
D : Elmt_Id;
Id : Node_Id;
function Build_Discriminal_Array_Constraint return List_Id;
-- If one or more of the bounds of the component depends on
-- discriminants, build actual constraint using the discriminants
-- of the prefix.
function Build_Discriminal_Record_Constraint return List_Id;
-- Similar to previous one, for discriminated components constrained by
-- the discriminant of the enclosing object.
----------------------------------------
-- Build_Discriminal_Array_Constraint --
----------------------------------------
function Build_Discriminal_Array_Constraint return List_Id is
Constraints : constant List_Id := New_List;
Indx : Node_Id;
Hi : Node_Id;
Lo : Node_Id;
Old_Hi : Node_Id;
Old_Lo : Node_Id;
begin
Indx := First_Index (T);
while Present (Indx) loop
Old_Lo := Type_Low_Bound (Etype (Indx));
Old_Hi := Type_High_Bound (Etype (Indx));
if Denotes_Discriminant (Old_Lo) then
Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
else
Lo := New_Copy_Tree (Old_Lo);
end if;
if Denotes_Discriminant (Old_Hi) then
Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
else
Hi := New_Copy_Tree (Old_Hi);
end if;
Append (Make_Range (Loc, Lo, Hi), Constraints);
Next_Index (Indx);
end loop;
return Constraints;
end Build_Discriminal_Array_Constraint;
-----------------------------------------
-- Build_Discriminal_Record_Constraint --
-----------------------------------------
function Build_Discriminal_Record_Constraint return List_Id is
Constraints : constant List_Id := New_List;
D : Elmt_Id;
D_Val : Node_Id;
begin
D := First_Elmt (Discriminant_Constraint (T));
while Present (D) loop
if Denotes_Discriminant (Node (D)) then
D_Val :=
New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
else
D_Val := New_Copy_Tree (Node (D));
end if;
Append (D_Val, Constraints);
Next_Elmt (D);
end loop;
return Constraints;
end Build_Discriminal_Record_Constraint;
-- Start of processing for Build_Discriminal_Subtype_Of_Component
begin
if Ekind (T) = E_Array_Subtype then
Id := First_Index (T);
while Present (Id) loop
if Denotes_Discriminant (Type_Low_Bound (Etype (Id)))
or else
Denotes_Discriminant (Type_High_Bound (Etype (Id)))
then
return Build_Component_Subtype
(Build_Discriminal_Array_Constraint, Loc, T);
end if;
Next_Index (Id);
end loop;
elsif Ekind (T) = E_Record_Subtype
and then Has_Discriminants (T)
and then not Has_Unknown_Discriminants (T)
then
D := First_Elmt (Discriminant_Constraint (T));
while Present (D) loop
if Denotes_Discriminant (Node (D)) then
return Build_Component_Subtype
(Build_Discriminal_Record_Constraint, Loc, T);
end if;
Next_Elmt (D);
end loop;
end if;
-- If none of the above, the actual and nominal subtypes are the same
return Empty;
end Build_Discriminal_Subtype_Of_Component;
------------------------------
-- Build_Elaboration_Entity --
------------------------------
procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Decl : Node_Id;
Elab_Ent : Entity_Id;
procedure Set_Package_Name (Ent : Entity_Id);
-- Given an entity, sets the fully qualified name of the entity in
-- Name_Buffer, with components separated by double underscores. This
-- is a recursive routine that climbs the scope chain to Standard.
----------------------
-- Set_Package_Name --
----------------------
procedure Set_Package_Name (Ent : Entity_Id) is
begin
if Scope (Ent) /= Standard_Standard then
Set_Package_Name (Scope (Ent));
declare
Nam : constant String := Get_Name_String (Chars (Ent));
begin
Name_Buffer (Name_Len + 1) := '_';
Name_Buffer (Name_Len + 2) := '_';
Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
Name_Len := Name_Len + Nam'Length + 2;
end;
else
Get_Name_String (Chars (Ent));
end if;
end Set_Package_Name;
-- Start of processing for Build_Elaboration_Entity
begin
-- Ignore call if already constructed
if Present (Elaboration_Entity (Spec_Id)) then
return;
-- Ignore in ASIS mode, elaboration entity is not in source and plays
-- no role in analysis.
elsif ASIS_Mode then
return;
-- Do not generate an elaboration entity in GNATprove move because the
-- elaboration counter is a form of expansion.
elsif GNATprove_Mode then
return;
-- See if we need elaboration entity
-- We always need an elaboration entity when preserving control flow, as
-- we want to remain explicit about the unit's elaboration order.
elsif Opt.Suppress_Control_Flow_Optimizations then
null;
-- We always need an elaboration entity for the dynamic elaboration
-- model, since it is needed to properly generate the PE exception for
-- access before elaboration.
elsif Dynamic_Elaboration_Checks then
null;
-- For the static model, we don't need the elaboration counter if this
-- unit is sure to have no elaboration code, since that means there
-- is no elaboration unit to be called. Note that we can't just decide
-- after the fact by looking to see whether there was elaboration code,
-- because that's too late to make this decision.
elsif Restriction_Active (No_Elaboration_Code) then
return;
-- Similarly, for the static model, we can skip the elaboration counter
-- if we have the No_Multiple_Elaboration restriction, since for the
-- static model, that's the only purpose of the counter (to avoid
-- multiple elaboration).
elsif Restriction_Active (No_Multiple_Elaboration) then
return;
end if;
-- Here we need the elaboration entity
-- Construct name of elaboration entity as xxx_E, where xxx is the unit
-- name with dots replaced by double underscore. We have to manually
-- construct this name, since it will be elaborated in the outer scope,
-- and thus will not have the unit name automatically prepended.
Set_Package_Name (Spec_Id);
Add_Str_To_Name_Buffer ("_E");
-- Create elaboration counter
Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
Set_Elaboration_Entity (Spec_Id, Elab_Ent);
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Elab_Ent,
Object_Definition =>
New_Occurrence_Of (Standard_Short_Integer, Loc),
Expression => Make_Integer_Literal (Loc, Uint_0));
Push_Scope (Standard_Standard);
Add_Global_Declaration (Decl);
Pop_Scope;
-- Reset True_Constant indication, since we will indeed assign a value
-- to the variable in the binder main. We also kill the Current_Value
-- and Last_Assignment fields for the same reason.
Set_Is_True_Constant (Elab_Ent, False);
Set_Current_Value (Elab_Ent, Empty);
Set_Last_Assignment (Elab_Ent, Empty);
-- We do not want any further qualification of the name (if we did not
-- do this, we would pick up the name of the generic package in the case
-- of a library level generic instantiation).
Set_Has_Qualified_Name (Elab_Ent);
Set_Has_Fully_Qualified_Name (Elab_Ent);
end Build_Elaboration_Entity;
--------------------------------
-- Build_Explicit_Dereference --
--------------------------------
procedure Build_Explicit_Dereference
(Expr : Node_Id;
Disc : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Expr);
I : Interp_Index;
It : Interp;
begin
-- An entity of a type with a reference aspect is overloaded with
-- both interpretations: with and without the dereference. Now that
-- the dereference is made explicit, set the type of the node properly,
-- to prevent anomalies in the backend. Same if the expression is an
-- overloaded function call whose return type has a reference aspect.
if Is_Entity_Name (Expr) then
Set_Etype (Expr, Etype (Entity (Expr)));
-- The designated entity will not be examined again when resolving
-- the dereference, so generate a reference to it now.
Generate_Reference (Entity (Expr), Expr);
elsif Nkind (Expr) = N_Function_Call then
-- If the name of the indexing function is overloaded, locate the one
-- whose return type has an implicit dereference on the desired
-- discriminant, and set entity and type of function call.
if Is_Overloaded (Name (Expr)) then
Get_First_Interp (Name (Expr), I, It);
while Present (It.Nam) loop
if Ekind ((It.Typ)) = E_Record_Type
and then First_Entity ((It.Typ)) = Disc
then
Set_Entity (Name (Expr), It.Nam);
Set_Etype (Name (Expr), Etype (It.Nam));
exit;
end if;
Get_Next_Interp (I, It);
end loop;
end if;
-- Set type of call from resolved function name.
Set_Etype (Expr, Etype (Name (Expr)));
end if;
Set_Is_Overloaded (Expr, False);
-- The expression will often be a generalized indexing that yields a
-- container element that is then dereferenced, in which case the
-- generalized indexing call is also non-overloaded.
if Nkind (Expr) = N_Indexed_Component
and then Present (Generalized_Indexing (Expr))
then
Set_Is_Overloaded (Generalized_Indexing (Expr), False);
end if;
Rewrite (Expr,
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Expr),
Selector_Name => New_Occurrence_Of (Disc, Loc))));
Set_Etype (Prefix (Expr), Etype (Disc));
Set_Etype (Expr, Designated_Type (Etype (Disc)));
end Build_Explicit_Dereference;
---------------------------
-- Build_Overriding_Spec --
---------------------------
function Build_Overriding_Spec
(Op : Entity_Id;
Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Par_Typ : constant Entity_Id := Find_Dispatching_Type (Op);
Spec : constant Node_Id := Specification (Unit_Declaration_Node (Op));
Formal_Spec : Node_Id;
Formal_Type : Node_Id;
New_Spec : Node_Id;
begin
New_Spec := Copy_Subprogram_Spec (Spec);
Formal_Spec := First (Parameter_Specifications (New_Spec));
while Present (Formal_Spec) loop
Formal_Type := Parameter_Type (Formal_Spec);
if Is_Entity_Name (Formal_Type)
and then Entity (Formal_Type) = Par_Typ
then
Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc));
end if;
-- Nothing needs to be done for access parameters
Next (Formal_Spec);
end loop;
return New_Spec;
end Build_Overriding_Spec;
-----------------------------------
-- Cannot_Raise_Constraint_Error --
-----------------------------------
function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
begin
if Compile_Time_Known_Value (Expr) then
return True;
elsif Do_Range_Check (Expr) then
return False;
elsif Raises_Constraint_Error (Expr) then
return False;
else
case Nkind (Expr) is
when N_Identifier =>
return True;
when N_Expanded_Name =>
return True;
when N_Selected_Component =>
return not Do_Discriminant_Check (Expr);
when N_Attribute_Reference =>
if Do_Overflow_Check (Expr) then
return False;
elsif No (Expressions (Expr)) then
return True;
else
declare
N : Node_Id;
begin
N := First (Expressions (Expr));
while Present (N) loop
if Cannot_Raise_Constraint_Error (N) then
Next (N);
else
return False;
end if;
end loop;
return True;
end;
end if;
when N_Type_Conversion =>
if Do_Overflow_Check (Expr)
or else Do_Length_Check (Expr)
or else Do_Tag_Check (Expr)
then
return False;
else
return Cannot_Raise_Constraint_Error (Expression (Expr));
end if;
when N_Unchecked_Type_Conversion =>
return Cannot_Raise_Constraint_Error (Expression (Expr));
when N_Unary_Op =>
if Do_Overflow_Check (Expr) then
return False;
else
return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
end if;
when N_Op_Divide
| N_Op_Mod
| N_Op_Rem
=>
if Do_Division_Check (Expr)
or else
Do_Overflow_Check (Expr)
then
return False;
else
return
Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
and then
Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
end if;
when N_Op_Add
| N_Op_And
| N_Op_Concat
| N_Op_Eq
| N_Op_Expon
| N_Op_Ge
| N_Op_Gt
| N_Op_Le
| N_Op_Lt
| N_Op_Multiply
| N_Op_Ne
| N_Op_Or
| N_Op_Rotate_Left
| N_Op_Rotate_Right
| N_Op_Shift_Left
| N_Op_Shift_Right
| N_Op_Shift_Right_Arithmetic
| N_Op_Subtract
| N_Op_Xor
=>
if Do_Overflow_Check (Expr) then
return False;
else
return
Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
and then
Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
end if;
when others =>
return False;
end case;
end if;
end Cannot_Raise_Constraint_Error;
-----------------------------------------
-- Check_Dynamically_Tagged_Expression --
-----------------------------------------
procedure Check_Dynamically_Tagged_Expression
(Expr : Node_Id;
Typ : Entity_Id;
Related_Nod : Node_Id)
is
begin
pragma Assert (Is_Tagged_Type (Typ));
-- In order to avoid spurious errors when analyzing the expanded code,
-- this check is done only for nodes that come from source and for
-- actuals of generic instantiations.
if (Comes_From_Source (Related_Nod)
or else In_Generic_Actual (Expr))
and then (Is_Class_Wide_Type (Etype (Expr))
or else Is_Dynamically_Tagged (Expr))
and then not Is_Class_Wide_Type (Typ)
then
Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
end if;
end Check_Dynamically_Tagged_Expression;
--------------------------
-- Check_Fully_Declared --
--------------------------
procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
begin
if Ekind (T) = E_Incomplete_Type then
-- Ada 2005 (AI-50217): If the type is available through a limited
-- with_clause, verify that its full view has been analyzed.
if From_Limited_With (T)
and then Present (Non_Limited_View (T))
and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
then
-- The non-limited view is fully declared
null;
else
Error_Msg_NE
("premature usage of incomplete}", N, First_Subtype (T));
end if;
-- Need comments for these tests ???
elsif Has_Private_Component (T)
and then not Is_Generic_Type (Root_Type (T))
and then not In_Spec_Expression
then
-- Special case: if T is the anonymous type created for a single
-- task or protected object, use the name of the source object.
if Is_Concurrent_Type (T)
and then not Comes_From_Source (T)
and then Nkind (N) = N_Object_Declaration
then
Error_Msg_NE
("type of& has incomplete component",
N, Defining_Identifier (N));
else
Error_Msg_NE
("premature usage of incomplete}",
N, First_Subtype (T));
end if;
end if;
end Check_Fully_Declared;
-------------------------------------------
-- Check_Function_With_Address_Parameter --
-------------------------------------------
procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is
F : Entity_Id;
T : Entity_Id;
begin
F := First_Formal (Subp_Id);
while Present (F) loop
T := Etype (F);
if Is_Private_Type (T) and then Present (Full_View (T)) then
T := Full_View (T);
end if;
if Is_Descendant_Of_Address (T) or else Is_Limited_Type (T) then
Set_Is_Pure (Subp_Id, False);
exit;
end if;
Next_Formal (F);
end loop;
end Check_Function_With_Address_Parameter;
-------------------------------------
-- Check_Function_Writable_Actuals --
-------------------------------------
procedure Check_Function_Writable_Actuals (N : Node_Id) is
Writable_Actuals_List : Elist_Id := No_Elist;
Identifiers_List : Elist_Id := No_Elist;
Aggr_Error_Node : Node_Id := Empty;
Error_Node : Node_Id := Empty;
procedure Collect_Identifiers (N : Node_Id);
-- In a single traversal of subtree N collect in Writable_Actuals_List
-- all the actuals of functions with writable actuals, and in the list
-- Identifiers_List collect all the identifiers that are not actuals of
-- functions with writable actuals. If a writable actual is referenced
-- twice as writable actual then Error_Node is set to reference its
-- second occurrence, the error is reported, and the tree traversal
-- is abandoned.
procedure Preanalyze_Without_Errors (N : Node_Id);
-- Preanalyze N without reporting errors. Very dubious, you can't just
-- go analyzing things more than once???
-------------------------
-- Collect_Identifiers --
-------------------------
procedure Collect_Identifiers (N : Node_Id) is
function Check_Node (N : Node_Id) return Traverse_Result;
-- Process a single node during the tree traversal to collect the
-- writable actuals of functions and all the identifiers which are
-- not writable actuals of functions.
function Contains (List : Elist_Id; N : Node_Id) return Boolean;
-- Returns True if List has a node whose Entity is Entity (N)
----------------
-- Check_Node --
----------------
function Check_Node (N : Node_Id) return Traverse_Result is
Is_Writable_Actual : Boolean := False;
Id : Entity_Id;
begin
if Nkind (N) = N_Identifier then
-- No analysis possible if the entity is not decorated
if No (Entity (N)) then
return Skip;
-- Don't collect identifiers of packages, called functions, etc
elsif Ekind_In (Entity (N), E_Package,
E_Function,
E_Procedure,
E_Entry)
then
return Skip;
-- For rewritten nodes, continue the traversal in the original
-- subtree. Needed to handle aggregates in original expressions
-- extracted from the tree by Remove_Side_Effects.
elsif Is_Rewrite_Substitution (N) then
Collect_Identifiers (Original_Node (N));
return Skip;
-- For now we skip aggregate discriminants, since they require
-- performing the analysis in two phases to identify conflicts:
-- first one analyzing discriminants and second one analyzing
-- the rest of components (since at run time, discriminants are
-- evaluated prior to components): too much computation cost
-- to identify a corner case???
elsif Nkind (Parent (N)) = N_Component_Association
and then Nkind_In (Parent (Parent (N)),
N_Aggregate,
N_Extension_Aggregate)
then
declare
Choice : constant Node_Id := First (Choices (Parent (N)));
begin
if Ekind (Entity (N)) = E_Discriminant then
return Skip;
elsif Expression (Parent (N)) = N
and then Nkind (Choice) = N_Identifier
and then Ekind (Entity (Choice)) = E_Discriminant
then
return Skip;
end if;
end;
-- Analyze if N is a writable actual of a function
elsif Nkind (Parent (N)) = N_Function_Call then
declare
Call : constant Node_Id := Parent (N);
Actual : Node_Id;
Formal : Node_Id;
begin
Id := Get_Called_Entity (Call);
-- In case of previous error, no check is possible
if No (Id) then
return Abandon;
end if;
if Ekind_In (Id, E_Function, E_Generic_Function)
and then Has_Out_Or_In_Out_Parameter (Id)
then
Formal := First_Formal (Id);
Actual := First_Actual (Call);
while Present (Actual) and then Present (Formal) loop
if Actual = N then
if Ekind_In (Formal, E_Out_Parameter,
E_In_Out_Parameter)
then
Is_Writable_Actual := True;
end if;
exit;
end if;
Next_Formal (Formal);
Next_Actual (Actual);
end loop;
end if;
end;
end if;
if Is_Writable_Actual then
-- Skip checking the error in non-elementary types since
-- RM 6.4.1(6.15/3) is restricted to elementary types, but
-- store this actual in Writable_Actuals_List since it is
-- needed to perform checks on other constructs that have
-- arbitrary order of evaluation (for example, aggregates).
if not Is_Elementary_Type (Etype (N)) then
if not Contains (Writable_Actuals_List, N) then
Append_New_Elmt (N, To => Writable_Actuals_List);
end if;
-- Second occurrence of an elementary type writable actual
elsif Contains (Writable_Actuals_List, N) then
-- Report the error on the second occurrence of the
-- identifier. We cannot assume that N is the second
-- occurrence (according to their location in the
-- sources), since Traverse_Func walks through Field2
-- last (see comment in the body of Traverse_Func).
declare
Elmt : Elmt_Id;
begin
Elmt := First_Elmt (Writable_Actuals_List);
while Present (Elmt)
and then Entity (Node (Elmt)) /= Entity (N)
loop
Next_Elmt (Elmt);
end loop;
if Sloc (N) > Sloc (Node (Elmt)) then
Error_Node := N;
else
Error_Node := Node (Elmt);
end if;
Error_Msg_NE
("value may be affected by call to & "
& "because order of evaluation is arbitrary",
Error_Node, Id);
return Abandon;
end;
-- First occurrence of a elementary type writable actual
else
Append_New_Elmt (N, To => Writable_Actuals_List);
end if;
else
if Identifiers_List = No_Elist then
Identifiers_List := New_Elmt_List;
end if;
Append_Unique_Elmt (N, Identifiers_List);
end if;
end if;
return OK;
end Check_Node;
--------------
-- Contains --
--------------
function Contains
(List : Elist_Id;
N : Node_Id) return Boolean
is
pragma Assert (Nkind (N) in N_Has_Entity);
Elmt : Elmt_Id;
begin
if List = No_Elist then
return False;
end if;
Elmt := First_Elmt (List);
while Present (Elmt) loop
if Entity (Node (Elmt)) = Entity (N) then
return True;
else
Next_Elmt (Elmt);
end if;
end loop;
return False;
end Contains;
------------------
-- Do_Traversal --
------------------
procedure Do_Traversal is new Traverse_Proc (Check_Node);
-- The traversal procedure
-- Start of processing for Collect_Identifiers
begin
if Present (Error_Node) then
return;
end if;
if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then
return;
end if;
Do_Traversal (N);
end Collect_Identifiers;
-------------------------------
-- Preanalyze_Without_Errors --
-------------------------------
procedure Preanalyze_Without_Errors (N : Node_Id) is
Status : constant Boolean := Get_Ignore_Errors;
begin
Set_Ignore_Errors (True);
Preanalyze (N);
Set_Ignore_Errors (Status);
end Preanalyze_Without_Errors;
-- Start of processing for Check_Function_Writable_Actuals
begin
-- The check only applies to Ada 2012 code on which Check_Actuals has
-- been set, and only to constructs that have multiple constituents
-- whose order of evaluation is not specified by the language.
if Ada_Version < Ada_2012
or else not Check_Actuals (N)
or else (not (Nkind (N) in N_Op)
and then not (Nkind (N) in N_Membership_Test)
and then not Nkind_In (N, N_Range,
N_Aggregate,
N_Extension_Aggregate,
N_Full_Type_Declaration,
N_Function_Call,
N_Procedure_Call_Statement,
N_Entry_Call_Statement))
or else (Nkind (N) = N_Full_Type_Declaration
and then not Is_Record_Type (Defining_Identifier (N)))
-- In addition, this check only applies to source code, not to code
-- generated by constraint checks.
or else not Comes_From_Source (N)
then
return;
end if;
-- If a construct C has two or more direct constituents that are names
-- or expressions whose evaluation may occur in an arbitrary order, at
-- least one of which contains a function call with an in out or out
-- parameter, then the construct is legal only if: for each name N that
-- is passed as a parameter of mode in out or out to some inner function
-- call C2 (not including the construct C itself), there is no other
-- name anywhere within a direct constituent of the construct C other
-- than the one containing C2, that is known to refer to the same
-- object (RM 6.4.1(6.17/3)).
case Nkind (N) is
when N_Range =>
Collect_Identifiers (Low_Bound (N));
Collect_Identifiers (High_Bound (N));
when N_Membership_Test
| N_Op
=>
declare
Expr : Node_Id;
begin
Collect_Identifiers (Left_Opnd (N));
if Present (Right_Opnd (N)) then
Collect_Identifiers (Right_Opnd (N));
end if;
if Nkind_In (N, N_In, N_Not_In)
and then Present (Alternatives (N))
then
Expr := First (Alternatives (N));
while Present (Expr) loop
Collect_Identifiers (Expr);
Next (Expr);
end loop;
end if;
end;
when N_Full_Type_Declaration =>
declare
function Get_Record_Part (N : Node_Id) return Node_Id;
-- Return the record part of this record type definition
function Get_Record_Part (N : Node_Id) return Node_Id is
Type_Def : constant Node_Id := Type_Definition (N);
begin
if Nkind (Type_Def) = N_Derived_Type_Definition then
return Record_Extension_Part (Type_Def);
else
return Type_Def;
end if;
end Get_Record_Part;
Comp : Node_Id;
Def_Id : Entity_Id := Defining_Identifier (N);
Rec : Node_Id := Get_Record_Part (N);
begin
-- No need to perform any analysis if the record has no
-- components
if No (Rec) or else No (Component_List (Rec)) then
return;
end if;
-- Collect the identifiers starting from the deepest
-- derivation. Done to report the error in the deepest
-- derivation.
loop
if Present (Component_List (Rec)) then
Comp := First (Component_Items (Component_List (Rec)));
while Present (Comp) loop
if Nkind (Comp) = N_Component_Declaration
and then Present (Expression (Comp))
then
Collect_Identifiers (Expression (Comp));
end if;
Next (Comp);
end loop;
end if;
exit when No (Underlying_Type (Etype (Def_Id)))
or else Base_Type (Underlying_Type (Etype (Def_Id)))
= Def_Id;
Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
Rec := Get_Record_Part (Parent (Def_Id));
end loop;
end;
when N_Entry_Call_Statement
| N_Subprogram_Call
=>
declare
Id : constant Entity_Id := Get_Called_Entity (N);
Formal : Node_Id;
Actual : Node_Id;
begin
Formal := First_Formal (Id);
Actual := First_Actual (N);
while Present (Actual) and then Present (Formal) loop
if Ekind_In (Formal, E_Out_Parameter,
E_In_Out_Parameter)
then
Collect_Identifiers (Actual);
end if;
Next_Formal (Formal);
Next_Actual (Actual);
end loop;
end;
when N_Aggregate
| N_Extension_Aggregate
=>
declare
Assoc : Node_Id;
Choice : Node_Id;
Comp_Expr : Node_Id;
begin
-- Handle the N_Others_Choice of array aggregates with static
-- bounds. There is no need to perform this analysis in
-- aggregates without static bounds since we cannot evaluate
-- if the N_Others_Choice covers several elements. There is
-- no need to handle the N_Others choice of record aggregates
-- since at this stage it has been already expanded by
-- Resolve_Record_Aggregate.
if Is_Array_Type (Etype (N))
and then Nkind (N) = N_Aggregate
and then Present (Aggregate_Bounds (N))
and then Compile_Time_Known_Bounds (Etype (N))
and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
>
Expr_Value (Low_Bound (Aggregate_Bounds (N)))
then
declare
Count_Components : Uint := Uint_0;
Num_Components : Uint;
Others_Assoc : Node_Id;
Others_Choice : Node_Id := Empty;
Others_Box_Present : Boolean := False;
begin
-- Count positional associations
if Present (Expressions (N)) then
Comp_Expr := First (Expressions (N));
while Present (Comp_Expr) loop
Count_Components := Count_Components + 1;
Next (Comp_Expr);
end loop;
end if;
-- Count the rest of elements and locate the N_Others
-- choice (if any)
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
Choice := First (Choices (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Others_Assoc := Assoc;
Others_Choice := Choice;
Others_Box_Present := Box_Present (Assoc);
-- Count several components
elsif Nkind_In (Choice, N_Range,
N_Subtype_Indication)
or else (Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice)))
then
declare
L, H : Node_Id;
begin
Get_Index_Bounds (Choice, L, H);
pragma Assert
(Compile_Time_Known_Value (L)
and then Compile_Time_Known_Value (H));
Count_Components :=
Count_Components
+ Expr_Value (H) - Expr_Value (L) + 1;
end;
-- Count single component. No other case available
-- since we are handling an aggregate with static
-- bounds.
else
pragma Assert (Is_OK_Static_Expression (Choice)
or else Nkind (Choice) = N_Identifier
or else Nkind (Choice) = N_Integer_Literal);
Count_Components := Count_Components + 1;
end if;
Next (Choice);
end loop;
Next (Assoc);
end loop;
Num_Components :=
Expr_Value (High_Bound (Aggregate_Bounds (N))) -
Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
pragma Assert (Count_Components <= Num_Components);
-- Handle the N_Others choice if it covers several
-- components
if Present (Others_Choice)
and then (Num_Components - Count_Components) > 1
then
if not Others_Box_Present then
-- At this stage, if expansion is active, the
-- expression of the others choice has not been
-- analyzed. Hence we generate a duplicate and
-- we analyze it silently to have available the
-- minimum decoration required to collect the
-- identifiers.
if not Expander_Active then
Comp_Expr := Expression (Others_Assoc);
else
Comp_Expr :=
New_Copy_Tree (Expression (Others_Assoc));
Preanalyze_Without_Errors (Comp_Expr);
end if;
Collect_Identifiers (Comp_Expr);
if Writable_Actuals_List /= No_Elist then
-- As suggested by Robert, at current stage we
-- report occurrences of this case as warnings.
Error_Msg_N
("writable function parameter may affect "
& "value in other component because order "
& "of evaluation is unspecified??",
Node (First_Elmt (Writable_Actuals_List)));
end if;
end if;
end if;
end;
-- For an array aggregate, a discrete_choice_list that has
-- a nonstatic range is considered as two or more separate
-- occurrences of the expression (RM 6.4.1(20/3)).
elsif Is_Array_Type (Etype (N))
and then Nkind (N) = N_Aggregate
and then Present (Aggregate_Bounds (N))
and then not Compile_Time_Known_Bounds (Etype (N))
then
-- Collect identifiers found in the dynamic bounds
declare
Count_Components : Natural := 0;
Low, High : Node_Id;
begin
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
Choice := First (Choices (Assoc));
while Present (Choice) loop
if Nkind_In (Choice, N_Range,
N_Subtype_Indication)
or else (Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice)))
then
Get_Index_Bounds (Choice, Low, High);
if not Compile_Time_Known_Value (Low) then
Collect_Identifiers (Low);
if No (Aggr_Error_Node) then
Aggr_Error_Node := Low;
end if;
end if;
if not Compile_Time_Known_Value (High) then
Collect_Identifiers (High);
if No (Aggr_Error_Node) then
Aggr_Error_Node := High;
end if;
end if;
-- The RM rule is violated if there is more than
-- a single choice in a component association.
else
Count_Components := Count_Components + 1;
if No (Aggr_Error_Node)
and then Count_Components > 1
then
Aggr_Error_Node := Choice;
end if;
if not Compile_Time_Known_Value (Choice) then
Collect_Identifiers (Choice);
end if;
end if;
Next (Choice);
end loop;
Next (Assoc);
end loop;
end;
end if;
-- Handle ancestor part of extension aggregates
if Nkind (N) = N_Extension_Aggregate then
Collect_Identifiers (Ancestor_Part (N));
end if;
-- Handle positional associations
if Present (Expressions (N)) then
Comp_Expr := First (Expressions (N));
while Present (Comp_Expr) loop
if not Is_OK_Static_Expression (Comp_Expr) then
Collect_Identifiers (Comp_Expr);
end if;
Next (Comp_Expr);
end loop;
end if;
-- Handle discrete associations
if Present (Component_Associations (N)) then
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
if not Box_Present (Assoc) then
Choice := First (Choices (Assoc));
while Present (Choice) loop
-- For now we skip discriminants since it requires
-- performing the analysis in two phases: first one
-- analyzing discriminants and second one analyzing
-- the rest of components since discriminants are
-- evaluated prior to components: too much extra
-- work to detect a corner case???
if Nkind (Choice) in N_Has_Entity
and then Present (Entity (Choice))
and then Ekind (Entity (Choice)) = E_Discriminant
then
null;
elsif Box_Present (Assoc) then
null;
else
if not Analyzed (Expression (Assoc)) then
Comp_Expr :=
New_Copy_Tree (Expression (Assoc));
Set_Parent (Comp_Expr, Parent (N));
Preanalyze_Without_Errors (Comp_Expr);
else
Comp_Expr := Expression (Assoc);
end if;
Collect_Identifiers (Comp_Expr);
end if;
Next (Choice);
end loop;
end if;
Next (Assoc);
end loop;
end if;
end;
when others =>
return;
end case;
-- No further action needed if we already reported an error
if Present (Error_Node) then
return;
end if;
-- Check violation of RM 6.20/3 in aggregates
if Present (Aggr_Error_Node)
and then Writable_Actuals_List /= No_Elist
then
Error_Msg_N
("value may be affected by call in other component because they "
& "are evaluated in unspecified order",
Node (First_Elmt (Writable_Actuals_List)));
return;
end if;
-- Check if some writable argument of a function is referenced
if Writable_Actuals_List /= No_Elist
and then Identifiers_List /= No_Elist
then
declare
Elmt_1 : Elmt_Id;
Elmt_2 : Elmt_Id;
begin
Elmt_1 := First_Elmt (Writable_Actuals_List);
while Present (Elmt_1) loop
Elmt_2 := First_Elmt (Identifiers_List);
while Present (Elmt_2) loop
if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
case Nkind (Parent (Node (Elmt_2))) is
when N_Aggregate
| N_Component_Association
| N_Component_Declaration
=>
Error_Msg_N
("value may be affected by call in other "
& "component because they are evaluated "
& "in unspecified order",
Node (Elmt_2));
when N_In
| N_Not_In
=>
Error_Msg_N
("value may be affected by call in other "
& "alternative because they are evaluated "
& "in unspecified order",
Node (Elmt_2));
when others =>
Error_Msg_N
("value of actual may be affected by call in "
& "other actual because they are evaluated "
& "in unspecified order",
Node (Elmt_2));
end case;
end if;
Next_Elmt (Elmt_2);
end loop;
Next_Elmt (Elmt_1);
end loop;
end;
end if;
end Check_Function_Writable_Actuals;
--------------------------------
-- Check_Implicit_Dereference --
--------------------------------
procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is
Disc : Entity_Id;
Desig : Entity_Id;
Nam : Node_Id;
begin
if Nkind (N) = N_Indexed_Component
and then Present (Generalized_Indexing (N))
then
Nam := Generalized_Indexing (N);
else
Nam := N;
end if;
if Ada_Version < Ada_2012
or else not Has_Implicit_Dereference (Base_Type (Typ))
then
return;
elsif not Comes_From_Source (N)
and then Nkind (N) /= N_Indexed_Component
then
return;
elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then
null;
else
Disc := First_Discriminant (Typ);
while Present (Disc) loop
if Has_Implicit_Dereference (Disc) then
Desig := Designated_Type (Etype (Disc));
Add_One_Interp (Nam, Disc, Desig);
-- If the node is a generalized indexing, add interpretation
-- to that node as well, for subsequent resolution.
if Nkind (N) = N_Indexed_Component then
Add_One_Interp (N, Disc, Desig);
end if;
-- If the operation comes from a generic unit and the context
-- is a selected component, the selector name may be global
-- and set in the instance already. Remove the entity to
-- force resolution of the selected component, and the
-- generation of an explicit dereference if needed.
if In_Instance
and then Nkind (Parent (Nam)) = N_Selected_Component
then
Set_Entity (Selector_Name (Parent (Nam)), Empty);
end if;
exit;
end if;
Next_Discriminant (Disc);
end loop;
end if;
end Check_Implicit_Dereference;
----------------------------------
-- Check_Internal_Protected_Use --
----------------------------------
procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
S : Entity_Id;
Prot : Entity_Id;
begin
Prot := Empty;
S := Current_Scope;
while Present (S) loop
if S = Standard_Standard then
exit;
elsif Ekind (S) = E_Function
and then Ekind (Scope (S)) = E_Protected_Type
then
Prot := Scope (S);
exit;
end if;
S := Scope (S);
end loop;
if Present (Prot)
and then Scope (Nam) = Prot
and then Ekind (Nam) /= E_Function
then
-- An indirect function call (e.g. a callback within a protected
-- function body) is not statically illegal. If the access type is
-- anonymous and is the type of an access parameter, the scope of Nam
-- will be the protected type, but it is not a protected operation.
if Ekind (Nam) = E_Subprogram_Type
and then Nkind (Associated_Node_For_Itype (Nam)) =
N_Function_Specification
then
null;
elsif Nkind (N) = N_Subprogram_Renaming_Declaration then
Error_Msg_N
("within protected function cannot use protected procedure in "
& "renaming or as generic actual", N);
elsif Nkind (N) = N_Attribute_Reference then
Error_Msg_N
("within protected function cannot take access of protected "
& "procedure", N);
else
Error_Msg_N
("within protected function, protected object is constant", N);
Error_Msg_N
("\cannot call operation that may modify it", N);
end if;
end if;
-- Verify that an internal call does not appear within a precondition
-- of a protected operation. This implements AI12-0166.
-- The precondition aspect has been rewritten as a pragma Precondition
-- and we check whether the scope of the called subprogram is the same
-- as that of the entity to which the aspect applies.
if Convention (Nam) = Convention_Protected then
declare
P : Node_Id;
begin
P := Parent (N);
while Present (P) loop
if Nkind (P) = N_Pragma
and then Chars (Pragma_Identifier (P)) = Name_Precondition
and then From_Aspect_Specification (P)
and then
Scope (Entity (Corresponding_Aspect (P))) = Scope (Nam)
then
Error_Msg_N
("internal call cannot appear in precondition of "
& "protected operation", N);
return;
elsif Nkind (P) = N_Pragma
and then Chars (Pragma_Identifier (P)) = Name_Contract_Cases
then
-- Check whether call is in a case guard. It is legal in a
-- consequence.
P := N;
while Present (P) loop
if Nkind (Parent (P)) = N_Component_Association
and then P /= Expression (Parent (P))
then
Error_Msg_N
("internal call cannot appear in case guard in a "
& "contract case", N);
end if;
P := Parent (P);
end loop;
return;
elsif Nkind (P) = N_Parameter_Specification
and then Scope (Current_Scope) = Scope (Nam)
and then Nkind_In (Parent (P), N_Entry_Declaration,
N_Subprogram_Declaration)
then
Error_Msg_N
("internal call cannot appear in default for formal of "
& "protected operation", N);
return;
end if;
P := Parent (P);
end loop;
end;
end if;
end Check_Internal_Protected_Use;
---------------------------------------
-- Check_Later_Vs_Basic_Declarations --
---------------------------------------
procedure Check_Later_Vs_Basic_Declarations
(Decls : List_Id;
During_Parsing : Boolean)
is
Body_Sloc : Source_Ptr;
Decl : Node_Id;
function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
-- Return whether Decl is considered as a declarative item.
-- When During_Parsing is True, the semantics of Ada 83 is followed.
-- When During_Parsing is False, the semantics of SPARK is followed.
-------------------------------
-- Is_Later_Declarative_Item --
-------------------------------
function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
begin
if Nkind (Decl) in N_Later_Decl_Item then
return True;
elsif Nkind (Decl) = N_Pragma then
return True;
elsif During_Parsing then
return False;
-- In SPARK, a package declaration is not considered as a later
-- declarative item.
elsif Nkind (Decl) = N_Package_Declaration then
return False;
-- In SPARK, a renaming is considered as a later declarative item
elsif Nkind (Decl) in N_Renaming_Declaration then
return True;
else
return False;
end if;
end Is_Later_Declarative_Item;
-- Start of processing for Check_Later_Vs_Basic_Declarations
begin
Decl := First (Decls);
-- Loop through sequence of basic declarative items
Outer : while Present (Decl) loop
if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
and then Nkind (Decl) not in N_Body_Stub
then
Next (Decl);
-- Once a body is encountered, we only allow later declarative
-- items. The inner loop checks the rest of the list.
else
Body_Sloc := Sloc (Decl);
Inner : while Present (Decl) loop
if not Is_Later_Declarative_Item (Decl) then
if During_Parsing then
if Ada_Version = Ada_83 then
Error_Msg_Sloc := Body_Sloc;
Error_Msg_N
("(Ada 83) decl cannot appear after body#", Decl);
end if;
else
Error_Msg_Sloc := Body_Sloc;
Check_SPARK_05_Restriction
("decl cannot appear after body#", Decl);
end if;
end if;
Next (Decl);
end loop Inner;
end if;
end loop Outer;
end Check_Later_Vs_Basic_Declarations;
---------------------------
-- Check_No_Hidden_State --
---------------------------
procedure Check_No_Hidden_State (Id : Entity_Id) is
Context : Entity_Id := Empty;
Not_Visible : Boolean := False;
Scop : Entity_Id;
begin
pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
-- Nothing to do for internally-generated abstract states and variables
-- because they do not represent the hidden state of the source unit.
if not Comes_From_Source (Id) then
return;
end if;
-- Find the proper context where the object or state appears
Scop := Scope (Id);
while Present (Scop) loop
Context := Scop;
-- Keep track of the context's visibility
Not_Visible := Not_Visible or else In_Private_Part (Context);
-- Prevent the search from going too far
if Context = Standard_Standard then
return;
-- Objects and states that appear immediately within a subprogram or
-- inside a construct nested within a subprogram do not introduce a
-- hidden state. They behave as local variable declarations.
elsif Is_Subprogram (Context) then
return;
-- When examining a package body, use the entity of the spec as it
-- carries the abstract state declarations.
elsif Ekind (Context) = E_Package_Body then
Context := Spec_Entity (Context);
end if;
-- Stop the traversal when a package subject to a null abstract state
-- has been found.
if Ekind_In (Context, E_Generic_Package, E_Package)
and then Has_Null_Abstract_State (Context)
then
exit;
end if;
Scop := Scope (Scop);
end loop;
-- At this point we know that there is at least one package with a null
-- abstract state in visibility. Emit an error message unconditionally
-- if the entity being processed is a state because the placement of the
-- related package is irrelevant. This is not the case for objects as
-- the intermediate context matters.
if Present (Context)
and then (Ekind (Id) = E_Abstract_State or else Not_Visible)
then
Error_Msg_N ("cannot introduce hidden state &", Id);
Error_Msg_NE ("\package & has null abstract state", Id, Context);
end if;
end Check_No_Hidden_State;
----------------------------------------
-- Check_Nonvolatile_Function_Profile --
----------------------------------------
procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id) is
Formal : Entity_Id;
begin
-- Inspect all formal parameters
Formal := First_Formal (Func_Id);
while Present (Formal) loop
if Is_Effectively_Volatile (Etype (Formal)) then
Error_Msg_NE
("nonvolatile function & cannot have a volatile parameter",
Formal, Func_Id);
end if;
Next_Formal (Formal);
end loop;
-- Inspect the return type
if Is_Effectively_Volatile (Etype (Func_Id)) then
Error_Msg_NE
("nonvolatile function & cannot have a volatile return type",
Result_Definition (Parent (Func_Id)), Func_Id);
end if;
end Check_Nonvolatile_Function_Profile;
-----------------------------
-- Check_Part_Of_Reference --
-----------------------------
procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is
function Is_Enclosing_Package_Body
(Body_Decl : Node_Id;
Obj_Id : Entity_Id) return Boolean;
pragma Inline (Is_Enclosing_Package_Body);
-- Determine whether package body Body_Decl or its corresponding spec
-- immediately encloses the declaration of object Obj_Id.
function Is_Internal_Declaration_Or_Body
(Decl : Node_Id) return Boolean;
pragma Inline (Is_Internal_Declaration_Or_Body);
-- Determine whether declaration or body denoted by Decl is internal
function Is_Single_Declaration_Or_Body
(Decl : Node_Id;
Conc_Typ : Entity_Id) return Boolean;
pragma Inline (Is_Single_Declaration_Or_Body);
-- Determine whether protected/task declaration or body denoted by Decl
-- belongs to single concurrent type Conc_Typ.
function Is_Single_Task_Pragma
(Prag : Node_Id;
Task_Typ : Entity_Id) return Boolean;
pragma Inline (Is_Single_Task_Pragma);
-- Determine whether pragma Prag belongs to single task type Task_Typ
-------------------------------
-- Is_Enclosing_Package_Body --
-------------------------------
function Is_Enclosing_Package_Body
(Body_Decl : Node_Id;
Obj_Id : Entity_Id) return Boolean
is
Obj_Context : Node_Id;
begin
-- Find the context of the object declaration
Obj_Context := Parent (Declaration_Node (Obj_Id));
if Nkind (Obj_Context) = N_Package_Specification then
Obj_Context := Parent (Obj_Context);
end if;
-- The object appears immediately within the package body
if Obj_Context = Body_Decl then
return True;
-- The object appears immediately within the corresponding spec
elsif Nkind (Obj_Context) = N_Package_Declaration
and then Unit_Declaration_Node (Corresponding_Spec (Body_Decl)) =
Obj_Context
then
return True;
end if;
return False;
end Is_Enclosing_Package_Body;
-------------------------------------
-- Is_Internal_Declaration_Or_Body --
-------------------------------------
function Is_Internal_Declaration_Or_Body
(Decl : Node_Id) return Boolean
is
begin
if Comes_From_Source (Decl) then
return False;
-- A body generated for an expression function which has not been
-- inserted into the tree yet (In_Spec_Expression is True) is not
-- considered internal.
elsif Nkind (Decl) = N_Subprogram_Body
and then Was_Expression_Function (Decl)
and then not In_Spec_Expression
then
return False;
end if;
return True;
end Is_Internal_Declaration_Or_Body;
-----------------------------------
-- Is_Single_Declaration_Or_Body --
-----------------------------------
function Is_Single_Declaration_Or_Body
(Decl : Node_Id;
Conc_Typ : Entity_Id) return Boolean
is
Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
begin
return
Present (Anonymous_Object (Spec_Id))
and then Anonymous_Object (Spec_Id) = Conc_Typ;
end Is_Single_Declaration_Or_Body;
---------------------------
-- Is_Single_Task_Pragma --
---------------------------
function Is_Single_Task_Pragma
(Prag : Node_Id;
Task_Typ : Entity_Id) return Boolean
is
Decl : constant Node_Id := Find_Related_Declaration_Or_Body (Prag);
begin
-- To qualify, the pragma must be associated with single task type
-- Task_Typ.
return
Is_Single_Task_Object (Task_Typ)
and then Nkind (Decl) = N_Object_Declaration
and then Defining_Entity (Decl) = Task_Typ;
end Is_Single_Task_Pragma;
-- Local variables
Conc_Obj : constant Entity_Id := Encapsulating_State (Var_Id);
Par : Node_Id;
Prag_Nam : Name_Id;
Prev : Node_Id;
-- Start of processing for Check_Part_Of_Reference
begin
-- Nothing to do when the variable was recorded, but did not become a
-- constituent of a single concurrent type.
if No (Conc_Obj) then
return;
end if;
-- Traverse the parent chain looking for a suitable context for the
-- reference to the concurrent constituent.
Prev := Ref;
Par := Parent (Prev);
while Present (Par) loop
if Nkind (Par) = N_Pragma then
Prag_Nam := Pragma_Name (Par);
-- A concurrent constituent is allowed to appear in pragmas
-- Initial_Condition and Initializes as this is part of the
-- elaboration checks for the constituent (SPARK RM 9(3)).
if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then
return;
-- When the reference appears within pragma Depends or Global,
-- check whether the pragma applies to a single task type. Note
-- that the pragma may not encapsulated by the type definition,
-- but this is still a valid context.
elsif Nam_In (Prag_Nam, Name_Depends, Name_Global)
and then Is_Single_Task_Pragma (Par, Conc_Obj)
then
return;
end if;
-- The reference appears somewhere in the definition of a single
-- concurrent type (SPARK RM 9(3)).
elsif Nkind_In (Par, N_Single_Protected_Declaration,
N_Single_Task_Declaration)
and then Defining_Entity (Par) = Conc_Obj
then
return;
-- The reference appears within the declaration or body of a single
-- concurrent type (SPARK RM 9(3)).
elsif Nkind_In (Par, N_Protected_Body,
N_Protected_Type_Declaration,
N_Task_Body,
N_Task_Type_Declaration)
and then Is_Single_Declaration_Or_Body (Par, Conc_Obj)
then
return;
-- The reference appears within the statement list of the object's
-- immediately enclosing package (SPARK RM 9(3)).
elsif Nkind (Par) = N_Package_Body
and then Nkind (Prev) = N_Handled_Sequence_Of_Statements
and then Is_Enclosing_Package_Body (Par, Var_Id)
then
return;
-- The reference has been relocated within an internally generated
-- package or subprogram. Assume that the reference is legal as the
-- real check was already performed in the original context of the
-- reference.
elsif Nkind_In (Par, N_Package_Body,
N_Package_Declaration,
N_Subprogram_Body,
N_Subprogram_Declaration)
and then Is_Internal_Declaration_Or_Body (Par)
then
return;
-- The reference has been relocated to an inlined body for GNATprove.
-- Assume that the reference is legal as the real check was already
-- performed in the original context of the reference.
elsif GNATprove_Mode
and then Nkind (Par) = N_Subprogram_Body
and then Chars (Defining_Entity (Par)) = Name_uParent
then
return;
end if;
Prev := Par;
Par := Parent (Prev);
end loop;
-- At this point it is known that the reference does not appear within a
-- legal context.
Error_Msg_NE
("reference to variable & cannot appear in this context", Ref, Var_Id);
Error_Msg_Name_1 := Chars (Var_Id);
if Is_Single_Protected_Object (Conc_Obj) then
Error_Msg_NE
("\% is constituent of single protected type &", Ref, Conc_Obj);
else
Error_Msg_NE
("\% is constituent of single task type &", Ref, Conc_Obj);
end if;
end Check_Part_Of_Reference;
------------------------------------------
-- Check_Potentially_Blocking_Operation --
------------------------------------------
procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
S : Entity_Id;
begin
-- N is one of the potentially blocking operations listed in 9.5.1(8).
-- When pragma Detect_Blocking is active, the run time will raise
-- Program_Error. Here we only issue a warning, since we generally
-- support the use of potentially blocking operations in the absence
-- of the pragma.
-- Indirect blocking through a subprogram call cannot be diagnosed
-- statically without interprocedural analysis, so we do not attempt
-- to do it here.
S := Scope (Current_Scope);
while Present (S) and then S /= Standard_Standard loop
if Is_Protected_Type (S) then
Error_Msg_N
("potentially blocking operation in protected operation??", N);
return;
end if;
S := Scope (S);
end loop;
end Check_Potentially_Blocking_Operation;
------------------------------------
-- Check_Previous_Null_Procedure --
------------------------------------
procedure Check_Previous_Null_Procedure
(Decl : Node_Id;
Prev : Entity_Id)
is
begin
if Ekind (Prev) = E_Procedure
and then Nkind (Parent (Prev)) = N_Procedure_Specification
and then Null_Present (Parent (Prev))
then
Error_Msg_Sloc := Sloc (Prev);
Error_Msg_N
("declaration cannot complete previous null procedure#", Decl);
end if;
end Check_Previous_Null_Procedure;
---------------------------------
-- Check_Result_And_Post_State --
---------------------------------
procedure Check_Result_And_Post_State (Subp_Id : Entity_Id) is
procedure Check_Result_And_Post_State_In_Pragma
(Prag : Node_Id;
Result_Seen : in out Boolean);
-- Determine whether pragma Prag mentions attribute 'Result and whether
-- the pragma contains an expression that evaluates differently in pre-
-- and post-state. Prag is a [refined] postcondition or a contract-cases
-- pragma. Result_Seen is set when the pragma mentions attribute 'Result
function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean;
-- Determine whether subprogram Subp_Id contains at least one IN OUT
-- formal parameter.
-------------------------------------------
-- Check_Result_And_Post_State_In_Pragma --
-------------------------------------------
procedure Check_Result_And_Post_State_In_Pragma
(Prag : Node_Id;
Result_Seen : in out Boolean)
is
procedure Check_Conjunct (Expr : Node_Id);
-- Check an individual conjunct in a conjunction of Boolean
-- expressions, connected by "and" or "and then" operators.
procedure Check_Conjuncts (Expr : Node_Id);
-- Apply the post-state check to every conjunct in an expression, in
-- case this is a conjunction of Boolean expressions. Otherwise apply
-- it to the expression as a whole.
procedure Check_Expression (Expr : Node_Id);
-- Perform the 'Result and post-state checks on a given expression
function Is_Function_Result (N : Node_Id) return Traverse_Result;
-- Attempt to find attribute 'Result in a subtree denoted by N
function Is_Trivial_Boolean (N : Node_Id) return Boolean;
-- Determine whether source node N denotes "True" or "False"
function Mentions_Post_State (N : Node_Id) return Boolean;
-- Determine whether a subtree denoted by N mentions any construct
-- that denotes a post-state.
procedure Check_Function_Result is
new Traverse_Proc (Is_Function_Result);
--------------------
-- Check_Conjunct --
--------------------
procedure Check_Conjunct (Expr : Node_Id) is
function Adjust_Message (Msg : String) return String;
-- Prepend a prefix to the input message Msg denoting that the
-- message applies to a conjunct in the expression, when this
-- is the case.
function Applied_On_Conjunct return Boolean;
-- Returns True if the message applies to a conjunct in the
-- expression, instead of the whole expression.
function Has_Global_Output (Subp : Entity_Id) return Boolean;
-- Returns True if Subp has an output in its Global contract
function Has_No_Output (Subp : Entity_Id) return Boolean;
-- Returns True if Subp has no declared output: no function
-- result, no output parameter, and no output in its Global
-- contract.
--------------------
-- Adjust_Message --
--------------------
function Adjust_Message (Msg : String) return String is
begin
if Applied_On_Conjunct then
return "conjunct in " & Msg;
else
return Msg;
end if;
end Adjust_Message;
-------------------------
-- Applied_On_Conjunct --
-------------------------
function Applied_On_Conjunct return Boolean is
begin
-- Expr is the conjunct of an enclosing "and" expression
return Nkind (Parent (Expr)) in N_Subexpr
-- or Expr is a conjunct of an enclosing "and then"
-- expression in a postcondition aspect that was split into
-- multiple pragmas. The first conjunct has the "and then"
-- expression as Original_Node, and other conjuncts have
-- Split_PCC set to True.
or else Nkind (Original_Node (Expr)) = N_And_Then
or else Split_PPC (Prag);
end Applied_On_Conjunct;
-----------------------
-- Has_Global_Output --
-----------------------
function Has_Global_Output (Subp : Entity_Id) return Boolean is
Global : constant Node_Id := Get_Pragma (Subp, Pragma_Global);
List : Node_Id;
Assoc : Node_Id;
begin
if No (Global) then
return False;
end if;
List := Expression (Get_Argument (Global, Subp));
-- Empty list (no global items) or single global item
-- declaration (only input items).
if Nkind_In (List, N_Null,
N_Expanded_Name,
N_Identifier,
N_Selected_Component)
then
return False;
-- Simple global list (only input items) or moded global list
-- declaration.
elsif Nkind (List) = N_Aggregate then
if Present (Expressions (List)) then
return False;
else
Assoc := First (Component_Associations (List));
while Present (Assoc) loop
if Chars (First (Choices (Assoc))) /= Name_Input then
return True;
end if;
Next (Assoc);
end loop;
return False;
end if;
-- To accommodate partial decoration of disabled SPARK
-- features, this routine may be called with illegal input.
-- If this is the case, do not raise Program_Error.
else
return False;
end if;
end Has_Global_Output;
-------------------
-- Has_No_Output --
-------------------
function Has_No_Output (Subp : Entity_Id) return Boolean is
Param : Node_Id;
begin
-- A function has its result as output
if Ekind (Subp) = E_Function then
return False;
end if;
-- An OUT or IN OUT parameter is an output
Param := First_Formal (Subp);
while Present (Param) loop
if Ekind_In (Param, E_Out_Parameter, E_In_Out_Parameter) then
return False;
end if;
Next_Formal (Param);
end loop;
-- An item of mode Output or In_Out in the Global contract is
-- an output.
if Has_Global_Output (Subp) then
return False;
end if;
return True;
end Has_No_Output;
-- Local variables
Err_Node : Node_Id;
-- Error node when reporting a warning on a (refined)
-- postcondition.
-- Start of processing for Check_Conjunct
begin
if Applied_On_Conjunct then
Err_Node := Expr;
else
Err_Node := Prag;
end if;
-- Do not report missing reference to outcome in postcondition if
-- either the postcondition is trivially True or False, or if the
-- subprogram is ghost and has no declared output.
if not Is_Trivial_Boolean (Expr)
and then not Mentions_Post_State (Expr)
and then not (Is_Ghost_Entity (Subp_Id)
and then Has_No_Output (Subp_Id))
then
if Pragma_Name (Prag) = Name_Contract_Cases then
Error_Msg_NE (Adjust_Message
("contract case does not check the outcome of calling "
& "&?T?"), Expr, Subp_Id);
elsif Pragma_Name (Prag) = Name_Refined_Post then
Error_Msg_NE (Adjust_Message
("refined postcondition does not check the outcome of "
& "calling &?T?"), Err_Node, Subp_Id);
else
Error_Msg_NE (Adjust_Message
("postcondition does not check the outcome of calling "
& "&?T?"), Err_Node, Subp_Id);
end if;
end if;
end Check_Conjunct;
---------------------
-- Check_Conjuncts --
---------------------
procedure Check_Conjuncts (Expr : Node_Id) is
begin
if Nkind_In (Expr, N_Op_And, N_And_Then) then
Check_Conjuncts (Left_Opnd (Expr));
Check_Conjuncts (Right_Opnd (Expr));
else
Check_Conjunct (Expr);
end if;
end Check_Conjuncts;
----------------------
-- Check_Expression --
----------------------
procedure Check_Expression (Expr : Node_Id) is
begin
if not Is_Trivial_Boolean (Expr) then
Check_Function_Result (Expr);
Check_Conjuncts (Expr);
end if;
end Check_Expression;
------------------------
-- Is_Function_Result --
------------------------
function Is_Function_Result (N : Node_Id) return Traverse_Result is
begin
if Is_Attribute_Result (N) then
Result_Seen := True;
return Abandon;
-- Warn on infinite recursion if call is to current function
elsif Nkind (N) = N_Function_Call
and then Is_Entity_Name (Name (N))
and then Entity (Name (N)) = Subp_Id
and then not Is_Potentially_Unevaluated (N)
then
Error_Msg_NE
("call to & within its postcondition will lead to infinite "
& "recursion?", N, Subp_Id);
return OK;
-- Continue the traversal
else
return OK;
end if;
end Is_Function_Result;
------------------------
-- Is_Trivial_Boolean --
------------------------
function Is_Trivial_Boolean (N : Node_Id) return Boolean is
begin
return
Comes_From_Source (N)
and then Is_Entity_Name (N)
and then (Entity (N) = Standard_True
or else
Entity (N) = Standard_False);
end Is_Trivial_Boolean;
-------------------------
-- Mentions_Post_State --
-------------------------
function Mentions_Post_State (N : Node_Id) return Boolean is
Post_State_Seen : Boolean := False;
function Is_Post_State (N : Node_Id) return Traverse_Result;
-- Attempt to find a construct that denotes a post-state. If this
-- is the case, set flag Post_State_Seen.
-------------------
-- Is_Post_State --
-------------------
function Is_Post_State (N : Node_Id) return Traverse_Result is
Ent : Entity_Id;
begin
if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then
Post_State_Seen := True;
return Abandon;
elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then
Ent := Entity (N);
-- Treat an undecorated reference as OK
if No (Ent)
-- A reference to an assignable entity is considered a
-- change in the post-state of a subprogram.
or else Ekind_In (Ent, E_Generic_In_Out_Parameter,
E_In_Out_Parameter,
E_Out_Parameter,
E_Variable)
-- The reference may be modified through a dereference
or else (Is_Access_Type (Etype (Ent))
and then Nkind (Parent (N)) =
N_Selected_Component)
then
Post_State_Seen := True;
return Abandon;
end if;
elsif Nkind (N) = N_Attribute_Reference then
if Attribute_Name (N) = Name_Old then
return Skip;
elsif Attribute_Name (N) = Name_Result then
Post_State_Seen := True;
return Abandon;
end if;
end if;
return OK;
end Is_Post_State;
procedure Find_Post_State is new Traverse_Proc (Is_Post_State);
-- Start of processing for Mentions_Post_State
begin
Find_Post_State (N);
return Post_State_Seen;
end Mentions_Post_State;
-- Local variables
Expr : constant Node_Id :=
Get_Pragma_Arg
(First (Pragma_Argument_Associations (Prag)));
Nam : constant Name_Id := Pragma_Name (Prag);
CCase : Node_Id;
-- Start of processing for Check_Result_And_Post_State_In_Pragma
begin
-- Examine all consequences
if Nam = Name_Contract_Cases then
CCase := First (Component_Associations (Expr));
while Present (CCase) loop
Check_Expression (Expression (CCase));
Next (CCase);
end loop;
-- Examine the expression of a postcondition
else pragma Assert (Nam_In (Nam, Name_Postcondition,
Name_Refined_Post));
Check_Expression (Expr);
end if;
end Check_Result_And_Post_State_In_Pragma;
--------------------------
-- Has_In_Out_Parameter --
--------------------------
function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is
Formal : Entity_Id;
begin
-- Traverse the formals looking for an IN OUT parameter
Formal := First_Formal (Subp_Id);
while Present (Formal) loop
if Ekind (Formal) = E_In_Out_Parameter then
return True;
end if;
Next_Formal (Formal);
end loop;
return False;
end Has_In_Out_Parameter;
-- Local variables
Items : constant Node_Id := Contract (Subp_Id);
Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
Case_Prag : Node_Id := Empty;
Post_Prag : Node_Id := Empty;
Prag : Node_Id;
Seen_In_Case : Boolean := False;
Seen_In_Post : Boolean := False;
Spec_Id : Entity_Id;
-- Start of processing for Check_Result_And_Post_State
begin
-- The lack of attribute 'Result or a post-state is classified as a
-- suspicious contract. Do not perform the check if the corresponding
-- swich is not set.
if not Warn_On_Suspicious_Contract then
return;
-- Nothing to do if there is no contract
elsif No (Items) then
return;
end if;
-- Retrieve the entity of the subprogram spec (if any)
if Nkind (Subp_Decl) = N_Subprogram_Body
and then Present (Corresponding_Spec (Subp_Decl))
then
Spec_Id := Corresponding_Spec (Subp_Decl);
elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
and then Present (Corresponding_Spec_Of_Stub (Subp_Decl))
then
Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
else
Spec_Id := Subp_Id;
end if;
-- Examine all postconditions for attribute 'Result and a post-state
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
if Nam_In (Pragma_Name_Unmapped (Prag),
Name_Postcondition, Name_Refined_Post)
and then not Error_Posted (Prag)
then
Post_Prag := Prag;
Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Post);
end if;
Prag := Next_Pragma (Prag);
end loop;
-- Examine the contract cases of the subprogram for attribute 'Result
-- and a post-state.
Prag := Contract_Test_Cases (Items);
while Present (Prag) loop
if Pragma_Name (Prag) = Name_Contract_Cases
and then not Error_Posted (Prag)
then
Case_Prag := Prag;
Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Case);
end if;
Prag := Next_Pragma (Prag);
end loop;
-- Do not emit any errors if the subprogram is not a function
if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
null;
-- Regardless of whether the function has postconditions or contract
-- cases, or whether they mention attribute 'Result, an IN OUT formal
-- parameter is always treated as a result.
elsif Has_In_Out_Parameter (Spec_Id) then
null;
-- The function has both a postcondition and contract cases and they do
-- not mention attribute 'Result.
elsif Present (Case_Prag)
and then not Seen_In_Case
and then Present (Post_Prag)
and then not Seen_In_Post
then
Error_Msg_N
("neither postcondition nor contract cases mention function "
& "result?T?", Post_Prag);
-- The function has contract cases only and they do not mention
-- attribute 'Result.
elsif Present (Case_Prag) and then not Seen_In_Case then
Error_Msg_N ("contract cases do not mention result?T?", Case_Prag);
-- The function has postconditions only and they do not mention
-- attribute 'Result.
elsif Present (Post_Prag) and then not Seen_In_Post then
Error_Msg_N
("postcondition does not mention function result?T?", Post_Prag);
end if;
end Check_Result_And_Post_State;
-----------------------------
-- Check_State_Refinements --
-----------------------------
procedure Check_State_Refinements
(Context : Node_Id;
Is_Main_Unit : Boolean := False)
is
procedure Check_Package (Pack : Node_Id);
-- Verify that all abstract states of a [generic] package denoted by its
-- declarative node Pack have proper refinement. Recursively verify the
-- visible and private declarations of the [generic] package for other
-- nested packages.
procedure Check_Packages_In (Decls : List_Id);
-- Seek out [generic] package declarations within declarative list Decls
-- and verify the status of their abstract state refinement.
function SPARK_Mode_Is_Off (N : Node_Id) return Boolean;
-- Determine whether construct N is subject to pragma SPARK_Mode Off
-------------------
-- Check_Package --
-------------------
procedure Check_Package (Pack : Node_Id) is
Body_Id : constant Entity_Id := Corresponding_Body (Pack);
Spec : constant Node_Id := Specification (Pack);
States : constant Elist_Id :=
Abstract_States (Defining_Entity (Pack));
State_Elmt : Elmt_Id;
State_Id : Entity_Id;
begin
-- Do not verify proper state refinement when the package is subject
-- to pragma SPARK_Mode Off because this disables the requirement for
-- state refinement.
if SPARK_Mode_Is_Off (Pack) then
null;
-- State refinement can only occur in a completing package body. Do
-- not verify proper state refinement when the body is subject to
-- pragma SPARK_Mode Off because this disables the requirement for
-- state refinement.
elsif Present (Body_Id)
and then SPARK_Mode_Is_Off (Unit_Declaration_Node (Body_Id))
then
null;
-- Do not verify proper state refinement when the package is an
-- instance as this check was already performed in the generic.
elsif Present (Generic_Parent (Spec)) then
null;
-- Otherwise examine the contents of the package
else
if Present (States) then
State_Elmt := First_Elmt (States);
while Present (State_Elmt) loop
State_Id := Node (State_Elmt);
-- Emit an error when a non-null state lacks any form of
-- refinement.
if not Is_Null_State (State_Id)
and then not Has_Null_Refinement (State_Id)
and then not Has_Non_Null_Refinement (State_Id)
then
Error_Msg_N ("state & requires refinement", State_Id);
end if;
Next_Elmt (State_Elmt);
end loop;
end if;
Check_Packages_In (Visible_Declarations (Spec));
Check_Packages_In (Private_Declarations (Spec));
end if;
end Check_Package;
-----------------------
-- Check_Packages_In --
-----------------------
procedure Check_Packages_In (Decls : List_Id) is
Decl : Node_Id;
begin
if Present (Decls) then
Decl := First (Decls);
while Present (Decl) loop
if Nkind_In (Decl, N_Generic_Package_Declaration,
N_Package_Declaration)
then
Check_Package (Decl);
end if;
Next (Decl);
end loop;
end if;
end Check_Packages_In;
-----------------------
-- SPARK_Mode_Is_Off --
-----------------------
function SPARK_Mode_Is_Off (N : Node_Id) return Boolean is
Id : constant Entity_Id := Defining_Entity (N);
Prag : constant Node_Id := SPARK_Pragma (Id);
begin
-- Default the mode to "off" when the context is an instance and all
-- SPARK_Mode pragmas found within are to be ignored.
if Ignore_SPARK_Mode_Pragmas (Id) then
return True;
else
return
Present (Prag)
and then Get_SPARK_Mode_From_Annotation (Prag) = Off;
end if;
end SPARK_Mode_Is_Off;
-- Start of processing for Check_State_Refinements
begin
-- A block may declare a nested package
if Nkind (Context) = N_Block_Statement then
Check_Packages_In (Declarations (Context));
-- An entry, protected, subprogram, or task body may declare a nested
-- package.
elsif Nkind_In (Context, N_Entry_Body,
N_Protected_Body,
N_Subprogram_Body,
N_Task_Body)
then
-- Do not verify proper state refinement when the body is subject to
-- pragma SPARK_Mode Off because this disables the requirement for
-- state refinement.
if not SPARK_Mode_Is_Off (Context) then
Check_Packages_In (Declarations (Context));
end if;
-- A package body may declare a nested package
elsif Nkind (Context) = N_Package_Body then
Check_Package (Unit_Declaration_Node (Corresponding_Spec (Context)));
-- Do not verify proper state refinement when the body is subject to
-- pragma SPARK_Mode Off because this disables the requirement for
-- state refinement.
if not SPARK_Mode_Is_Off (Context) then
Check_Packages_In (Declarations (Context));
end if;
-- A library level [generic] package may declare a nested package
elsif Nkind_In (Context, N_Gener