Google Git
Sign in
gnu / gcc / refs/tags/releases/gcc-7.5.0 / . / gcc / ada / sem_util.adb
blob: d461692807ef887a5efd5d9a4305d915902e706d [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ U T I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2016, 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 Exp_Ch11; use Exp_Ch11;
with Exp_Disp; use Exp_Disp;
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_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 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.
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.
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.
------------------------------
-- 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.
-- Shouldn't this be Declaration_Node???
Nod := Parent (Base_Type (Typ));
if Nkind (Nod) = N_Full_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));
else pragma Assert ((Ekind (Typ)) = E_Record_Type);
if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
Nod := Formal_Type_Definition (Parent (Typ));
else
Nod := Type_Definition (Parent (Typ));
end if;
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_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);
Set_Next_Entity (Par, S);
Set_Next_Entity (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;
--------------------------
-- 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_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;
-- 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;
-----------------------------------
-- 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_Part_Of_Reference --
-----------------------------
procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is
Conc_Typ : constant Entity_Id := Encapsulating_State (Var_Id);
Decl : Node_Id;
OK_Use : Boolean := False;
Par : Node_Id;
Prag_Nam : Name_Id;
Spec_Id : Entity_Id;
begin
-- Traverse the parent chain looking for a suitable context for the
-- reference to the concurrent constituent.
Par := Parent (Ref);
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
OK_Use := True;
exit;
-- When the reference appears within pragma Depends or Global,
-- check whether the pragma applies to a single task type. Note
-- that the pragma is not encapsulated by the type definition,
-- but this is still a valid context.
elsif Nam_In (Prag_Nam, Name_Depends, Name_Global) then
Decl := Find_Related_Declaration_Or_Body (Par);
if Nkind (Decl) = N_Object_Declaration
and then Defining_Entity (Decl) = Conc_Typ
then
OK_Use := True;
exit;
end if;
end if;
-- The reference appears somewhere in the definition of the single
-- protected/task type (SPARK RM 9.3).
elsif Nkind_In (Par, N_Single_Protected_Declaration,
N_Single_Task_Declaration)
and then Defining_Entity (Par) = Conc_Typ
then
OK_Use := True;
exit;
-- The reference appears within the expanded declaration or the body
-- of the single protected/task type (SPARK RM 9.3).
elsif Nkind_In (Par, N_Protected_Body,
N_Protected_Type_Declaration,
N_Task_Body,
N_Task_Type_Declaration)
then
Spec_Id := Unique_Defining_Entity (Par);
if Present (Anonymous_Object (Spec_Id))
and then Anonymous_Object (Spec_Id) = Conc_Typ
then
OK_Use := True;
exit;
end if;
-- 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 not Comes_From_Source (Par)
then
OK_Use := True;
exit;
-- 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
OK_Use := True;
exit;
end if;
Par := Parent (Par);
end loop;
-- The reference is illegal as it appears outside the definition or
-- body of the single protected/task type.
if not OK_Use then
Error_Msg_NE
("reference to variable & cannot appear in this context",
Ref, Var_Id);
Error_Msg_Name_1 := Chars (Var_Id);
if Ekind (Conc_Typ) = E_Protected_Type then
Error_Msg_NE
("\% is constituent of single protected type &", Ref, Conc_Typ);
else
Error_Msg_NE
("\% is constituent of single task type &", Ref, Conc_Typ);
end if;
end if;
end Check_Part_Of_Reference;
-----------------------------------------
-- 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 Is_Tagged_Type (Typ)
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.
function Get_Function_Id (Call : Node_Id) return Entity_Id;
-- Return the entity associated with the function call
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_Function_Id (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;
---------------------
-- Get_Function_Id --
---------------------
function Get_Function_Id (Call : Node_Id) return Entity_Id is
Nam : constant Node_Id := Name (Call);
Id : Entity_Id;
begin
if Nkind (Nam) = N_Explicit_Dereference then
Id := Etype (Nam);
pragma Assert (Ekind (Id) = E_Subprogram_Type);
elsif Nkind (Nam) = N_Selected_Component then
Id := Entity (Selector_Name (Nam));
elsif Nkind (Nam) = N_Indexed_Component then
Id := Entity (Selector_Name (Prefix (Nam)));
else
Id := Entity (Nam);
end if;
return Id;
end Get_Function_Id;
-------------------------------
-- 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_Function_Id (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
S := Current_Scope;
while Present (S) loop
if S = Standard_Standard then
return;
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 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;
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
function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean;
-- Determine whether the entity of a package denoted by Pkg has a null
-- abstract state.
-----------------------------
-- Has_Null_Abstract_State --
-----------------------------
function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is
States : constant Elist_Id := Abstract_States (Pkg);
begin
-- Check first available state of related package. A null abstract
-- state always appears as the sole element of the state list.
return
Present (States)
and then Is_Null_State (Node (First_Elmt (States)));
end Has_Null_Abstract_State;
-- Local variables
Context : Entity_Id := Empty;
Not_Visible : Boolean := False;
Scop : Entity_Id;
-- Start of processing for Check_No_Hidden_State
begin
pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
-- 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_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_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_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_Expression --
----------------------
procedure Check_Expression (Expr : Node_Id) is
begin
if not Is_Trivial_Boolean (Expr) then
Check_Function_Result (Expr);
if not Mentions_Post_State (Expr) then
if Pragma_Name (Prag) = Name_Contract_Cases then
Error_Msg_NE
("contract case does not check the outcome of calling "
& "&?T?", Expr, Subp_Id);
elsif Pragma_Name (Prag) = Name_Refined_Post then
Error_Msg_NE
("refined postcondition does not check the outcome of "
& "calling &?T?", Prag, Subp_Id);
else
Error_Msg_NE
("postcondition does not check the outcome of calling "
& "&?T?", Prag, Subp_Id);
end if;
end if;
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;
-- 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);
-- The entity may be modifiable through an implicit
-- dereference.
if No (Ent)
or else Ekind (Ent) in Assignable_Kind
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 packge 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
Prag : constant Node_Id := SPARK_Pragma (Defining_Entity (N));
begin
return
Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = Off;
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_Generic_Package_Declaration,
N_Package_Declaration)
and then Is_Main_Unit
then
Check_Package (Context);
end if;
end Check_State_Refinements;
------------------------------
-- Check_Unprotected_Access --
------------------------------
procedure Check_Unprotected_Access
(Context : Node_Id;
Expr : Node_Id)
is
Cont_Encl_Typ : Entity_Id;
Pref_Encl_Typ : Entity_Id;
function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
-- Check whether Obj is a private component of a protected object.
-- Return the protected type where the component resides, Empty
-- otherwise.
function Is_Public_Operation return Boolean;
-- Verify that the enclosing operation is callable from outside the
-- protected object, to minimize false positives.
------------------------------
-- Enclosing_Protected_Type --
------------------------------
function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
begin
if Is_Entity_Name (Obj) then
declare
Ent : Entity_Id := Entity (Obj);
begin
-- The object can be a renaming of a private component, use
-- the original record component.
if Is_Prival (Ent) then
Ent := Prival_Link (Ent);
end if;
if Is_Protected_Type (Scope (Ent)) then
return Scope (Ent);
end if;
end;
end if;
-- For indexed and selected components, recursively check the prefix
if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
return Enclosing_Protected_Type (Prefix (Obj));
-- The object does not denote a protected component
else
return Empty;
end if;
end Enclosing_Protected_Type;
-------------------------
-- Is_Public_Operation --
-------------------------
function Is_Public_Operation return Boolean is
S : Entity_Id;
E : Entity_Id;
begin
S := Current_Scope;
while Present (S) and then S /= Pref_Encl_Typ loop
if Scope (S) = Pref_Encl_Typ then
E := First_Entity (Pref_Encl_Typ);
while Present (E)
and then E /= First_Private_Entity (Pref_Encl_Typ)
loop
if E = S then
return True;
end if;
Next_Entity (E);
end loop;
end if;
S := Scope (S);
end loop;
return False;
end Is_Public_Operation;
-- Start of processing for Check_Unprotected_Access
begin
if Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Unchecked_Access
then
Cont_Encl_Typ := Enclosing_Protected_Type (Context);
Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
-- Check whether we are trying to export a protected component to a
-- context with an equal or lower access level.
if Present (Pref_Encl_Typ)
and then No (Cont_Encl_Typ)
and then Is_Public_Operation
and then Scope_Depth (Pref_Encl_Typ) >=
Object_Access_Level (Context)
then
Error_Msg_N
("??possible unprotected access to protected data", Expr);
end if;
end if;
end Check_Unprotected_Access;
------------------------------
-- Check_Unused_Body_States --
------------------------------
procedure Check_Unused_Body_States (Body_Id : Entity_Id) is
procedure Process_Refinement_Clause
(Clause : Node_Id;
States : Elist_Id);
-- Inspect all constituents of refinement clause Clause and remove any
-- matches from body state list States.
procedure Report_Unused_Body_States (States : Elist_Id);
-- Emit errors for each abstract state or object found in list States
-------------------------------
-- Process_Refinement_Clause --
-------------------------------
procedure Process_Refinement_Clause
(Clause : Node_Id;
States : Elist_Id)
is
procedure Process_Constituent (Constit : Node_Id);
-- Remove constituent Constit from body state list States
-------------------------
-- Process_Constituent --
-------------------------
procedure Process_Constituent (Constit : Node_Id) is
Constit_Id : Entity_Id;
begin
-- Guard against illegal constituents. Only abstract states and
-- objects can appear on the right hand side of a refinement.
if Is_Entity_Name (Constit) then
Constit_Id := Entity_Of (Constit);
if Present (Constit_Id)
and then Ekind_In (Constit_Id, E_Abstract_State,
E_Constant,
E_Variable)
then
Remove (States, Constit_Id);
end if;
end if;
end Process_Constituent;
-- Local variables
Constit : Node_Id;
-- Start of processing for Process_Refinement_Clause
begin
if Nkind (Clause) = N_Component_Association then
Constit := Expression (Clause);
-- Multiple constituents appear as an aggregate
if Nkind (Constit) = N_Aggregate then
Constit := First (Expressions (Constit));
while Present (Constit) loop
Process_Constituent (Constit);
Next (Constit);
end loop;
-- Various forms of a single constituent
else
Process_Constituent (Constit);
end if;
end if;
end Process_Refinement_Clause;
-------------------------------
-- Report_Unused_Body_States --
-------------------------------
procedure Report_Unused_Body_States (States : Elist_Id) is
Posted : Boolean := False;
State_Elmt : Elmt_Id;
State_Id : Entity_Id;
begin
if Present (States) then
State_Elmt := First_Elmt (States);
while Present (State_Elmt) loop
State_Id := Node (State_Elmt);
-- Constants are part of the hidden state of a package, but the
-- compiler cannot determine whether they have variable input
-- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
-- hidden state. Do not emit an error when a constant does not
-- participate in a state refinement, even though it acts as a
-- hidden state.
if Ekind (State_Id) = E_Constant then
null;
-- Generate an error message of the form:
-- body of package ... has unused hidden states
-- abstract state ... defined at ...
-- variable ... defined at ...
else
if not Posted then
Posted := True;
SPARK_Msg_N
("body of package & has unused hidden states", Body_Id);
end if;
Error_Msg_Sloc := Sloc (State_Id);
if Ekind (State_Id) = E_Abstract_State then
SPARK_Msg_NE
("\abstract state & defined #", Body_Id, State_Id);
else
SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id);
end if;
end if;
Next_Elmt (State_Elmt);
end loop;
end if;
end Report_Unused_Body_States;
-- Local variables
Prag : constant Node_Id := Get_Pragma (Body_Id, Pragma_Refined_State);
Spec_Id : constant Entity_Id := Spec_Entity (Body_Id);
Clause : Node_Id;
States : Elist_Id;
-- Start of processing for Check_Unused_Body_States
begin
-- Inspect the clauses of pragma Refined_State and determine whether all
-- visible states declared within the package body participate in the
-- refinement.
if Present (Prag) then
Clause := Expression (Get_Argument (Prag, Spec_Id));
States := Collect_Body_States (Body_Id);
-- Multiple non-null state refinements appear as an aggregate
if Nkind (Clause) = N_Aggregate then
Clause := First (Component_Associations (Clause));
while Present (Clause) loop
Process_Refinement_Clause (Clause, States);
Next (Clause);
end loop;
-- Various forms of a single state refinement
else
Process_Refinement_Clause (Clause, States);
end if;
-- Ensure that all abstract states and objects declared in the
-- package body state space are utilized as constituents.
Report_Unused_Body_States (States);
end if;
end Check_Unused_Body_States;
-----------------
-- Choice_List --
-----------------
function Choice_List (N : Node_Id) return List_Id is
begin
if Nkind (N) = N_Iterated_Component_Association then
return Discrete_Choices (N);
else
return Choices (N);
end if;
end Choice_List;
-------------------------
-- Collect_Body_States --
-------------------------
function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id is
function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean;
-- Determine whether object Obj_Id is a suitable visible state of a
-- package body.
procedure Collect_Visible_States
(Pack_Id : Entity_Id;
States : in out Elist_Id);
-- Gather the entities of all abstract states and objects declared in
-- the visible state space of package Pack_Id.
----------------------------
-- Collect_Visible_States --
----------------------------
procedure Collect_Visible_States
(Pack_Id : Entity_Id;
States : in out Elist_Id)
is
Item_Id : Entity_Id;
begin
-- Traverse the entity chain of the package and inspect all visible
-- items.
Item_Id := First_Entity (Pack_Id);
while Present (Item_Id) and then not In_Private_Part (Item_Id) loop
-- Do not consider internally generated items as those cannot be
-- named and participate in refinement.
if not Comes_From_Source (Item_Id) then
null;
elsif Ekind (Item_Id) = E_Abstract_State then
Append_New_Elmt (Item_Id, States);
elsif Ekind_In (Item_Id, E_Constant, E_Variable)
and then Is_Visible_Object (Item_Id)
then
Append_New_Elmt (Item_Id, States);
-- Recursively gather the visible states of a nested package
elsif Ekind (Item_Id) = E_Package then
Collect_Visible_States (Item_Id, States);
end if;
Next_Entity (Item_Id);
end loop;
end Collect_Visible_States;
-----------------------
-- Is_Visible_Object --
-----------------------
function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean is
begin
-- Objects that map generic formals to their actuals are not visible
-- from outside the generic instantiation.
if Present (Corresponding_Generic_Association
(Declaration_Node (Obj_Id)))
then
return False;
-- Constituents of a single protected/task type act as components of
-- the type and are not visible from outside the type.
elsif Ekind (Obj_Id) = E_Variable
and then Present (Encapsulating_State (Obj_Id))
and then Is_Single_Concurrent_Object (Encapsulating_State (Obj_Id))
then
return False;
else
return True;
end if;
end Is_Visible_Object;
-- Local variables
Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id);
Decl : Node_Id;
Item_Id : Entity_Id;
States : Elist_Id := No_Elist;
-- Start of processing for Collect_Body_States
begin
-- Inspect the declarations of the body looking for source objects,
-- packages and package instantiations. Note that even though this
-- processing is very similar to Collect_Visible_States, a package
-- body does not have a First/Next_Entity list.
Decl := First (Declarations (Body_Decl));
while Present (Decl) loop
-- Capture source objects as internally generated temporaries cannot
-- be named and participate in refinement.
if Nkind (Decl) = N_Object_Declaration then
Item_Id := Defining_Entity (Decl);
if Comes_From_Source (Item_Id)
and then Is_Visible_Object (Item_Id)
then
Append_New_Elmt (Item_Id, States);
end if;
-- Capture the visible abstract states and objects of a source
-- package [instantiation].
elsif Nkind (Decl) = N_Package_Declaration then
Item_Id := Defining_Entity (Decl);
if Comes_From_Source (Item_Id) then
Collect_Visible_States (Item_Id, States);
end if;
end if;
Next (Decl);
end loop;
return States;
end Collect_Body_States;
------------------------
-- Collect_Interfaces --
------------------------
procedure Collect_Interfaces
(T : Entity_Id;
Ifaces_List : out Elist_Id;
Exclude_Parents : Boolean := False;
Use_Full_View : Boolean := True)
is
procedure Collect (Typ : Entity_Id);
-- Subsidiary subprogram used to traverse the whole list
-- of directly and indirectly implemented interfaces
-------------
-- Collect --
-------------
procedure Collect (Typ : Entity_Id) is
Ancestor : Entity_Id;
Full_T : Entity_Id;
Id : Node_Id;
Iface : Entity_Id;
begin
Full_T := Typ;
-- Handle private types and subtypes
if Use_Full_View
and then Is_Private_Type (Typ)
and then Present (Full_View (Typ))
then
Full_T := Full_View (Typ);
if Ekind (Full_T) = E_Record_Subtype then
Full_T := Etype (Typ);
if Present (Full_View (Full_T)) then
Full_T := Full_View (Full_T);
end if;
end if;
end if;
-- Include the ancestor if we are generating the whole list of
-- abstract interfaces.
if Etype (Full_T) /= Typ
-- Protect the frontend against wrong sources. For example:
-- package P is
-- type A is tagged null record;
-- type B is new A with private;
-- type C is new A with private;
-- private
-- type B is new C with null record;
-- type C is new B with null record;
-- end P;
and then Etype (Full_T) /= T
then
Ancestor := Etype (Full_T);
Collect (Ancestor);
if Is_Interface (Ancestor) and then not Exclude_Parents then
Append_Unique_Elmt (Ancestor, Ifaces_List);
end if;
end if;
-- Traverse the graph of ancestor interfaces
if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
Id := First (Abstract_Interface_List (Full_T));
while Present (Id) loop
Iface := Etype (Id);
-- Protect against wrong uses. For example:
-- type I is interface;
-- type O is tagged null record;
-- type Wrong is new I and O with null record; -- ERROR
if Is_Interface (Iface) then
if Exclude_Parents
and then Etype (T) /= T
and then Interface_Present_In_Ancestor (Etype (T), Iface)
then
null;
else
Collect (Iface);
Append_Unique_Elmt (Iface, Ifaces_List);
end if;
end if;
Next (Id);
end loop;
end if;
end Collect;
-- Start of processing for Collect_Interfaces
begin
pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
Ifaces_List := New_Elmt_List;
Collect (T);
end Collect_Interfaces;
----------------------------------
-- Collect_Interface_Components --
----------------------------------
procedure Collect_Interface_Components
(Tagged_Type : Entity_Id;
Components_List : out Elist_Id)
is
procedure Collect (Typ : Entity_Id);
-- Subsidiary subprogram used to climb to the parents
-------------
-- Collect --
-------------
procedure Collect (Typ : Entity_Id) is
Tag_Comp : Entity_Id;
Parent_Typ : Entity_Id;
begin
-- Handle private types
if Present (Full_View (Etype (Typ))) then
Parent_Typ := Full_View (Etype (Typ));
else
Parent_Typ := Etype (Typ);
end if;
if Parent_Typ /= Typ
-- Protect the frontend against wrong sources. For example:
-- package P is
-- type A is tagged null record;
-- type B is new A with private;
-- type C is new A with private;
-- private
-- type B is new C with null record;
-- type C is new B with null record;
-- end P;
and then Parent_Typ /= Tagged_Type
then
Collect (Parent_Typ);
end if;
-- Collect the components containing tags of secondary dispatch
-- tables.
Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
while Present (Tag_Comp) loop
pragma Assert (Present (Related_Type (Tag_Comp)));
Append_Elmt (Tag_Comp, Components_List);
Tag_Comp := Next_Tag_Component (Tag_Comp);
end loop;
end Collect;
-- Start of processing for Collect_Interface_Components
begin
pragma Assert (Ekind (Tagged_Type) = E_Record_Type
and then Is_Tagged_Type (Tagged_Type));
Components_List := New_Elmt_List;
Collect (Tagged_Type);
end Collect_Interface_Components;
-----------------------------
-- Collect_Interfaces_Info --
-----------------------------
procedure Collect_Interfaces_Info
(T : Entity_Id;
Ifaces_List : out Elist_Id;
Components_List : out Elist_Id;
Tags_List : out Elist_Id)
is
Comps_List : Elist_Id;
Comp_Elmt : Elmt_Id;
Comp_Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
Iface : Entity_Id;
function Search_Tag (Iface : Entity_Id) return Entity_Id;
-- Search for the secondary tag associated with the interface type
-- Iface that is implemented by T.
----------------
-- Search_Tag --
----------------
function Search_Tag (Iface : Entity_Id) return Entity_Id is
ADT : Elmt_Id;
begin
if not Is_CPP_Class (T) then
ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
else
ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
end if;
while Present (ADT)
and then Is_Tag (Node (ADT))
and then Related_Type (Node (ADT)) /= Iface
loop
-- Skip secondary dispatch table referencing thunks to user
-- defined primitives covered by this interface.
pragma Assert (Has_Suffix (Node (ADT), 'P'));
Next_Elmt (ADT);
-- Skip secondary dispatch tables of Ada types
if not Is_CPP_Class (T) then
-- Skip secondary dispatch table referencing thunks to
-- predefined primitives.
pragma Assert (Has_Suffix (Node (ADT), 'Y'));
Next_Elmt (ADT);
-- Skip secondary dispatch table referencing user-defined
-- primitives covered by this interface.
pragma Assert (Has_Suffix (Node (ADT), 'D'));
Next_Elmt (ADT);
-- Skip secondary dispatch table referencing predefined
-- primitives.
pragma Assert (Has_Suffix (Node (ADT), 'Z'));
Next_Elmt (ADT);
end if;
end loop;
pragma Assert (Is_Tag (Node (ADT)));
return Node (ADT);
end Search_Tag;
-- Start of processing for Collect_Interfaces_Info
begin
Collect_Interfaces (T, Ifaces_List);
Collect_Interface_Components (T, Comps_List);
-- Search for the record component and tag associated with each
-- interface type of T.
Components_List := New_Elmt_List;
Tags_List := New_Elmt_List;
Iface_Elmt := First_Elmt (Ifaces_List);
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
-- Associate the primary tag component and the primary dispatch table
-- with all the interfaces that are parents of T
if Is_Ancestor (Iface, T, Use_Full_View => True) then
Append_Elmt (First_Tag_Component (T), Components_List);
Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
-- Otherwise search for the tag component and secondary dispatch
-- table of Iface
else
Comp_Elmt := First_Elmt (Comps_List);
while Present (Comp_Elmt) loop
Comp_Iface := Related_Type (Node (Comp_Elmt));
if Comp_Iface = Iface
or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
then
Append_Elmt (Node (Comp_Elmt), Components_List);
Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
exit;
end if;
Next_Elmt (Comp_Elmt);
end loop;
pragma Assert (Present (Comp_Elmt));
end if;
Next_Elmt (Iface_Elmt);
end loop;
end Collect_Interfaces_Info;
---------------------
-- Collect_Parents --
---------------------
procedure Collect_Parents
(T : Entity_Id;
List : out Elist_Id;
Use_Full_View : Boolean := True)
is
Current_Typ : Entity_Id := T;
Parent_Typ : Entity_Id;
begin
List := New_Elmt_List;
-- No action if the if the type has no parents
if T = Etype (T) then
return;
end if;
loop
Parent_Typ := Etype (Current_Typ);
if Is_Private_Type (Parent_Typ)
and then Present (Full_View (Parent_Typ))
and then Use_Full_View
then
Parent_Typ := Full_View (Base_Type (Parent_Typ));
end if;
Append_Elmt (Parent_Typ, List);
exit when Parent_Typ = Current_Typ;
Current_Typ := Parent_Typ;
end loop;
end Collect_Parents;
----------------------------------
-- Collect_Primitive_Operations --
----------------------------------
function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
B_Type : constant Entity_Id := Base_Type (T);
B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
B_Scope : Entity_Id := Scope (B_Type);
Op_List : Elist_Id;
Formal : Entity_Id;
Is_Prim : Boolean;
Is_Type_In_Pkg : Boolean;
Formal_Derived : Boolean := False;
Id : Entity_Id;