Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / ada / freeze.adb
blob: 7ed44f591fc207867c9fecf75196536c26a802af [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- F R E E Z E --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, 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 Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Contracts; use Contracts;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
with Exp_Disp; use Exp_Disp;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Exp_Tss; use Exp_Tss;
with Ghost; use Ghost;
with Layout; use Layout;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Strub; use Strub;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Urealp; use Urealp;
with Warnsw; use Warnsw;
package body Freeze is
-----------------------
-- Local Subprograms --
-----------------------
procedure Adjust_Esize_For_Alignment (Typ : Entity_Id);
-- Typ is a type that is being frozen. If no size clause is given,
-- but a default Esize has been computed, then this default Esize is
-- adjusted up if necessary to be consistent with a given alignment,
-- but never to a value greater than System_Max_Integer_Size. This is
-- used for all discrete types and for fixed-point types.
procedure Build_And_Analyze_Renamed_Body
(Decl : Node_Id;
New_S : Entity_Id;
After : in out Node_Id);
-- Build body for a renaming declaration, insert in tree and analyze
procedure Check_Address_Clause (E : Entity_Id);
-- Apply legality checks to address clauses for object declarations,
-- at the point the object is frozen. Also ensure any initialization is
-- performed only after the object has been frozen.
procedure Check_Component_Storage_Order
(Encl_Type : Entity_Id;
Comp : Entity_Id;
ADC : Node_Id;
Comp_ADC_Present : out Boolean);
-- For an Encl_Type that has a Scalar_Storage_Order attribute definition
-- clause, verify that the component type has an explicit and compatible
-- attribute/aspect. For arrays, Comp is Empty; for records, it is the
-- entity of the component under consideration. For an Encl_Type that
-- does not have a Scalar_Storage_Order attribute definition clause,
-- verify that the component also does not have such a clause.
-- ADC is the attribute definition clause if present (or Empty). On return,
-- Comp_ADC_Present is set True if the component has a Scalar_Storage_Order
-- attribute definition clause.
procedure Check_Debug_Info_Needed (T : Entity_Id);
-- As each entity is frozen, this routine is called to deal with the
-- setting of Debug_Info_Needed for the entity. This flag is set if
-- the entity comes from source, or if we are in Debug_Generated_Code
-- mode or if the -gnatdV debug flag is set. However, it never sets
-- the flag if Debug_Info_Off is set. This procedure also ensures that
-- subsidiary entities have the flag set as required.
procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id);
-- When an expression function is frozen by a use of it, the expression
-- itself is frozen. Check that the expression does not include references
-- to deferred constants without completion. We report this at the freeze
-- point of the function, to provide a better error message.
--
-- In most cases the expression itself is frozen by the time the function
-- itself is frozen, because the formals will be frozen by then. However,
-- Attribute references to outer types are freeze points for those types;
-- this routine generates the required freeze nodes for them.
procedure Check_Strict_Alignment (E : Entity_Id);
-- E is a base type. If E is tagged or has a component that is aliased
-- or tagged or contains something this is aliased or tagged, set
-- Strict_Alignment.
procedure Check_Unsigned_Type (E : Entity_Id);
pragma Inline (Check_Unsigned_Type);
-- If E is a fixed-point or discrete type, then all the necessary work
-- to freeze it is completed except for possible setting of the flag
-- Is_Unsigned_Type, which is done by this procedure. The call has no
-- effect if the entity E is not a discrete or fixed-point type.
procedure Freeze_And_Append
(Ent : Entity_Id;
N : Node_Id;
Result : in out List_Id);
-- Freezes Ent using Freeze_Entity, and appends the resulting list of
-- nodes to Result, modifying Result from No_List if necessary. N has
-- the same usage as in Freeze_Entity.
procedure Freeze_Enumeration_Type (Typ : Entity_Id);
-- Freeze enumeration type. The Esize field is set as processing
-- proceeds (i.e. set by default when the type is declared and then
-- adjusted by rep clauses). What this procedure does is to make sure
-- that if a foreign convention is specified, and no specific size
-- is given, then the size must be at least Integer'Size.
procedure Freeze_Static_Object (E : Entity_Id);
-- If an object is frozen which has Is_Statically_Allocated set, then
-- all referenced types must also be marked with this flag. This routine
-- is in charge of meeting this requirement for the object entity E.
procedure Freeze_Subprogram (E : Entity_Id);
-- Perform freezing actions for a subprogram (create extra formals,
-- and set proper default mechanism values). Note that this routine
-- is not called for internal subprograms, for which neither of these
-- actions is needed (or desirable, we do not want for example to have
-- these extra formals present in initialization procedures, where they
-- would serve no purpose). In this call E is either a subprogram or
-- a subprogram type (i.e. an access to a subprogram).
function Is_Fully_Defined (T : Entity_Id) return Boolean;
-- True if T is not private and has no private components, or has a full
-- view. Used to determine whether the designated type of an access type
-- should be frozen when the access type is frozen. This is done when an
-- allocator is frozen, or an expression that may involve attributes of
-- the designated type. Otherwise freezing the access type does not freeze
-- the designated type.
function Should_Freeze_Type (Typ : Entity_Id; E : Entity_Id) return Boolean;
-- If Typ is in the current scope or in an instantiation, then return True.
-- ???Expression functions (represented by E) shouldn't freeze types in
-- general, but our current expansion and freezing model requires an early
-- freezing when the dispatch table is needed or when building an aggregate
-- with a subtype of Typ, so return True also in this case.
-- Note that expression function completions do freeze and are
-- handled in Sem_Ch6.Analyze_Expression_Function.
------------------------
-- Should_Freeze_Type --
------------------------
function Should_Freeze_Type
(Typ : Entity_Id; E : Entity_Id) return Boolean
is
function Is_Dispatching_Call_Or_Aggregate
(N : Node_Id) return Traverse_Result;
-- Return Abandon if N is a dispatching call to a subprogram
-- declared in the same scope as Typ or an aggregate whose type
-- is Typ.
--------------------------------------
-- Is_Dispatching_Call_Or_Aggregate --
--------------------------------------
function Is_Dispatching_Call_Or_Aggregate
(N : Node_Id) return Traverse_Result is
begin
if Nkind (N) = N_Function_Call
and then Present (Controlling_Argument (N))
and then Scope (Entity (Original_Node (Name (N))))
= Scope (Typ)
then
return Abandon;
elsif Nkind (N) = N_Aggregate
and then Base_Type (Etype (N)) = Base_Type (Typ)
then
return Abandon;
else
return OK;
end if;
end Is_Dispatching_Call_Or_Aggregate;
-------------------------
-- Need_Dispatch_Table --
-------------------------
function Need_Dispatch_Table is new
Traverse_Func (Is_Dispatching_Call_Or_Aggregate);
-- Return Abandon if the input expression requires access to
-- Typ's dispatch table.
Decl : constant Node_Id :=
(if No (E) then E else Original_Node (Unit_Declaration_Node (E)));
-- Start of processing for Should_Freeze_Type
begin
return Within_Scope (Typ, Current_Scope)
or else In_Instance
or else (Present (Decl)
and then Nkind (Decl) = N_Expression_Function
and then Need_Dispatch_Table (Expression (Decl)) = Abandon);
end Should_Freeze_Type;
procedure Process_Default_Expressions
(E : Entity_Id;
After : in out Node_Id);
-- This procedure is called for each subprogram to complete processing of
-- default expressions at the point where all types are known to be frozen.
-- The expressions must be analyzed in full, to make sure that all error
-- processing is done (they have only been preanalyzed). If the expression
-- is not an entity or literal, its analysis may generate code which must
-- not be executed. In that case we build a function body to hold that
-- code. This wrapper function serves no other purpose (it used to be
-- called to evaluate the default, but now the default is inlined at each
-- point of call).
procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id);
-- Typ is a record or array type that is being frozen. This routine sets
-- the default component alignment from the scope stack values if the
-- alignment is otherwise not specified.
procedure Set_SSO_From_Default (T : Entity_Id);
-- T is a record or array type that is being frozen. If it is a base type,
-- and if SSO_Set_Low/High_By_Default is set, then Reverse_Storage order
-- will be set appropriately. Note that an explicit occurrence of aspect
-- Scalar_Storage_Order or an explicit setting of this aspect with an
-- attribute definition clause occurs, then these two flags are reset in
-- any case, so call will have no effect.
procedure Undelay_Type (T : Entity_Id);
-- T is a type of a component that we know to be an Itype. We don't want
-- this to have a Freeze_Node, so ensure it doesn't. Do the same for any
-- Full_View or Corresponding_Record_Type.
procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Node_Id);
-- Expr is the expression for an address clause for the entity denoted by
-- Nam whose type is Typ. If Typ has a default initialization, and there is
-- no explicit initialization in the source declaration, check whether the
-- address clause might cause overlaying of an entity, and emit a warning
-- on the side effect that the initialization will cause.
-------------------------------
-- Adjust_Esize_For_Alignment --
-------------------------------
procedure Adjust_Esize_For_Alignment (Typ : Entity_Id) is
Align : Uint;
begin
if Known_Esize (Typ) and then Known_Alignment (Typ) then
Align := Alignment_In_Bits (Typ);
if Align > Esize (Typ) and then Align <= System_Max_Integer_Size then
Set_Esize (Typ, Align);
end if;
end if;
end Adjust_Esize_For_Alignment;
------------------------------------
-- Build_And_Analyze_Renamed_Body --
------------------------------------
procedure Build_And_Analyze_Renamed_Body
(Decl : Node_Id;
New_S : Entity_Id;
After : in out Node_Id)
is
Body_Decl : constant Node_Id := Unit_Declaration_Node (New_S);
Ent : constant Entity_Id := Defining_Entity (Decl);
Body_Node : Node_Id;
Renamed_Subp : Entity_Id;
begin
-- If the renamed subprogram is intrinsic, there is no need for a
-- wrapper body: we set the alias that will be called and expanded which
-- completes the declaration. This transformation is only legal if the
-- renamed entity has already been elaborated.
-- Note that it is legal for a renaming_as_body to rename an intrinsic
-- subprogram, as long as the renaming occurs before the new entity
-- is frozen (RM 8.5.4 (5)).
if Nkind (Body_Decl) = N_Subprogram_Renaming_Declaration
and then Is_Entity_Name (Name (Body_Decl))
then
Renamed_Subp := Entity (Name (Body_Decl));
else
Renamed_Subp := Empty;
end if;
if Present (Renamed_Subp)
and then Is_Intrinsic_Subprogram (Renamed_Subp)
and then
(not In_Same_Source_Unit (Renamed_Subp, Ent)
or else Sloc (Renamed_Subp) < Sloc (Ent))
-- We can make the renaming entity intrinsic if the renamed function
-- has an interface name, or if it is one of the shift/rotate
-- operations known to the compiler.
and then
(Present (Interface_Name (Renamed_Subp))
or else Chars (Renamed_Subp) in Name_Rotate_Left
| Name_Rotate_Right
| Name_Shift_Left
| Name_Shift_Right
| Name_Shift_Right_Arithmetic)
then
Set_Interface_Name (Ent, Interface_Name (Renamed_Subp));
if Present (Alias (Renamed_Subp)) then
Set_Alias (Ent, Alias (Renamed_Subp));
else
Set_Alias (Ent, Renamed_Subp);
end if;
Set_Is_Intrinsic_Subprogram (Ent);
Set_Has_Completion (Ent);
else
Body_Node := Build_Renamed_Body (Decl, New_S);
Insert_After (After, Body_Node);
Mark_Rewrite_Insertion (Body_Node);
Analyze (Body_Node);
After := Body_Node;
end if;
end Build_And_Analyze_Renamed_Body;
------------------------
-- Build_Renamed_Body --
------------------------
function Build_Renamed_Body
(Decl : Node_Id;
New_S : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (New_S);
-- We use for the source location of the renamed body, the location of
-- the spec entity. It might seem more natural to use the location of
-- the renaming declaration itself, but that would be wrong, since then
-- the body we create would look as though it was created far too late,
-- and this could cause problems with elaboration order analysis,
-- particularly in connection with instantiations.
N : constant Node_Id := Unit_Declaration_Node (New_S);
Nam : constant Node_Id := Name (N);
Old_S : Entity_Id;
Spec : constant Node_Id := New_Copy_Tree (Specification (Decl));
Actuals : List_Id := No_List;
Call_Node : Node_Id;
Call_Name : Node_Id;
Body_Node : Node_Id;
Formal : Entity_Id;
O_Formal : Entity_Id;
Param_Spec : Node_Id;
Pref : Node_Id := Empty;
-- If the renamed entity is a primitive operation given in prefix form,
-- the prefix is the target object and it has to be added as the first
-- actual in the generated call.
begin
-- Determine the entity being renamed, which is the target of the call
-- statement. If the name is an explicit dereference, this is a renaming
-- of a subprogram type rather than a subprogram. The name itself is
-- fully analyzed.
if Nkind (Nam) = N_Selected_Component then
Old_S := Entity (Selector_Name (Nam));
elsif Nkind (Nam) = N_Explicit_Dereference then
Old_S := Etype (Nam);
elsif Nkind (Nam) = N_Indexed_Component then
if Is_Entity_Name (Prefix (Nam)) then
Old_S := Entity (Prefix (Nam));
else
Old_S := Entity (Selector_Name (Prefix (Nam)));
end if;
elsif Nkind (Nam) = N_Character_Literal then
Old_S := Etype (New_S);
else
Old_S := Entity (Nam);
end if;
if Is_Entity_Name (Nam) then
-- If the renamed entity is a predefined operator, retain full name
-- to ensure its visibility.
if Ekind (Old_S) = E_Operator
and then Nkind (Nam) = N_Expanded_Name
then
Call_Name := New_Copy (Name (N));
else
Call_Name := New_Occurrence_Of (Old_S, Loc);
end if;
else
if Nkind (Nam) = N_Selected_Component
and then Present (First_Formal (Old_S))
and then
(Is_Controlling_Formal (First_Formal (Old_S))
or else Is_Class_Wide_Type (Etype (First_Formal (Old_S))))
then
-- Retrieve the target object, to be added as a first actual
-- in the call.
Call_Name := New_Occurrence_Of (Old_S, Loc);
Pref := Prefix (Nam);
else
Call_Name := New_Copy (Name (N));
end if;
-- Original name may have been overloaded, but is fully resolved now
Set_Is_Overloaded (Call_Name, False);
end if;
-- For simple renamings, subsequent calls can be expanded directly as
-- calls to the renamed entity. The body must be generated in any case
-- for calls that may appear elsewhere. This is not done in the case
-- where the subprogram is an instantiation because the actual proper
-- body has not been built yet. This is also not done in GNATprove mode
-- as we need to check other conditions for creating a body to inline
-- in that case, which are controlled in Analyze_Subprogram_Body_Helper.
if Ekind (Old_S) in E_Function | E_Procedure
and then Nkind (Decl) = N_Subprogram_Declaration
and then not Is_Generic_Instance (Old_S)
and then not GNATprove_Mode
then
Set_Body_To_Inline (Decl, Old_S);
end if;
-- Check whether the return type is a limited view. If the subprogram
-- is already frozen the generated body may have a non-limited view
-- of the type, that must be used, because it is the one in the spec
-- of the renaming declaration.
if Ekind (Old_S) = E_Function
and then Is_Entity_Name (Result_Definition (Spec))
then
declare
Ret_Type : constant Entity_Id := Etype (Result_Definition (Spec));
begin
if Has_Non_Limited_View (Ret_Type) then
Set_Result_Definition
(Spec, New_Occurrence_Of (Non_Limited_View (Ret_Type), Loc));
end if;
end;
end if;
-- The body generated for this renaming is an internal artifact, and
-- does not constitute a freeze point for the called entity.
Set_Must_Not_Freeze (Call_Name);
Formal := First_Formal (Defining_Entity (Decl));
if Present (Pref) then
declare
Pref_Type : constant Entity_Id := Etype (Pref);
Form_Type : constant Entity_Id := Etype (First_Formal (Old_S));
begin
-- The controlling formal may be an access parameter, or the
-- actual may be an access value, so adjust accordingly.
if Is_Access_Type (Pref_Type)
and then not Is_Access_Type (Form_Type)
then
Actuals := New_List
(Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
elsif Is_Access_Type (Form_Type)
and then not Is_Access_Type (Pref)
then
Actuals :=
New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Access,
Prefix => Relocate_Node (Pref)));
else
Actuals := New_List (Pref);
end if;
end;
elsif Present (Formal) then
Actuals := New_List;
else
Actuals := No_List;
end if;
while Present (Formal) loop
Append (New_Occurrence_Of (Formal, Loc), Actuals);
Next_Formal (Formal);
end loop;
-- If the renamed entity is an entry, inherit its profile. For other
-- renamings as bodies, both profiles must be subtype conformant, so it
-- is not necessary to replace the profile given in the declaration.
-- However, default values that are aggregates are rewritten when
-- partially analyzed, so we recover the original aggregate to insure
-- that subsequent conformity checking works. Similarly, if the default
-- expression was constant-folded, recover the original expression.
Formal := First_Formal (Defining_Entity (Decl));
if Present (Formal) then
O_Formal := First_Formal (Old_S);
Param_Spec := First (Parameter_Specifications (Spec));
while Present (Formal) loop
if Is_Entry (Old_S) then
if Nkind (Parameter_Type (Param_Spec)) /=
N_Access_Definition
then
Set_Etype (Formal, Etype (O_Formal));
Set_Entity (Parameter_Type (Param_Spec), Etype (O_Formal));
end if;
elsif Nkind (Default_Value (O_Formal)) = N_Aggregate
or else Nkind (Original_Node (Default_Value (O_Formal))) /=
Nkind (Default_Value (O_Formal))
then
Set_Expression (Param_Spec,
New_Copy_Tree (Original_Node (Default_Value (O_Formal))));
end if;
Next_Formal (Formal);
Next_Formal (O_Formal);
Next (Param_Spec);
end loop;
end if;
-- If the renamed entity is a function, the generated body contains a
-- return statement. Otherwise, build a procedure call. If the entity is
-- an entry, subsequent analysis of the call will transform it into the
-- proper entry or protected operation call. If the renamed entity is
-- a character literal, return it directly.
if Ekind (Old_S) = E_Function
or else Ekind (Old_S) = E_Operator
or else (Ekind (Old_S) = E_Subprogram_Type
and then Etype (Old_S) /= Standard_Void_Type)
then
Call_Node :=
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name => Call_Name,
Parameter_Associations => Actuals));
elsif Ekind (Old_S) = E_Enumeration_Literal then
Call_Node :=
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Old_S, Loc));
elsif Nkind (Nam) = N_Character_Literal then
Call_Node :=
Make_Simple_Return_Statement (Loc, Expression => Call_Name);
else
Call_Node :=
Make_Procedure_Call_Statement (Loc,
Name => Call_Name,
Parameter_Associations => Actuals);
end if;
-- Create entities for subprogram body and formals
Set_Defining_Unit_Name (Spec,
Make_Defining_Identifier (Loc, Chars => Chars (New_S)));
Param_Spec := First (Parameter_Specifications (Spec));
while Present (Param_Spec) loop
Set_Defining_Identifier (Param_Spec,
Make_Defining_Identifier (Loc,
Chars => Chars (Defining_Identifier (Param_Spec))));
Next (Param_Spec);
end loop;
-- In GNATprove, prefer to generate an expression function whenever
-- possible, to benefit from the more precise analysis in that case
-- (as if an implicit postcondition had been generated).
if GNATprove_Mode
and then Nkind (Call_Node) = N_Simple_Return_Statement
then
Body_Node :=
Make_Expression_Function (Loc,
Specification => Spec,
Expression => Expression (Call_Node));
else
Body_Node :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Call_Node)));
end if;
if Nkind (Decl) /= N_Subprogram_Declaration then
Rewrite (N,
Make_Subprogram_Declaration (Loc,
Specification => Specification (N)));
end if;
-- Link the body to the entity whose declaration it completes. If
-- the body is analyzed when the renamed entity is frozen, it may
-- be necessary to restore the proper scope (see package Exp_Ch13).
if Nkind (N) = N_Subprogram_Renaming_Declaration
and then Present (Corresponding_Spec (N))
then
Set_Corresponding_Spec (Body_Node, Corresponding_Spec (N));
else
Set_Corresponding_Spec (Body_Node, New_S);
end if;
return Body_Node;
end Build_Renamed_Body;
--------------------------
-- Check_Address_Clause --
--------------------------
procedure Check_Address_Clause (E : Entity_Id) is
Addr : constant Node_Id := Address_Clause (E);
Typ : constant Entity_Id := Etype (E);
Decl : Node_Id;
Expr : Node_Id;
Init : Node_Id;
Lhs : Node_Id;
Tag_Assign : Node_Id;
begin
if Present (Addr) then
-- For a deferred constant, the initialization value is on full view
if Ekind (E) = E_Constant and then Present (Full_View (E)) then
Decl := Declaration_Node (Full_View (E));
else
Decl := Declaration_Node (E);
end if;
Expr := Expression (Addr);
if Needs_Constant_Address (Decl, Typ) then
Check_Constant_Address_Clause (Expr, E);
-- Has_Delayed_Freeze was set on E when the address clause was
-- analyzed, and must remain set because we want the address
-- clause to be elaborated only after any entity it references
-- has been elaborated.
end if;
-- If Rep_Clauses are to be ignored, remove address clause from
-- list attached to entity, because it may be illegal for gigi,
-- for example by breaking order of elaboration.
if Ignore_Rep_Clauses then
declare
Rep : Node_Id;
begin
Rep := First_Rep_Item (E);
if Rep = Addr then
Set_First_Rep_Item (E, Next_Rep_Item (Addr));
else
while Present (Rep)
and then Next_Rep_Item (Rep) /= Addr
loop
Next_Rep_Item (Rep);
end loop;
end if;
if Present (Rep) then
Set_Next_Rep_Item (Rep, Next_Rep_Item (Addr));
end if;
end;
-- And now remove the address clause
Kill_Rep_Clause (Addr);
elsif not Error_Posted (Expr)
and then not Needs_Finalization (Typ)
then
Warn_Overlay (Expr, Typ, Name (Addr));
end if;
Init := Expression (Decl);
-- If a variable, or a non-imported constant, overlays a constant
-- object and has an initialization value, then the initialization
-- may end up writing into read-only memory. Detect the cases of
-- statically identical values and remove the initialization. In
-- the other cases, give a warning. We will give other warnings
-- later for the variable if it is assigned.
if (Ekind (E) = E_Variable
or else (Ekind (E) = E_Constant
and then not Is_Imported (E)))
and then Overlays_Constant (E)
and then Present (Init)
then
declare
O_Ent : Entity_Id;
Off : Boolean;
begin
Find_Overlaid_Entity (Addr, O_Ent, Off);
if Ekind (O_Ent) = E_Constant
and then Etype (O_Ent) = Typ
and then Present (Constant_Value (O_Ent))
and then Compile_Time_Compare
(Init,
Constant_Value (O_Ent),
Assume_Valid => True) = EQ
then
Set_No_Initialization (Decl);
return;
elsif Comes_From_Source (Init)
and then Address_Clause_Overlay_Warnings
then
Error_Msg_Sloc := Sloc (Addr);
Error_Msg_NE
("??constant& may be modified via address clause#",
Decl, O_Ent);
end if;
end;
end if;
-- Remove side effects from initial expression, except in the case of
-- limited build-in-place calls and aggregates, which have their own
-- expansion elsewhere. This exception is necessary to avoid copying
-- limited objects.
if Present (Init)
and then not Is_Limited_View (Typ)
then
-- Capture initialization value at point of declaration, and make
-- explicit assignment legal, because object may be a constant.
Remove_Side_Effects (Init);
Lhs := New_Occurrence_Of (E, Sloc (Decl));
Set_Assignment_OK (Lhs);
-- Move initialization to freeze actions, once the object has
-- been frozen and the address clause alignment check has been
-- performed.
Append_Freeze_Action (E,
Make_Assignment_Statement (Sloc (Decl),
Name => Lhs,
Expression => Expression (Decl)));
Set_No_Initialization (Decl);
-- If the object is tagged, check whether the tag must be
-- reassigned explicitly.
Tag_Assign := Make_Tag_Assignment (Decl);
if Present (Tag_Assign) then
Append_Freeze_Action (E, Tag_Assign);
end if;
end if;
end if;
end Check_Address_Clause;
-----------------------------
-- Check_Compile_Time_Size --
-----------------------------
procedure Check_Compile_Time_Size (T : Entity_Id) is
procedure Set_Small_Size (T : Entity_Id; S : Uint);
-- Sets the compile time known size in the RM_Size field of T, checking
-- for a size clause that was given which attempts to give a small size.
function Size_Known (T : Entity_Id) return Boolean;
-- Recursive function that does all the work
function Static_Discriminated_Components (T : Entity_Id) return Boolean;
-- If T is a constrained subtype, its size is not known if any of its
-- discriminant constraints is not static and it is not a null record.
-- The test is conservative and doesn't check that the components are
-- in fact constrained by non-static discriminant values. Could be made
-- more precise ???
--------------------
-- Set_Small_Size --
--------------------
procedure Set_Small_Size (T : Entity_Id; S : Uint) is
begin
if S > System_Max_Integer_Size then
return;
-- Check for bad size clause given
elsif Has_Size_Clause (T) then
if RM_Size (T) < S then
Error_Msg_Uint_1 := S;
Error_Msg_NE (Size_Too_Small_Message, Size_Clause (T), T);
end if;
-- Set size if not set already. Do not set it to Uint_0, because in
-- some cases (notably array-of-record), the Component_Size is
-- No_Uint, which causes S to be Uint_0. Presumably the RM_Size and
-- Component_Size will eventually be set correctly by the back end.
elsif not Known_RM_Size (T) and then S /= Uint_0 then
Set_RM_Size (T, S);
end if;
end Set_Small_Size;
----------------
-- Size_Known --
----------------
function Size_Known (T : Entity_Id) return Boolean is
Comp : Entity_Id;
Ctyp : Entity_Id;
begin
if Size_Known_At_Compile_Time (T) then
return True;
-- Always True for elementary types, even generic formal elementary
-- types. We used to return False in the latter case, but the size
-- is known at compile time, even in the template, we just do not
-- know the exact size but that's not the point of this routine.
elsif Is_Elementary_Type (T) or else Is_Task_Type (T) then
return True;
-- Array types
elsif Is_Array_Type (T) then
-- String literals always have known size, and we can set it
if Ekind (T) = E_String_Literal_Subtype then
if Known_Component_Size (T) then
Set_Small_Size
(T, Component_Size (T) * String_Literal_Length (T));
else
-- The following is wrong, but does what previous versions
-- did. The Component_Size is unknown for the string in a
-- pragma Warnings.
Set_Small_Size (T, Uint_0);
end if;
return True;
-- Unconstrained types never have known at compile time size
elsif not Is_Constrained (T) then
return False;
-- Don't do any recursion on type with error posted, since we may
-- have a malformed type that leads us into a loop.
elsif Error_Posted (T) then
return False;
-- Otherwise if component size unknown, then array size unknown
elsif not Size_Known (Component_Type (T)) then
return False;
end if;
-- Check for all indexes static, and also compute possible size
-- (in case it is not greater than System_Max_Integer_Size and
-- thus may be packable).
declare
Index : Entity_Id;
Low : Node_Id;
High : Node_Id;
Size : Uint := Component_Size (T);
Dim : Uint;
begin
-- See comment in Set_Small_Size above
if No (Size) then
Size := Uint_0;
end if;
Index := First_Index (T);
while Present (Index) loop
if Nkind (Index) = N_Range then
Get_Index_Bounds (Index, Low, High);
elsif Error_Posted (Scalar_Range (Etype (Index))) then
return False;
else
Low := Type_Low_Bound (Etype (Index));
High := Type_High_Bound (Etype (Index));
end if;
if not Compile_Time_Known_Value (Low)
or else not Compile_Time_Known_Value (High)
or else Etype (Index) = Any_Type
then
return False;
else
Dim := Expr_Value (High) - Expr_Value (Low) + 1;
if Dim > Uint_0 then
Size := Size * Dim;
else
Size := Uint_0;
end if;
end if;
Next_Index (Index);
end loop;
Set_Small_Size (T, Size);
return True;
end;
-- For non-generic private types, go to underlying type if present
elsif Is_Private_Type (T)
and then not Is_Generic_Type (T)
and then Present (Underlying_Type (T))
then
-- Don't do any recursion on type with error posted, since we may
-- have a malformed type that leads us into a loop.
if Error_Posted (T) then
return False;
else
return Size_Known (Underlying_Type (T));
end if;
-- Record types
elsif Is_Record_Type (T) then
-- A class-wide type is never considered to have a known size
if Is_Class_Wide_Type (T) then
return False;
-- A subtype of a variant record must not have non-static
-- discriminated components.
elsif T /= Base_Type (T)
and then not Static_Discriminated_Components (T)
then
return False;
-- Don't do any recursion on type with error posted, since we may
-- have a malformed type that leads us into a loop.
elsif Error_Posted (T) then
return False;
end if;
-- Now look at the components of the record
declare
-- The following two variables are used to keep track of the
-- size of packed records if we can tell the size of the packed
-- record in the front end. Packed_Size_Known is True if so far
-- we can figure out the size. It is initialized to True for a
-- packed record, unless the record has either discriminants or
-- independent components, or is a strict-alignment type, since
-- it cannot be fully packed in this case.
-- The reason we eliminate the discriminated case is that
-- we don't know the way the back end lays out discriminated
-- packed records. If Packed_Size_Known is True, then
-- Packed_Size is the size in bits so far.
Packed_Size_Known : Boolean :=
Is_Packed (T)
and then not Has_Discriminants (T)
and then not Has_Independent_Components (T)
and then not Strict_Alignment (T);
Packed_Size : Uint := Uint_0;
-- Size in bits so far
begin
-- Test for variant part present
if Has_Discriminants (T)
and then Present (Parent (T))
and then Nkind (Parent (T)) = N_Full_Type_Declaration
and then Nkind (Type_Definition (Parent (T))) =
N_Record_Definition
and then not Null_Present (Type_Definition (Parent (T)))
and then
Present (Variant_Part
(Component_List (Type_Definition (Parent (T)))))
then
-- If variant part is present, and type is unconstrained,
-- then we must have defaulted discriminants, or a size
-- clause must be present for the type, or else the size
-- is definitely not known at compile time.
if not Is_Constrained (T)
and then
No (Discriminant_Default_Value (First_Discriminant (T)))
and then not Known_RM_Size (T)
then
return False;
end if;
end if;
-- Loop through components
Comp := First_Component_Or_Discriminant (T);
while Present (Comp) loop
Ctyp := Etype (Comp);
-- We do not know the packed size if there is a component
-- clause present (we possibly could, but this would only
-- help in the case of a record with partial rep clauses.
-- That's because in the case of full rep clauses, the
-- size gets figured out anyway by a different circuit).
if Present (Component_Clause (Comp)) then
Packed_Size_Known := False;
end if;
-- We do not know the packed size for an independent
-- component or if it is of a strict-alignment type,
-- since packing does not touch these (RM 13.2(7)).
if Is_Independent (Comp)
or else Is_Independent (Ctyp)
or else Strict_Alignment (Ctyp)
then
Packed_Size_Known := False;
end if;
-- We need to identify a component that is an array where
-- the index type is an enumeration type with non-standard
-- representation, and some bound of the type depends on a
-- discriminant.
-- This is because gigi computes the size by doing a
-- substitution of the appropriate discriminant value in
-- the size expression for the base type, and gigi is not
-- clever enough to evaluate the resulting expression (which
-- involves a call to rep_to_pos) at compile time.
-- It would be nice if gigi would either recognize that
-- this expression can be computed at compile time, or
-- alternatively figured out the size from the subtype
-- directly, where all the information is at hand ???
if Is_Array_Type (Etype (Comp))
and then Present (Packed_Array_Impl_Type (Etype (Comp)))
then
declare
Ocomp : constant Entity_Id :=
Original_Record_Component (Comp);
OCtyp : constant Entity_Id := Etype (Ocomp);
Ind : Node_Id;
Indtyp : Entity_Id;
Lo, Hi : Node_Id;
begin
Ind := First_Index (OCtyp);
while Present (Ind) loop
Indtyp := Etype (Ind);
if Is_Enumeration_Type (Indtyp)
and then Has_Non_Standard_Rep (Indtyp)
then
Lo := Type_Low_Bound (Indtyp);
Hi := Type_High_Bound (Indtyp);
if Is_Entity_Name (Lo)
and then Ekind (Entity (Lo)) = E_Discriminant
then
return False;
elsif Is_Entity_Name (Hi)
and then Ekind (Entity (Hi)) = E_Discriminant
then
return False;
end if;
end if;
Next_Index (Ind);
end loop;
end;
end if;
-- Clearly size of record is not known if the size of one of
-- the components is not known.
if not Size_Known (Ctyp) then
return False;
end if;
-- Accumulate packed size if possible
if Packed_Size_Known then
-- We can deal with elementary types, small packed arrays
-- if the representation is a modular type and also small
-- record types as checked by Set_Small_Size.
if Is_Elementary_Type (Ctyp)
or else (Is_Array_Type (Ctyp)
and then Present
(Packed_Array_Impl_Type (Ctyp))
and then Is_Modular_Integer_Type
(Packed_Array_Impl_Type (Ctyp)))
or else Is_Record_Type (Ctyp)
then
-- If RM_Size is known and static, then we can keep
-- accumulating the packed size.
if Known_Static_RM_Size (Ctyp) then
Packed_Size := Packed_Size + RM_Size (Ctyp);
-- If we have a field whose RM_Size is not known then
-- we can't figure out the packed size here.
else
Packed_Size_Known := False;
end if;
-- For other types we can't figure out the packed size
else
Packed_Size_Known := False;
end if;
end if;
Next_Component_Or_Discriminant (Comp);
end loop;
if Packed_Size_Known then
Set_Small_Size (T, Packed_Size);
end if;
return True;
end;
-- All other cases, size not known at compile time
else
return False;
end if;
end Size_Known;
-------------------------------------
-- Static_Discriminated_Components --
-------------------------------------
function Static_Discriminated_Components
(T : Entity_Id) return Boolean
is
Constraint : Elmt_Id;
begin
if Has_Discriminants (T)
and then Present (Discriminant_Constraint (T))
and then Present (First_Component (T))
then
Constraint := First_Elmt (Discriminant_Constraint (T));
while Present (Constraint) loop
if not Compile_Time_Known_Value (Node (Constraint)) then
return False;
end if;
Next_Elmt (Constraint);
end loop;
end if;
return True;
end Static_Discriminated_Components;
-- Start of processing for Check_Compile_Time_Size
begin
Set_Size_Known_At_Compile_Time (T, Size_Known (T));
end Check_Compile_Time_Size;
-----------------------------------
-- Check_Component_Storage_Order --
-----------------------------------
procedure Check_Component_Storage_Order
(Encl_Type : Entity_Id;
Comp : Entity_Id;
ADC : Node_Id;
Comp_ADC_Present : out Boolean)
is
Comp_Base : Entity_Id;
Comp_ADC : Node_Id;
Encl_Base : Entity_Id;
Err_Node : Node_Id;
Component_Aliased : Boolean;
Comp_Byte_Aligned : Boolean := False;
-- Set for the record case, True if Comp is aligned on byte boundaries
-- (in which case it is allowed to have different storage order).
Comp_SSO_Differs : Boolean;
-- Set True when the component is a nested composite, and it does not
-- have the same scalar storage order as Encl_Type.
begin
-- Record case
if Present (Comp) then
Err_Node := Comp;
Comp_Base := Etype (Comp);
if Is_Tag (Comp) then
Comp_Byte_Aligned := True;
Component_Aliased := False;
else
-- If a component clause is present, check if the component starts
-- and ends on byte boundaries. Otherwise conservatively assume it
-- does so only in the case where the record is not packed.
if Present (Component_Clause (Comp)) then
Comp_Byte_Aligned :=
Known_Normalized_First_Bit (Comp)
and then
Known_Esize (Comp)
and then
Normalized_First_Bit (Comp) mod System_Storage_Unit = 0
and then
Esize (Comp) mod System_Storage_Unit = 0;
else
Comp_Byte_Aligned := not Is_Packed (Encl_Type);
end if;
Component_Aliased := Is_Aliased (Comp);
end if;
-- Array case
else
Err_Node := Encl_Type;
Comp_Base := Component_Type (Encl_Type);
Component_Aliased := Has_Aliased_Components (Encl_Type);
end if;
-- Note: the Reverse_Storage_Order flag is set on the base type, but
-- the attribute definition clause is attached to the first subtype.
-- Also, if the base type is incomplete or private, go to full view
-- if known
Encl_Base := Base_Type (Encl_Type);
if Present (Underlying_Type (Encl_Base)) then
Encl_Base := Underlying_Type (Encl_Base);
end if;
Comp_Base := Base_Type (Comp_Base);
if Present (Underlying_Type (Comp_Base)) then
Comp_Base := Underlying_Type (Comp_Base);
end if;
Comp_ADC :=
Get_Attribute_Definition_Clause
(First_Subtype (Comp_Base), Attribute_Scalar_Storage_Order);
Comp_ADC_Present := Present (Comp_ADC);
-- Case of record or array component: check storage order compatibility.
-- But, if the record has Complex_Representation, then it is treated as
-- a scalar in the back end so the storage order is irrelevant.
if (Is_Record_Type (Comp_Base)
and then not Has_Complex_Representation (Comp_Base))
or else Is_Array_Type (Comp_Base)
then
Comp_SSO_Differs :=
Reverse_Storage_Order (Encl_Base) /=
Reverse_Storage_Order (Comp_Base);
-- Parent and extension must have same storage order
if Present (Comp) and then Chars (Comp) = Name_uParent then
if Comp_SSO_Differs then
Error_Msg_N
("record extension must have same scalar storage order as "
& "parent", Err_Node);
end if;
-- If component and composite SSO differs, check that component
-- falls on byte boundaries and isn't bit packed.
elsif Comp_SSO_Differs then
-- Component SSO differs from enclosing composite:
-- Reject if composite is a bit-packed array, as it is rewritten
-- into an array of scalars.
if Is_Bit_Packed_Array (Encl_Base) then
Error_Msg_N
("type of packed array must have same scalar storage order "
& "as component", Err_Node);
-- Reject if not byte aligned
elsif Is_Record_Type (Encl_Base)
and then not Comp_Byte_Aligned
then
if Present (Component_Clause (Comp)) then
Error_Msg_N
("type of non-byte-aligned component must have same scalar"
& " storage order as enclosing record", Err_Node);
else
Error_Msg_N
("type of packed component must have same scalar"
& " storage order as enclosing record", Err_Node);
end if;
-- Warn if specified only for the outer composite
elsif Present (ADC) and then No (Comp_ADC) then
Error_Msg_NE
("scalar storage order specified for & does not apply to "
& "component?", Err_Node, Encl_Base);
end if;
end if;
-- Enclosing type has explicit SSO: non-composite component must not
-- be aliased.
elsif Present (ADC) and then Component_Aliased then
Error_Msg_N
("aliased component not permitted for type with explicit "
& "Scalar_Storage_Order", Err_Node);
end if;
end Check_Component_Storage_Order;
-----------------------------
-- Check_Debug_Info_Needed --
-----------------------------
procedure Check_Debug_Info_Needed (T : Entity_Id) is
begin
if Debug_Info_Off (T) then
return;
elsif Comes_From_Source (T)
or else Debug_Generated_Code
or else Debug_Flag_VV
or else Needs_Debug_Info (T)
then
Set_Debug_Info_Needed (T);
end if;
end Check_Debug_Info_Needed;
-------------------------------
-- Check_Expression_Function --
-------------------------------
procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id) is
function Find_Constant (Nod : Node_Id) return Traverse_Result;
-- Function to search for deferred constant
-------------------
-- Find_Constant --
-------------------
function Find_Constant (Nod : Node_Id) return Traverse_Result is
begin
-- When a constant is initialized with the result of a dispatching
-- call, the constant declaration is rewritten as a renaming of the
-- displaced function result. This scenario is not a premature use of
-- a constant even though the Has_Completion flag is not set.
if Is_Entity_Name (Nod)
and then Present (Entity (Nod))
and then Ekind (Entity (Nod)) = E_Constant
and then Scope (Entity (Nod)) = Current_Scope
and then Nkind (Declaration_Node (Entity (Nod))) =
N_Object_Declaration
and then not Is_Imported (Entity (Nod))
and then not Has_Completion (Entity (Nod))
and then not Is_Frozen (Entity (Nod))
then
Error_Msg_NE
("premature use of& in call or instance", N, Entity (Nod));
elsif Nkind (Nod) = N_Attribute_Reference then
Analyze (Prefix (Nod));
if Is_Entity_Name (Prefix (Nod))
and then Is_Type (Entity (Prefix (Nod)))
then
Freeze_Before (N, Entity (Prefix (Nod)));
end if;
end if;
return OK;
end Find_Constant;
procedure Check_Deferred is new Traverse_Proc (Find_Constant);
-- Local variables
Decl : Node_Id;
-- Start of processing for Check_Expression_Function
begin
Decl := Original_Node (Unit_Declaration_Node (Nam));
-- The subprogram body created for the expression function is not
-- itself a freeze point.
if Scope (Nam) = Current_Scope
and then Nkind (Decl) = N_Expression_Function
and then Nkind (N) /= N_Subprogram_Body
then
Check_Deferred (Expression (Decl));
end if;
end Check_Expression_Function;
--------------------------------
-- Check_Inherited_Conditions --
--------------------------------
procedure Check_Inherited_Conditions
(R : Entity_Id;
Late_Overriding : Boolean := False)
is
Prim_Ops : constant Elist_Id := Primitive_Operations (R);
Decls : List_Id;
Op_Node : Elmt_Id;
Par_Prim : Entity_Id;
Prim : Entity_Id;
Wrapper_Needed : Boolean;
function Build_DTW_Body
(Loc : Source_Ptr;
DTW_Spec : Node_Id;
DTW_Decls : List_Id;
Par_Prim : Entity_Id;
Wrapped_Subp : Entity_Id) return Node_Id;
-- Build the body of the dispatch table wrapper containing the given
-- spec and declarations; the call to the wrapped subprogram includes
-- the proper type conversion.
function Build_DTW_Spec (Par_Prim : Entity_Id) return Node_Id;
-- Build the spec of the dispatch table wrapper
procedure Build_Inherited_Condition_Pragmas
(Subp : Entity_Id;
Wrapper_Needed : out Boolean);
-- Build corresponding pragmas for an operation whose ancestor has
-- class-wide pre/postconditions. If the operation is inherited then
-- Wrapper_Needed is returned True to force the creation of a wrapper
-- for the inherited operation. If the ancestor is being overridden,
-- the pragmas are constructed only to verify their legality, in case
-- they contain calls to other primitives that may have been overridden.
function Needs_Wrapper
(Class_Cond : Node_Id;
Subp : Entity_Id;
Par_Subp : Entity_Id) return Boolean;
-- Checks whether the dispatch-table wrapper (DTW) for Subp must be
-- built to evaluate the given class-wide condition.
--------------------
-- Build_DTW_Body --
--------------------
function Build_DTW_Body
(Loc : Source_Ptr;
DTW_Spec : Node_Id;
DTW_Decls : List_Id;
Par_Prim : Entity_Id;
Wrapped_Subp : Entity_Id) return Node_Id
is
Par_Typ : constant Entity_Id := Find_Dispatching_Type (Par_Prim);
Actuals : constant List_Id := Empty_List;
Call : Node_Id;
Formal : Entity_Id := First_Formal (Par_Prim);
New_F_Spec : Entity_Id := First (Parameter_Specifications (DTW_Spec));
New_Formal : Entity_Id;
begin
-- Build parameter association for call to wrapped subprogram
while Present (Formal) loop
New_Formal := Defining_Identifier (New_F_Spec);
-- If the controlling argument is inherited, add conversion to
-- parent type for the call.
if Etype (Formal) = Par_Typ
and then Is_Controlling_Formal (Formal)
then
Append_To (Actuals,
Make_Type_Conversion (Loc,
New_Occurrence_Of (Par_Typ, Loc),
New_Occurrence_Of (New_Formal, Loc)));
else
Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
end if;
Next_Formal (Formal);
Next (New_F_Spec);
end loop;
if Ekind (Wrapped_Subp) = E_Procedure then
Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Wrapped_Subp, Loc),
Parameter_Associations => Actuals);
else
Call :=
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Wrapped_Subp, Loc),
Parameter_Associations => Actuals));
end if;
return
Make_Subprogram_Body (Loc,
Specification => Copy_Subprogram_Spec (DTW_Spec),
Declarations => DTW_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Call),
End_Label => Make_Identifier (Loc,
Chars (Defining_Entity (DTW_Spec)))));
end Build_DTW_Body;
--------------------
-- Build_DTW_Spec --
--------------------
function Build_DTW_Spec (Par_Prim : Entity_Id) return Node_Id is
DTW_Id : Entity_Id;
DTW_Spec : Node_Id;
begin
DTW_Spec := Build_Overriding_Spec (Par_Prim, R);
DTW_Id := Defining_Entity (DTW_Spec);
-- Add minimal decoration of fields
Mutate_Ekind (DTW_Id, Ekind (Par_Prim));
Set_LSP_Subprogram (DTW_Id, Par_Prim);
Set_Is_Dispatch_Table_Wrapper (DTW_Id);
Set_Is_Wrapper (DTW_Id);
-- The DTW wrapper is never a null procedure
if Nkind (DTW_Spec) = N_Procedure_Specification then
Set_Null_Present (DTW_Spec, False);
end if;
return DTW_Spec;
end Build_DTW_Spec;
---------------------------------------
-- Build_Inherited_Condition_Pragmas --
---------------------------------------
procedure Build_Inherited_Condition_Pragmas
(Subp : Entity_Id;
Wrapper_Needed : out Boolean)
is
Class_Pre : constant Node_Id :=
Class_Preconditions (Ultimate_Alias (Subp));
Class_Post : Node_Id := Class_Postconditions (Par_Prim);
A_Post : Node_Id;
New_Prag : Node_Id;
begin
Wrapper_Needed := False;
if No (Class_Pre) and then No (Class_Post) then
return;
end if;
-- For class-wide preconditions we just evaluate whether the wrapper
-- is needed; there is no need to build the pragma since the check
-- is performed on the caller side.
if Present (Class_Pre)
and then Needs_Wrapper (Class_Pre, Subp, Par_Prim)
then
Wrapper_Needed := True;
end if;
-- For class-wide postconditions we evaluate whether the wrapper is
-- needed and we build the class-wide postcondition pragma to install
-- it in the wrapper.
if Present (Class_Post)
and then Needs_Wrapper (Class_Post, Subp, Par_Prim)
then
Wrapper_Needed := True;
-- Update the class-wide postcondition
Class_Post := New_Copy_Tree (Class_Post);
Build_Class_Wide_Expression
(Pragma_Or_Expr => Class_Post,
Subp => Subp,
Par_Subp => Par_Prim,
Adjust_Sloc => False);
-- Install the updated class-wide postcondition in a copy of the
-- pragma postcondition defined for the nearest ancestor.
A_Post := Get_Class_Wide_Pragma (Par_Prim,
Pragma_Postcondition);
if No (A_Post) then
declare
Subps : constant Subprogram_List :=
Inherited_Subprograms (Subp);
begin
for Index in Subps'Range loop
A_Post := Get_Class_Wide_Pragma (Subps (Index),
Pragma_Postcondition);
exit when Present (A_Post);
end loop;
end;
end if;
New_Prag := New_Copy_Tree (A_Post);
Rewrite
(Expression (First (Pragma_Argument_Associations (New_Prag))),
Class_Post);
Append (New_Prag, Decls);
end if;
end Build_Inherited_Condition_Pragmas;
-------------------
-- Needs_Wrapper --
-------------------
function Needs_Wrapper
(Class_Cond : Node_Id;
Subp : Entity_Id;
Par_Subp : Entity_Id) return Boolean
is
Result : Boolean := False;
function Check_Entity (N : Node_Id) return Traverse_Result;
-- Check calls to overridden primitives
--------------------
-- Replace_Entity --
--------------------
function Check_Entity (N : Node_Id) return Traverse_Result is
New_E : Entity_Id;
begin
if Nkind (N) = N_Identifier
and then Present (Entity (N))
and then
(Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
and then
(Nkind (Parent (N)) /= N_Attribute_Reference
or else Attribute_Name (Parent (N)) /= Name_Class)
then
-- The check does not apply to dispatching calls within the
-- condition, but only to calls whose static tag is that of
-- the parent type.
if Is_Subprogram (Entity (N))
and then Nkind (Parent (N)) = N_Function_Call
and then Present (Controlling_Argument (Parent (N)))
then
return OK;
end if;
-- Determine whether entity has a renaming
New_E := Get_Mapped_Entity (Entity (N));
-- If the entity is an overridden primitive and we are not
-- in GNATprove mode, we must build a wrapper for the current
-- inherited operation. If the reference is the prefix of an
-- attribute such as 'Result (or others ???) there is no need
-- for a wrapper: the condition is just rewritten in terms of
-- the inherited subprogram.
if Present (New_E)
and then Comes_From_Source (New_E)
and then Is_Subprogram (New_E)
and then Nkind (Parent (N)) /= N_Attribute_Reference
and then not GNATprove_Mode
then
Result := True;
return Abandon;
end if;
end if;
return OK;
end Check_Entity;
procedure Check_Condition_Entities is
new Traverse_Proc (Check_Entity);
-- Start of processing for Needs_Wrapper
begin
Update_Primitives_Mapping (Par_Subp, Subp);
Map_Formals (Par_Subp, Subp);
Check_Condition_Entities (Class_Cond);
return Result;
end Needs_Wrapper;
Ifaces_List : Elist_Id := No_Elist;
Ifaces_Listed : Boolean := False;
-- Cache the list of interface operations inherited by R
-- Start of processing for Check_Inherited_Conditions
begin
if Late_Overriding then
Op_Node := First_Elmt (Prim_Ops);
while Present (Op_Node) loop
Prim := Node (Op_Node);
-- Map the overridden primitive to the overriding one
if Present (Overridden_Operation (Prim))
and then Comes_From_Source (Prim)
then
Par_Prim := Overridden_Operation (Prim);
Update_Primitives_Mapping (Par_Prim, Prim);
-- Force discarding previous mappings of its formals
Map_Formals (Par_Prim, Prim, Force_Update => True);
end if;
Next_Elmt (Op_Node);
end loop;
end if;
-- Perform validity checks on the inherited conditions of overriding
-- operations, for conformance with LSP, and apply SPARK-specific
-- restrictions on inherited conditions.
Op_Node := First_Elmt (Prim_Ops);
while Present (Op_Node) loop
Prim := Node (Op_Node);
Par_Prim := Overridden_Operation (Prim);
if Present (Par_Prim)
and then Comes_From_Source (Prim)
then
-- When the primitive is an LSP wrapper we climb to the parent
-- primitive that has the inherited contract.
if Is_Wrapper (Par_Prim)
and then Present (LSP_Subprogram (Par_Prim))
then
Par_Prim := LSP_Subprogram (Par_Prim);
end if;
-- Check that overrider and overridden operations have
-- the same strub mode.
Check_Same_Strub_Mode (Prim, Par_Prim);
-- Analyze the contract items of the overridden operation, before
-- they are rewritten as pragmas.
Analyze_Entry_Or_Subprogram_Contract (Par_Prim);
-- In GNATprove mode this is where we can collect the inherited
-- conditions, because we do not create the Check pragmas that
-- normally convey the modified class-wide conditions on
-- overriding operations.
if GNATprove_Mode then
Collect_Inherited_Class_Wide_Conditions (Prim);
end if;
end if;
-- Go over operations inherited from interfaces and check
-- them for strub mode compatibility as well.
if Has_Interfaces (R)
and then Is_Dispatching_Operation (Prim)
and then Find_Dispatching_Type (Prim) = R
then
declare
Elmt : Elmt_Id;
Iface_Elmt : Elmt_Id;
Iface : Entity_Id;
Iface_Prim : Entity_Id;
begin
-- Collect the interfaces only once. We haven't
-- finished freezing yet, so we can't use the faster
-- search from Sem_Disp.Covered_Interface_Primitives.
if not Ifaces_Listed then
Collect_Interfaces (R, Ifaces_List);
Ifaces_Listed := True;
end if;
Iface_Elmt := First_Elmt (Ifaces_List);
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
Elmt := First_Elmt (Primitive_Operations (Iface));
while Present (Elmt) loop
Iface_Prim := Node (Elmt);
if Iface_Prim /= Par_Prim
and then Chars (Iface_Prim) = Chars (Prim)
and then Comes_From_Source (Iface_Prim)
and then (Is_Interface_Conformant
(R, Iface_Prim, Prim))
then
Check_Same_Strub_Mode (Prim, Iface_Prim);
end if;
Next_Elmt (Elmt);
end loop;
Next_Elmt (Iface_Elmt);
end loop;
end;
end if;
Next_Elmt (Op_Node);
end loop;
-- Now examine the inherited operations to check whether they require
-- a wrapper to handle inherited conditions that call other primitives,
-- so that LSP can be verified/enforced.
Op_Node := First_Elmt (Prim_Ops);
while Present (Op_Node) loop
Decls := Empty_List;
Prim := Node (Op_Node);
Wrapper_Needed := False;
-- Skip internal entities built for mapping interface primitives
if not Comes_From_Source (Prim)
and then Present (Alias (Prim))
and then No (Interface_Alias (Prim))
then
Par_Prim := Ultimate_Alias (Prim);
-- When the primitive is an LSP wrapper we climb to the parent
-- primitive that has the inherited contract.
if Is_Wrapper (Par_Prim)
and then Present (LSP_Subprogram (Par_Prim))
then
Par_Prim := LSP_Subprogram (Par_Prim);
end if;
-- Analyze the contract items of the parent operation, and
-- determine whether a wrapper is needed. This is determined
-- when the condition is rewritten in sem_prag, using the
-- mapping between overridden and overriding operations built
-- in the loop above.
Analyze_Entry_Or_Subprogram_Contract (Par_Prim);
Build_Inherited_Condition_Pragmas (Prim, Wrapper_Needed);
end if;
if Wrapper_Needed
and then not Is_Abstract_Subprogram (Par_Prim)
and then Expander_Active
then
-- Build the dispatch-table wrapper (DTW). The support for
-- AI12-0195 relies on two kind of wrappers: one for indirect
-- calls (also used for AI12-0220), and one for putting in the
-- dispatch table:
--
-- 1) "indirect-call wrapper" (ICW) is needed anytime there are
-- class-wide preconditions. Prim'Access will point directly
-- at the ICW if any, or at the "pristine" body if Prim has
-- no class-wide preconditions.
--
-- 2) "dispatch-table wrapper" (DTW) is needed anytime the class
-- wide preconditions *or* the class-wide postconditions are
-- affected by overriding.
--
-- The DTW holds a single statement that is a single call where
-- the controlling actuals are conversions to the corresponding
-- type in the parent primitive. If the primitive is a function
-- the statement is a return statement with a call.
declare
Alias_Id : constant Entity_Id := Ultimate_Alias (Prim);
Loc : constant Source_Ptr := Sloc (R);
DTW_Body : Node_Id;
DTW_Decl : Node_Id;
DTW_Id : Entity_Id;
DTW_Spec : Node_Id;
begin
-- The wrapper must be analyzed in the scope of its wrapped
-- primitive (to ensure its correct decoration).
Push_Scope (Scope (Prim));
DTW_Spec := Build_DTW_Spec (Par_Prim);
DTW_Id := Defining_Entity (DTW_Spec);
DTW_Decl := Make_Subprogram_Declaration (Loc,
Specification => DTW_Spec);
-- For inherited class-wide preconditions the DTW wrapper
-- reuses the ICW of the parent (which checks the parent
-- interpretation of the class-wide preconditions); the
-- interpretation of the class-wide preconditions for the
-- inherited subprogram is checked at the caller side.
-- When the subprogram inherits class-wide postconditions
-- the DTW also checks the interpretation of the class-wide
-- postconditions for the inherited subprogram, and the body
-- of the parent checks its interpretation of the parent for
-- the class-wide postconditions.
-- procedure Prim (F1 : T1; ...) is
-- [ pragma Check (Postcondition, Expr); ]
-- begin
-- Par_Prim_ICW (Par_Type (F1), ...);
-- end;
if Present (Indirect_Call_Wrapper (Par_Prim)) then
DTW_Body :=
Build_DTW_Body (Loc,
DTW_Spec => DTW_Spec,
DTW_Decls => Decls,
Par_Prim => Par_Prim,
Wrapped_Subp => Indirect_Call_Wrapper (Par_Prim));
-- For subprograms that only inherit class-wide postconditions
-- the DTW wrapper calls the parent primitive (which on its
-- body checks the interpretation of the class-wide post-
-- conditions for the parent subprogram), and the DTW checks
-- the interpretation of the class-wide postconditions for the
-- inherited subprogram.
-- procedure Prim (F1 : T1; ...) is
-- pragma Check (Postcondition, Expr);
-- begin
-- Par_Prim (Par_Type (F1), ...);
-- end;
else
DTW_Body :=
Build_DTW_Body (Loc,
DTW_Spec => DTW_Spec,
DTW_Decls => Decls,
Par_Prim => Par_Prim,
Wrapped_Subp => Par_Prim);
end if;
-- Insert the declaration of the wrapper before the freezing
-- node of the record type declaration to ensure that it will
-- override the internal primitive built by Derive_Subprogram.
if Late_Overriding then
Ensure_Freeze_Node (R);
Insert_Before_And_Analyze (Freeze_Node (R), DTW_Decl);
else
Append_Freeze_Action (R, DTW_Decl);
end if;
Analyze (DTW_Decl);
-- Insert the body of the wrapper in the freeze actions of
-- its record type declaration to ensure that it is placed
-- in the scope of its declaration but not too early to cause
-- premature freezing of other entities.
Append_Freeze_Action (R, DTW_Body);
Analyze (DTW_Body);
-- Ensure correct decoration
pragma Assert (Is_Dispatching_Operation (DTW_Id));
pragma Assert (Present (Overridden_Operation (DTW_Id)));
pragma Assert (Overridden_Operation (DTW_Id) = Alias_Id);
-- Inherit dispatch table slot
Set_DTC_Entity_Value (R, DTW_Id);
Set_DT_Position (DTW_Id, DT_Position (Alias_Id));
-- Register the wrapper in the dispatch table
if Late_Overriding
and then not Building_Static_DT (R)
then
Insert_List_After_And_Analyze (Freeze_Node (R),
Register_Primitive (Loc, DTW_Id));
end if;
-- Build the helper and ICW for the DTW
if Present (Indirect_Call_Wrapper (Par_Prim)) then
declare
CW_Subp : Entity_Id;
Decl_N : Node_Id;
Body_N : Node_Id;
begin
Merge_Class_Conditions (DTW_Id);
Make_Class_Precondition_Subps (DTW_Id,
Late_Overriding => Late_Overriding);
CW_Subp := Static_Call_Helper (DTW_Id);
Decl_N := Unit_Declaration_Node (CW_Subp);
Analyze (Decl_N);
-- If the DTW was built for a late-overriding primitive
-- its body must be analyzed now (since the tagged type
-- is already frozen).
if Late_Overriding then
Body_N :=
Unit_Declaration_Node
(Corresponding_Body (Decl_N));
Analyze (Body_N);
end if;
end;
end if;
Pop_Scope;
end;
end if;
Next_Elmt (Op_Node);
end loop;
end Check_Inherited_Conditions;
----------------------------
-- Check_Strict_Alignment --
----------------------------
procedure Check_Strict_Alignment (E : Entity_Id) is
Comp : Entity_Id;
begin
-- Bit-packed array types do not require strict alignment, even if they
-- are by-reference types, because they are accessed in a special way.
if Is_By_Reference_Type (E) and then not Is_Bit_Packed_Array (E) then
Set_Strict_Alignment (E);
elsif Is_Array_Type (E) then
Set_Strict_Alignment (E, Strict_Alignment (Component_Type (E)));
-- ??? AI12-001: Any component of a packed type that contains an
-- aliased part must be aligned according to the alignment of its
-- subtype (RM 13.2(7)). This means that the following test:
-- if Has_Aliased_Components (E) then
-- Set_Strict_Alignment (E);
-- end if;
-- should be implemented here. Unfortunately it would break Florist,
-- which has the bad habit of overaligning all the types it declares
-- on 32-bit platforms. Other legacy codebases could also be affected
-- because this check has historically been missing in GNAT.
elsif Is_Record_Type (E) then
Comp := First_Component (E);
while Present (Comp) loop
if not Is_Type (Comp)
and then (Is_Aliased (Comp)
or else Strict_Alignment (Etype (Comp)))
then
Set_Strict_Alignment (E);
return;
end if;
Next_Component (Comp);
end loop;
end if;
end Check_Strict_Alignment;
-------------------------
-- Check_Unsigned_Type --
-------------------------
procedure Check_Unsigned_Type (E : Entity_Id) is
Ancestor : Entity_Id;
Lo_Bound : Node_Id;
Btyp : Entity_Id;
begin
if not Is_Discrete_Or_Fixed_Point_Type (E) then
return;
end if;
-- Do not attempt to analyze case where range was in error
if No (Scalar_Range (E)) or else Error_Posted (Scalar_Range (E)) then
return;
end if;
-- The situation that is nontrivial is something like:
-- subtype x1 is integer range -10 .. +10;
-- subtype x2 is x1 range 0 .. V1;
-- subtype x3 is x2 range V2 .. V3;
-- subtype x4 is x3 range V4 .. V5;
-- where Vn are variables. Here the base type is signed, but we still
-- know that x4 is unsigned because of the lower bound of x2.
-- The only way to deal with this is to look up the ancestor chain
Ancestor := E;
loop
if Ancestor = Any_Type or else Etype (Ancestor) = Any_Type then
return;
end if;
Lo_Bound := Type_Low_Bound (Ancestor);
if Compile_Time_Known_Value (Lo_Bound) then
if Expr_Rep_Value (Lo_Bound) >= 0 then
Set_Is_Unsigned_Type (E, True);
end if;
return;
else
Ancestor := Ancestor_Subtype (Ancestor);
-- If no ancestor had a static lower bound, go to base type
if No (Ancestor) then
-- Note: the reason we still check for a compile time known
-- value for the base type is that at least in the case of
-- generic formals, we can have bounds that fail this test,
-- and there may be other cases in error situations.
Btyp := Base_Type (E);
if Btyp = Any_Type or else Etype (Btyp) = Any_Type then
return;
end if;
Lo_Bound := Type_Low_Bound (Base_Type (E));
if Compile_Time_Known_Value (Lo_Bound)
and then Expr_Rep_Value (Lo_Bound) >= 0
then
Set_Is_Unsigned_Type (E, True);
end if;
return;
end if;
end if;
end loop;
end Check_Unsigned_Type;
------------------------------
-- Is_Full_Access_Aggregate --
------------------------------
function Is_Full_Access_Aggregate (N : Node_Id) return Boolean is
Loc : constant Source_Ptr := Sloc (N);
New_N : Node_Id;
Par : Node_Id;
Temp : Entity_Id;
Typ : Entity_Id;
begin
Par := Parent (N);
-- Array may be qualified, so find outer context
if Nkind (Par) = N_Qualified_Expression then
Par := Parent (Par);
end if;
if not Comes_From_Source (Par) then
return False;
end if;
case Nkind (Par) is
when N_Assignment_Statement =>
Typ := Etype (Name (Par));
if not Is_Full_Access (Typ)
and then not Is_Full_Access_Object (Name (Par))
then
return False;
end if;
when N_Object_Declaration =>
Typ := Etype (Defining_Identifier (Par));
if not Is_Full_Access (Typ)
and then not Is_Full_Access (Defining_Identifier (Par))
then
return False;
end if;
when others =>
return False;
end case;
Temp := Make_Temporary (Loc, 'T', N);
New_N :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Relocate_Node (N));
Insert_Before (Par, New_N);
Analyze (New_N);
Set_Expression (Par, New_Occurrence_Of (Temp, Loc));
return True;
end Is_Full_Access_Aggregate;
-----------------------------------------------
-- Explode_Initialization_Compound_Statement --
-----------------------------------------------
procedure Explode_Initialization_Compound_Statement (E : Entity_Id) is
Init_Stmts : constant Node_Id := Initialization_Statements (E);
begin
if Present (Init_Stmts)
and then Nkind (Init_Stmts) = N_Compound_Statement
then
Insert_List_Before (Init_Stmts, Actions (Init_Stmts));
-- Note that we rewrite Init_Stmts into a NULL statement, rather than
-- just removing it, because Freeze_All may rely on this particular
-- Node_Id still being present in the enclosing list to know where to
-- stop freezing.
Rewrite (Init_Stmts, Make_Null_Statement (Sloc (Init_Stmts)));
Set_Initialization_Statements (E, Empty);
end if;
end Explode_Initialization_Compound_Statement;
----------------
-- Freeze_All --
----------------
-- Note: the easy coding for this procedure would be to just build a
-- single list of freeze nodes and then insert them and analyze them
-- all at once. This won't work, because the analysis of earlier freeze
-- nodes may recursively freeze types which would otherwise appear later
-- on in the freeze list. So we must analyze and expand the freeze nodes
-- as they are generated.
procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is
procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id);
-- This is the internal recursive routine that does freezing of entities
-- (but NOT the analysis of default expressions, which should not be
-- recursive, we don't want to analyze those till we are sure that ALL
-- the types are frozen).
--------------------
-- Freeze_All_Ent --
--------------------
procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id) is
E : Entity_Id;
Flist : List_Id;
procedure Process_Flist;
-- If freeze nodes are present, insert and analyze, and reset cursor
-- for next insertion.
-------------------
-- Process_Flist --
-------------------
procedure Process_Flist is
Lastn : Node_Id;
begin
if Is_Non_Empty_List (Flist) then
Lastn := Next (After);
Insert_List_After_And_Analyze (After, Flist);
if Present (Lastn) then
After := Prev (Lastn);
else
After := Last (List_Containing (After));
end if;
end if;
end Process_Flist;
-- Start of processing for Freeze_All_Ent
begin
E := From;
while Present (E) loop
-- If the entity is an inner package which is not a package
-- renaming, then its entities must be frozen at this point. Note
-- that such entities do NOT get frozen at the end of the nested
-- package itself (only library packages freeze).
-- Same is true for task declarations, where anonymous records
-- created for entry parameters must be frozen.
if Ekind (E) = E_Package
and then No (Renamed_Entity (E))
and then not Is_Child_Unit (E)
and then not Is_Frozen (E)
then
Push_Scope (E);
Install_Visible_Declarations (E);
Install_Private_Declarations (E);
Freeze_All (First_Entity (E), After);
End_Package_Scope (E);
if Is_Generic_Instance (E)
and then Has_Delayed_Freeze (E)
then
Set_Has_Delayed_Freeze (E, False);
Expand_N_Package_Declaration (Unit_Declaration_Node (E));
end if;
elsif Ekind (E) in Task_Kind
and then Nkind (Parent (E)) in
N_Single_Task_Declaration | N_Task_Type_Declaration
then
Push_Scope (E);
Freeze_All (First_Entity (E), After);
End_Scope;
-- For a derived tagged type, we must ensure that all the
-- primitive operations of the parent have been frozen, so that
-- their addresses will be in the parent's dispatch table at the
-- point it is inherited.
elsif Ekind (E) = E_Record_Type
and then Is_Tagged_Type (E)
and then Is_Tagged_Type (Etype (E))
and then Is_Derived_Type (E)
then
declare
Prim_List : constant Elist_Id :=
Primitive_Operations (Etype (E));
Prim : Elmt_Id;
Subp : Entity_Id;
begin
Prim := First_Elmt (Prim_List);
while Present (Prim) loop
Subp := Node (Prim);
if Comes_From_Source (Subp)
and then not Is_Frozen (Subp)
then
Flist := Freeze_Entity (Subp, After);
Process_Flist;
end if;
Next_Elmt (Prim);
end loop;
end;
end if;
if not Is_Frozen (E) then
Flist := Freeze_Entity (E, After);
Process_Flist;
-- If already frozen, and there are delayed aspects, this is where
-- we do the visibility check for these aspects (see Sem_Ch13 spec
-- for a description of how we handle aspect visibility).
elsif Has_Delayed_Aspects (E) then
declare
Ritem : Node_Id;
begin
Ritem := First_Rep_Item (E);
while Present (Ritem) loop
if Nkind (Ritem) = N_Aspect_Specification
and then Entity (Ritem) = E
and then Is_Delayed_Aspect (Ritem)
then
Check_Aspect_At_End_Of_Declarations (Ritem);
end if;
Next_Rep_Item (Ritem);
end loop;
end;
end if;
-- If an incomplete type is still not frozen, this may be a
-- premature freezing because of a body declaration that follows.
-- Indicate where the freezing took place. Freezing will happen
-- if the body comes from source, but not if it is internally
-- generated, for example as the body of a type invariant.
-- If the freezing is caused by the end of the current declarative
-- part, it is a Taft Amendment type, and there is no error.
if not Is_Frozen (E)
and then Ekind (E) = E_Incomplete_Type
then
declare
Bod : constant Node_Id := Next (After);
begin
-- The presence of a body freezes all entities previously
-- declared in the current list of declarations, but this
-- does not apply if the body does not come from source.
-- A type invariant is transformed into a subprogram body
-- which is placed at the end of the private part of the
-- current package, but this body does not freeze incomplete
-- types that may be declared in this private part.
if Comes_From_Source (Bod)
and then Nkind (Bod) in N_Entry_Body
| N_Package_Body
| N_Protected_Body
| N_Subprogram_Body
| N_Task_Body
| N_Body_Stub
and then
In_Same_List (After, Parent (E))
then
Error_Msg_Sloc := Sloc (Next (After));
Error_Msg_NE
("type& is frozen# before its full declaration",
Parent (E), E);
end if;
end;
end if;
Next_Entity (E);
end loop;
end Freeze_All_Ent;
-- Local variables
Decl : Node_Id;
E : Entity_Id;
Item : Entity_Id;
-- Start of processing for Freeze_All
begin
Freeze_All_Ent (From, After);
-- Now that all types are frozen, we can deal with default expressions
-- that require us to build a default expression functions. This is the
-- point at which such functions are constructed (after all types that
-- might be used in such expressions have been frozen).
-- For subprograms that are renaming_as_body, we create the wrapper
-- bodies as needed.
-- We also add finalization chains to access types whose designated
-- types are controlled. This is normally done when freezing the type,
-- but this misses recursive type definitions where the later members
-- of the recursion introduce controlled components.
-- Loop through entities
E := From;
while Present (E) loop
if Is_Subprogram (E) then
if not Default_Expressions_Processed (E) then
Process_Default_Expressions (E, After);
end if;
-- Check subprogram renamings for the same strub-mode.
-- Avoid rechecking dispatching operations, that's taken
-- care of in Check_Inherited_Conditions, that covers
-- inherited interface operations.
Item := Alias (E);
if Present (Item)
and then not Is_Dispatching_Operation (E)
then
Check_Same_Strub_Mode (E, Item);
end if;
if not Has_Completion (E) then
Decl := Unit_Declaration_Node (E);
if Nkind (Decl) = N_Subprogram_Renaming_Declaration then
if Error_Posted (Decl) then
Set_Has_Completion (E);
else
Build_And_Analyze_Renamed_Body (Decl, E, After);
end if;
elsif Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
and then
Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
N_Subprogram_Renaming_Declaration
then
Build_And_Analyze_Renamed_Body
(Decl, Corresponding_Body (Decl), After);
end if;
end if;
-- Freeze the default expressions of entries, entry families, and
-- protected subprograms.
elsif Is_Concurrent_Type (E) then
Item := First_Entity (E);
while Present (Item) loop
if Is_Subprogram_Or_Entry (Item)
and then not Default_Expressions_Processed (Item)
then
Process_Default_Expressions (Item, After);
end if;
Next_Entity (Item);
end loop;
end if;
-- Historical note: We used to create a finalization master for an
-- access type whose designated type is not controlled, but contains
-- private controlled compoments. This form of postprocessing is no
-- longer needed because the finalization master is now created when
-- the access type is frozen (see Exp_Ch3.Freeze_Type).
Next_Entity (E);
end loop;
end Freeze_All;
-----------------------
-- Freeze_And_Append --
-----------------------
procedure Freeze_And_Append
(Ent : Entity_Id;
N : Node_Id;
Result : in out List_Id)
is
L : constant List_Id := Freeze_Entity (Ent, N);
begin
if Is_Non_Empty_List (L) then
if Result = No_List then
Result := L;
else
Append_List (L, Result);
end if;
end if;
end Freeze_And_Append;
-------------------
-- Freeze_Before --
-------------------
procedure Freeze_Before
(N : Node_Id;
T : Entity_Id;
Do_Freeze_Profile : Boolean := True)
is
-- Freeze T, then insert the generated Freeze nodes before the node N.
-- Flag Freeze_Profile is used when T is an overloadable entity, and
-- indicates whether its profile should be frozen at the same time.
Freeze_Nodes : constant List_Id :=
Freeze_Entity (T, N, Do_Freeze_Profile);
Pack : constant Entity_Id := Scope (T);
begin
if Ekind (T) = E_Function then
Check_Expression_Function (N, T);
end if;
if Is_Non_Empty_List (Freeze_Nodes) then
-- If the entity is a type declared in an inner package, it may be
-- frozen by an outer declaration before the package itself is
-- frozen. Install the package scope to analyze the freeze nodes,
-- which may include generated subprograms such as predicate
-- functions, etc.
if Is_Type (T) and then From_Nested_Package (T) then
Push_Scope (Pack);
Install_Visible_Declarations (Pack);
Install_Private_Declarations (Pack);
Insert_Actions (N, Freeze_Nodes);
End_Package_Scope (Pack);
else
Insert_Actions (N, Freeze_Nodes);
end if;
end if;
end Freeze_Before;
-------------------
-- Freeze_Entity --
-------------------
-- WARNING: This routine manages Ghost regions. Return statements must be
-- replaced by gotos which jump to the end of the routine and restore the
-- Ghost mode.
function Freeze_Entity
(E : Entity_Id;
N : Node_Id;
Do_Freeze_Profile : Boolean := True) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
-- Save the Ghost-related attributes to restore on exit
Atype : Entity_Id;
Comp : Entity_Id;
F_Node : Node_Id;
Formal : Entity_Id;
Indx : Node_Id;
Result : List_Id := No_List;
-- List of freezing actions, left at No_List if none
Test_E : Entity_Id := E;
-- A local temporary used to test if freezing is necessary for E, since
-- its value can be set to something other than E in certain cases. For
-- example, E cannot be used directly in cases such as when it is an
-- Itype defined within a record - since it is the location of record
-- which matters.
procedure Add_To_Result (Fnod : Node_Id);
-- Add freeze action Fnod to list Result
function After_Last_Declaration return Boolean;
-- If Loc is a freeze_entity that appears after the last declaration
-- in the scope, inhibit error messages on late completion.
procedure Check_Current_Instance (Comp_Decl : Node_Id);
-- Check that an Access or Unchecked_Access attribute with a prefix
-- which is the current instance type can only be applied when the type
-- is limited.
procedure Check_No_Parts_Violations
(Typ : Entity_Id; Aspect_No_Parts : Aspect_Id) with
Pre => Aspect_No_Parts in
Aspect_No_Controlled_Parts | Aspect_No_Task_Parts;
-- Check that Typ does not violate the semantics of the specified
-- Aspect_No_Parts (No_Controlled_Parts or No_Task_Parts) when it is
-- specified on Typ or one of its ancestors.
procedure Check_Suspicious_Convention (Rec_Type : Entity_Id);
-- Give a warning for pragma Convention with language C or C++ applied
-- to a discriminated record type. This is suppressed for the unchecked
-- union case, since the whole point in this case is interface C. We
-- also do not generate this within instantiations, since we will have
-- generated a message on the template.
procedure Check_Suspicious_Modulus (Utype : Entity_Id);
-- Give warning for modulus of 8, 16, 32, 64 or 128 given as an explicit
-- integer literal without an explicit corresponding size clause. The
-- caller has checked that Utype is a modular integer type.
procedure Freeze_Array_Type (Arr : Entity_Id);
-- Freeze array type, including freezing index and component types
procedure Freeze_Object_Declaration (E : Entity_Id);
-- Perform checks and generate freeze node if needed for a constant or
-- variable declared by an object declaration.
function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id;
-- Create Freeze_Generic_Entity nodes for types declared in a generic
-- package. Recurse on inner generic packages.
function Freeze_Profile (E : Entity_Id) return Boolean;
-- Freeze formals and return type of subprogram. If some type in the
-- profile is incomplete and we are in an instance, freezing of the
-- entity will take place elsewhere, and the function returns False.
procedure Freeze_Record_Type (Rec : Entity_Id);
-- Freeze record type, including freezing component types, and freezing
-- primitive operations if this is a tagged type.
function Has_Boolean_Aspect_Import (E : Entity_Id) return Boolean;
-- Determine whether an arbitrary entity is subject to Boolean aspect
-- Import and its value is specified as True.
procedure Inherit_Freeze_Node
(Fnod : Node_Id;
Typ : Entity_Id);
-- Set type Typ's freeze node to refer to Fnode. This routine ensures
-- that any attributes attached to Typ's original node are preserved.
procedure Wrap_Imported_Subprogram (E : Entity_Id);
-- If E is an entity for an imported subprogram with pre/post-conditions
-- then this procedure will create a wrapper to ensure that proper run-
-- time checking of the pre/postconditions. See body for details.
-------------------
-- Add_To_Result --
-------------------
procedure Add_To_Result (Fnod : Node_Id) is
begin
Append_New_To (Result, Fnod);
end Add_To_Result;
----------------------------
-- After_Last_Declaration --
----------------------------
function After_Last_Declaration return Boolean is
Spec : constant Node_Id := Parent (Current_Scope);
begin
if Nkind (Spec) = N_Package_Specification then
if Present (Private_Declarations (Spec)) then
return Loc >= Sloc (Last (Private_Declarations (Spec)));
elsif Present (Visible_Declarations (Spec)) then
return Loc >= Sloc (Last (Visible_Declarations (Spec)));
else
return False;
end if;
else
return False;
end if;
end After_Last_Declaration;
----------------------------
-- Check_Current_Instance --
----------------------------
procedure Check_Current_Instance (Comp_Decl : Node_Id) is
function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean;
-- Determine whether Typ is compatible with the rules for aliased
-- views of types as defined in RM 3.10 in the various dialects.
function Process (N : Node_Id) return Traverse_Result;
-- Process routine to apply check to given node
-----------------------------
-- Is_Aliased_View_Of_Type --
-----------------------------
function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean is
Typ_Decl : constant Node_Id := Parent (Typ);
begin
-- Common case
if Nkind (Typ_Decl) = N_Full_Type_Declaration
and then Limited_Present (Type_Definition (Typ_Decl))
then
return True;
-- The following paragraphs describe what a legal aliased view of
-- a type is in the various dialects of Ada.
-- Ada 95
-- The current instance of a limited type, and a formal parameter
-- or generic formal object of a tagged type.
-- Ada 95 limited type
-- * Type with reserved word "limited"
-- * A protected or task type
-- * A composite type with limited component
elsif Ada_Version <= Ada_95 then
return Is_Limited_Type (Typ);
-- Ada 2005
-- The current instance of a limited tagged type, a protected
-- type, a task type, or a type that has the reserved word
-- "limited" in its full definition ... a formal parameter or
-- generic formal object of a tagged type.
-- Ada 2005 limited type
-- * Type with reserved word "limited", "synchronized", "task"
-- or "protected"
-- * A composite type with limited component
-- * A derived type whose parent is a non-interface limited type
elsif Ada_Version = Ada_2005 then
return
(Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ))
or else
(Is_Derived_Type (Typ)
and then not Is_Interface (Etype (Typ))
and then Is_Limited_Type (Etype (Typ)));
-- Ada 2012 and beyond
-- The current instance of an immutably limited type ... a formal
-- parameter or generic formal object of a tagged type.
-- Ada 2012 limited type
-- * Type with reserved word "limited", "synchronized", "task"
-- or "protected"
-- * A composite type with limited component
-- * A derived type whose parent is a non-interface limited type
-- * An incomplete view
-- Ada 2012 immutably limited type
-- * Explicitly limited record type
-- * Record extension with "limited" present
-- * Non-formal limited private type that is either tagged
-- or has at least one access discriminant with a default
-- expression
-- * Task type, protected type or synchronized interface
-- * Type derived from immutably limited type
else
return
Is_Immutably_Limited_Type (Typ)
or else Is_Incomplete_Type (Typ);
end if;
end Is_Aliased_View_Of_Type;
-------------
-- Process --
-------------
function Process (N : Node_Id) return Traverse_Result is
begin
case Nkind (N) is
when N_Attribute_Reference =>
if Attribute_Name (N) in Name_Access | Name_Unchecked_Access
and then Is_Entity_Name (Prefix (N))
and then Is_Type (Entity (Prefix (N)))
and then Entity (Prefix (N)) = E
then
if Ada_Version < Ada_2012 then
Error_Msg_N
("current instance must be a limited type",
Prefix (N));
else
Error_Msg_N
("current instance must be an immutably limited "
& "type (RM-2012, 7.5 (8.1/3))", Prefix (N));
end if;
return Abandon;
else
return OK;
end if;
when others =>
return OK;
end case;
end Process;
procedure Traverse is new Traverse_Proc (Process);
-- Local variables
Rec_Type : constant Entity_Id :=
Scope (Defining_Identifier (Comp_Decl));
-- Start of processing for Check_Current_Instance
begin
if not Is_Aliased_View_Of_Type (Rec_Type) then
Traverse (Comp_Decl);
end if;
end Check_Current_Instance;
-------------------------------
-- Check_No_Parts_Violations --
-------------------------------
procedure Check_No_Parts_Violations
(Typ : Entity_Id; Aspect_No_Parts : Aspect_Id)
is
function Find_Aspect_No_Parts
(Typ : Entity_Id) return Node_Id;
-- Search for Aspect_No_Parts on a given type. When
-- the aspect is not explicity specified Empty is returned.
function Get_Aspect_No_Parts_Value
(Typ : Entity_Id) return Entity_Id;
-- Obtain the value for the Aspect_No_Parts on a given
-- type. When the aspect is not explicitly specified Empty is
-- returned.
function Has_Aspect_No_Parts
(Typ : Entity_Id) return Boolean;
-- Predicate function which identifies whether No_Parts
-- is explicitly specified on a given type.
-------------------------------------
-- Find_Aspect_No_Parts --
-------------------------------------
function Find_Aspect_No_Parts
(Typ : Entity_Id) return Node_Id
is
Partial_View : constant Entity_Id :=
Incomplete_Or_Partial_View (Typ);
Aspect_Spec : Entity_Id :=
Find_Aspect (Typ, Aspect_No_Parts);
Curr_Aspect_Spec : Entity_Id;
begin
-- Examine Typ's associated node, when present, since aspect
-- specifications do not get transferred when nodes get rewritten.
-- For example, this can happen in the expansion of array types
if No (Aspect_Spec)
and then Present (Associated_Node_For_Itype (Typ))
and then Nkind (Associated_Node_For_Itype (Typ))
= N_Full_Type_Declaration
then
Aspect_Spec :=
Find_Aspect
(Id => Defining_Identifier
(Associated_Node_For_Itype (Typ)),
A => Aspect_No_Parts);
end if;
-- Examine aspects specifications on private type declarations
-- Should Find_Aspect be improved to handle this case ???
if No (Aspect_Spec)
and then Present (Partial_View)
and then Present
(Aspect_Specifications
(Declaration_Node
(Partial_View)))
then
Curr_Aspect_Spec :=
First
(Aspect_Specifications
(Declaration_Node
(Partial_View)));
-- Search through aspects present on the private type
while Present (Curr_Aspect_Spec) loop
if Get_Aspect_Id (Curr_Aspect_Spec)
= Aspect_No_Parts
then
Aspect_Spec := Curr_Aspect_Spec;
exit;
end if;
Next (Curr_Aspect_Spec);
end loop;
end if;
-- When errors are posted on the aspect return Empty
if Error_Posted (Aspect_Spec) then
return Empty;
end if;
return Aspect_Spec;
end Find_Aspect_No_Parts;
------------------------------------------
-- Get_Aspect_No_Parts_Value --
------------------------------------------
function Get_Aspect_No_Parts_Value
(Typ : Entity_Id) return Entity_Id
is
Aspect_Spec : constant Entity_Id :=
Find_Aspect_No_Parts (Typ);
begin
-- Return the value of the aspect when present
if Present (Aspect_Spec) then
-- No expression is the same as True
if No (Expression (Aspect_Spec)) then
return Standard_True;
end if;
-- Assume its expression has already been constant folded into
-- a Boolean value and return its value.
return Entity (Expression (Aspect_Spec));
end if;
-- Otherwise, the aspect is not specified - so return Empty
return Empty;
end Get_Aspect_No_Parts_Value;
------------------------------------
-- Has_Aspect_No_Parts --
------------------------------------
function Has_Aspect_No_Parts
(Typ : Entity_Id) return Boolean
is (Present (Find_Aspect_No_Parts (Typ)));
-- Generic instances
-------------------------------------------
-- Get_Generic_Formal_Types_In_Hierarchy --
-------------------------------------------
function Get_Generic_Formal_Types_In_Hierarchy
is new Collect_Types_In_Hierarchy (Predicate => Is_Generic_Formal);
-- Return a list of all types within a given type's hierarchy which
-- are generic formals.
----------------------------------------
-- Get_Types_With_Aspect_In_Hierarchy --
----------------------------------------
function Get_Types_With_Aspect_In_Hierarchy
is new Collect_Types_In_Hierarchy
(Predicate => Has_Aspect_No_Parts);
-- Returns a list of all types within a given type's hierarchy which
-- have the Aspect_No_Parts specified.
-- Local declarations
Aspect_Value : Entity_Id;
Curr_Value : Entity_Id;
Curr_Typ_Elmt : Elmt_Id;
Curr_Body_Elmt : Elmt_Id;
Curr_Formal_Elmt : Elmt_Id;
Gen_Bodies : Elist_Id;
Gen_Formals : Elist_Id;
Scop : Entity_Id;
Types_With_Aspect : Elist_Id;
-- Start of processing for Check_No_Parts_Violations
begin
-- Nothing to check if the type is elementary or artificial
if Is_Elementary_Type (Typ) or else not Comes_From_Source (Typ) then
return;
end if;
Types_With_Aspect := Get_Types_With_Aspect_In_Hierarchy (Typ);
-- Nothing to check if there are no types with No_Parts specified
if Is_Empty_Elmt_List (Types_With_Aspect) then
return;
end if;
-- Set name for all errors below
Error_Msg_Name_1 := Aspect_Names (Aspect_No_Parts);
-- Obtain the aspect value for No_Parts for comparison
Aspect_Value :=
Get_Aspect_No_Parts_Value
(Node (First_Elmt (Types_With_Aspect)));
-- When the value is True and there are controlled/task parts or the
-- type itself is controlled/task, trigger the appropriate error.
if Aspect_Value = Standard_True then
if Aspect_No_Parts = Aspect_No_Controlled_Parts then
if Is_Controlled (Typ) or else Has_Controlled_Component (Typ)
then
Error_Msg_N
("aspect % applied to controlled type &", Typ);
end if;
elsif Aspect_No_Parts = Aspect_No_Task_Parts then
if Has_Task (Typ) then
Error_Msg_N
("aspect % applied to task type &", Typ);
end if;
else
raise Program_Error;
end if;
end if;
-- Move through Types_With_Aspect - checking that the value specified
-- for their corresponding Aspect_No_Parts do not override each
-- other.
Curr_Typ_Elmt := First_Elmt (Types_With_Aspect);
while Present (Curr_Typ_Elmt) loop
Curr_Value :=
Get_Aspect_No_Parts_Value (Node (Curr_Typ_Elmt));
-- Compare the aspect value against the current type
if Curr_Value /= Aspect_Value then
Error_Msg_NE
("cannot override aspect % of "
& "ancestor type &", Typ, Node (Curr_Typ_Elmt));
return;
end if;
Next_Elmt (Curr_Typ_Elmt);
end loop;
-- Issue an error if the aspect applies to a type declared inside a
-- generic body and if said type derives from or has a component
-- of ageneric formal type - since those are considered to have
-- controlled/task parts and have Aspect_No_Parts specified as
-- False by default (RM H.4.1(4/5) is about the language-defined
-- No_Controlled_Parts aspect, and we are using the same rules for
-- No_Task_Parts).
-- We do not check tagged types since deriving from a formal type
-- within an enclosing generic unit is already illegal
-- (RM 3.9.1 (4/2)).
if Aspect_Value = Standard_True
and then In_Generic_Body (Typ)
and then not Is_Tagged_Type (Typ)
then
Gen_Bodies := New_Elmt_List;
Gen_Formals :=
Get_Generic_Formal_Types_In_Hierarchy
(Typ => Typ,
Examine_Components => True);
-- Climb scopes collecting generic bodies
Scop := Scope (Typ);
while Present (Scop) and then Scop /= Standard_Standard loop
-- Generic package body
if Ekind (Scop) = E_Generic_Package
and then In_Package_Body (Scop)
then
Append_Elmt (Scop, Gen_Bodies);
-- Generic subprogram body
elsif Is_Generic_Subprogram (Scop) then
Append_Elmt (Scop, Gen_Bodies);
end if;
Scop := Scope (Scop);
end loop;
-- Warn about the improper use of Aspect_No_Parts on a type
-- declaration deriving from or that has a component of a generic
-- formal type within the formal type's corresponding generic
-- body by moving through all formal types in Typ's hierarchy and
-- checking if they are formals in any of the enclosing generic
-- bodies.
-- However, a special exception gets made for formal types which
-- derive from a type which has Aspect_No_Parts True.
-- For example:
-- generic
-- type Form is private;
-- package G is
-- type Type_A is new Form with No_Controlled_Parts; -- OK
-- end;
--
-- package body G is
-- type Type_B is new Form with No_Controlled_Parts; -- ERROR
-- end;
-- generic
-- type Form is private;
-- package G is
-- type Type_A is record C : Form; end record
-- with No_Controlled_Parts; -- OK
-- end;
--
-- package body G is
-- type Type_B is record C : Form; end record
-- with No_Controlled_Parts; -- ERROR
-- end;
-- type Root is tagged null record with No_Controlled_Parts;
--
-- generic
-- type Form is new Root with private;
-- package G is
-- type Type_A is record C : Form; end record
-- with No_Controlled_Parts; -- OK
-- end;
--
-- package body G is
-- type Type_B is record C : Form; end record
-- with No_Controlled_Parts; -- OK
-- end;
Curr_Formal_Elmt := First_Elmt (Gen_Formals);
while Present (Curr_Formal_Elmt) loop
Curr_Body_Elmt := First_Elmt (Gen_Bodies);
while Present (Curr_Body_Elmt) loop
-- Obtain types in the formal type's hierarchy which have
-- the aspect specified.
Types_With_Aspect :=
Get_Types_With_Aspect_In_Hierarchy
(Node (Curr_Formal_Elmt));
-- We found a type declaration in a generic body where both
-- Aspect_No_Parts is true and one of its ancestors is a
-- generic formal type.
if Scope (Node (Curr_Formal_Elmt)) =
Node (Curr_Body_Elmt)
-- Check that no ancestors of the formal type have
-- Aspect_No_Parts True before issuing the error.
and then (Is_Empty_Elmt_List (Types_With_Aspect)
or else
Get_Aspect_No_Parts_Value
(Node (First_Elmt (Types_With_Aspect)))
= Standard_False)
then
Error_Msg_Node_1 := Typ;
Error_Msg_Node_2 := Node (Curr_Formal_Elmt);
Error_Msg
("aspect % cannot be applied to "
& "type & which has an ancestor or component of "
& "formal type & within the formal type's "
& "corresponding generic body", Sloc (Typ));
end if;
Next_Elmt (Curr_Body_Elmt);
end loop;
Next_Elmt (Curr_Formal_Elmt);
end loop;
end if;
end Check_No_Parts_Violations;
---------------------------------
-- Check_Suspicious_Convention --
---------------------------------
procedure Check_Suspicious_Convention (Rec_Type : Entity_Id) is
begin
if Has_Discriminants (Rec_Type)
and then Is_Base_Type (Rec_Type)
and then not Is_Unchecked_Union (Rec_Type)
and then (Convention (Rec_Type) = Convention_C
or else
Convention (Rec_Type) = Convention_CPP)
and then Comes_From_Source (Rec_Type)
and then not In_Instance
and then not Has_Warnings_Off (Rec_Type)
then
declare
Cprag : constant Node_Id :=
Get_Rep_Pragma (Rec_Type, Name_Convention);
A2 : Node_Id;
begin
if Present (Cprag) then
A2 := Next (First (Pragma_Argument_Associations (Cprag)));
if Convention (Rec_Type) = Convention_C then
Error_Msg_N
("?x?discriminated record has no direct equivalent in "
& "C", A2);
else
Error_Msg_N
("?x?discriminated record has no direct equivalent in "
& "C++", A2);
end if;
Error_Msg_NE
("\?x?use of convention for type& is dubious",
A2, Rec_Type);
end if;
end;
end if;
end Check_Suspicious_Convention;
------------------------------
-- Check_Suspicious_Modulus --
------------------------------
procedure Check_Suspicious_Modulus (Utype : Entity_Id) is
Decl : constant Node_Id := Declaration_Node (Underlying_Type (Utype));
begin
if not Warn_On_Suspicious_Modulus_Value then
return;
end if;
if Nkind (Decl) = N_Full_Type_Declaration then
declare
Tdef : constant Node_Id := Type_Definition (Decl);
begin
if Nkind (Tdef) = N_Modular_Type_Definition then
declare
Modulus : constant Node_Id :=
Original_Node (Expression (Tdef));
begin
if Nkind (Modulus) = N_Integer_Literal then
declare
Modv : constant Uint := Intval (Modulus);
Sizv : constant Uint := RM_Size (Utype);
begin
-- First case, modulus and size are the same. This
-- happens if you have something like mod 32, with
-- an explicit size of 32, this is for sure a case
-- where the warning is given, since it is seems
-- very unlikely that someone would want e.g. a
-- five bit type stored in 32 bits. It is much
-- more likely they wanted a 32-bit type.
if Modv = Sizv then
null;
-- Second case, the modulus is 32 or 64 and no
-- size clause is present. This is a less clear
-- case for giving the warning, but in the case
-- of 32/64 (5-bit or 6-bit types) these seem rare
-- enough that it is a likely error (and in any
-- case using 2**5 or 2**6 in these cases seems
-- clearer. We don't include 8 or 16 here, simply
-- because in practice 3-bit and 4-bit types are
-- more common and too many false positives if
-- we warn in these cases.
elsif not Has_Size_Clause (Utype)
and then (Modv = Uint_32 or else Modv = Uint_64)
then
null;
-- No warning needed
else
return;
end if;
-- If we fall through, give warning
Error_Msg_Uint_1 := Modv;
Error_Msg_N
("?.m?2 '*'*^' may have been intended here",
Modulus);
end;
end if;
end;
end if;
end;
end if;
end Check_Suspicious_Modulus;
-----------------------
-- Freeze_Array_Type --
-----------------------
procedure Freeze_Array_Type (Arr : Entity_Id) is
FS : constant Entity_Id := First_Subtype (Arr);
Ctyp : constant Entity_Id := Component_Type (Arr);
Clause : Entity_Id;
Non_Standard_Enum : Boolean := False;
-- Set true if any of the index types is an enumeration type with a
-- non-standard representation.
begin
Freeze_And_Append (Ctyp, N, Result);
Indx := First_Index (Arr);
while Present (Indx) loop
Freeze_And_Append (Etype (Indx), N, Result);
if Is_Enumeration_Type (Etype (Indx))
and then Has_Non_Standard_Rep (Etype (Indx))
then
Non_Standard_Enum := True;
end if;
Next_Index (Indx);
end loop;
-- Processing that is done only for base types
if Ekind (Arr) = E_Array_Type then
-- Deal with default setting of reverse storage order
Set_SSO_From_Default (Arr);
-- Propagate flags for component type
if Is_Controlled (Ctyp)
or else Has_Controlled_Component (Ctyp)
then
Set_Has_Controlled_Component (Arr);
end if;
if Has_Unchecked_Union (Ctyp) then
Set_Has_Unchecked_Union (Arr);
end if;
-- The array type requires its own invariant procedure in order to
-- verify the component invariant over all elements. In GNATprove
-- mode, the component invariants are checked by other means. They
-- should not be added to the array type invariant procedure, so
-- that the procedure can be used to check the array type
-- invariants if any.
if Has_Invariants (Ctyp)
and then not GNATprove_Mode
then
Set_Has_Own_Invariants (Arr);
end if;
-- Warn for pragma Pack overriding foreign convention
if Has_Foreign_Convention (Ctyp)
and then Has_Pragma_Pack (Arr)
then
declare
CN : constant Name_Id :=
Get_Convention_Name (Convention (Ctyp));
PP : constant Node_Id :=
Get_Pragma (First_Subtype (Arr), Pragma_Pack);
begin
if Present (PP) then
Error_Msg_Name_1 := CN;
Error_Msg_Sloc := Sloc (Arr);
Error_Msg_N
("pragma Pack affects convention % components #??", PP);
Error_Msg_Name_1 := CN;
Error_Msg_N
("\array components may not have % compatible "
& "representation??", PP);
end if;
end;
end if;
-- Check for Aliased or Atomic_Components or Full Access with
-- unsuitable packing or explicit component size clause given.
if (Has_Aliased_Components (Arr)
or else Has_Atomic_Components (Arr)
or else Is_Full_Access (Ctyp))
and then
(Has_Component_Size_Clause (Arr) or else Is_Packed (Arr))
then
Alias_Atomic_Check : declare
procedure Complain_CS (T : String);
-- Outputs error messages for incorrect CS clause or pragma
-- Pack for aliased or full access components (T is either
-- "aliased" or "atomic" or "volatile full access");
-----------------
-- Complain_CS --
-----------------
procedure Complain_CS (T : String) is
begin
if Has_Component_Size_Clause (Arr) then
Clause :=
Get_Attribute_Definition_Clause
(FS, Attribute_Component_Size);
Error_Msg_N
("incorrect component size for "
& T & " components", Clause);
Error_Msg_Uint_1 := Esize (Ctyp);
Error_Msg_N
("\only allowed value is^", Clause);
else
Error_Msg_N
("?cannot pack " & T & " components (RM 13.2(7))",
Get_Rep_Pragma (FS, Name_Pack));
Set_Is_Packed (Arr, False);
end if;
end Complain_CS;
-- Start of processing for Alias_Atomic_Check
begin
-- If object size of component type isn't known, we cannot
-- be sure so we defer to the back end.
if not Known_Static_Esize (Ctyp) then
null;
-- Case where component size has no effect. First check for
-- object size of component type multiple of the storage
-- unit size.
elsif Esize (Ctyp) mod System_Storage_Unit = 0
-- OK in both packing case and component size case if RM
-- size is known and static and same as the object size.
and then
((Known_Static_RM_Size (Ctyp)
and then Esize (Ctyp) = RM_Size (Ctyp))
-- Or if we have an explicit component size clause and
-- the component size and object size are equal.
or else
(Has_Component_Size_Clause (Arr)
and then Component_Size (Arr) = Esize (Ctyp)))
then
null;
elsif Has_Aliased_Components (Arr) then
Complain_CS ("aliased");
elsif Has_Atomic_Components (Arr)
or else Is_Atomic (Ctyp)
then
Complain_CS ("atomic");
elsif Is_Volatile_Full_Access (Ctyp) then
Complain_CS ("volatile full access");
end if;
end Alias_Atomic_Check;
end if;
-- Check for Independent_Components/Independent with unsuitable
-- packing or explicit component size clause given.
if (Has_Independent_Components (Arr) or else Is_Independent (Ctyp))
and then
(Has_Component_Size_Clause (Arr) or else Is_Packed (Arr))
then
begin
-- If object size of component type isn't known, we cannot
-- be sure so we defer to the back end.
if not Known_Static_Esize (Ctyp) then
null;
-- Case where component size has no effect. First check for
-- object size of component type multiple of the storage
-- unit size.
elsif Esize (Ctyp) mod System_Storage_Unit = 0
-- OK in both packing case and component size case if RM
-- size is known and multiple of the storage unit size.
and then
((Known_Static_RM_Size (Ctyp)
and then RM_Size (Ctyp) mod System_Storage_Unit = 0)
-- Or if we have an explicit component size clause and
-- the component size is larger than the object size.
or else
(Has_Component_Size_Clause (Arr)
and then Component_Size (Arr) >= Esize (Ctyp)))
then
null;
else
if Has_Component_Size_Clause (Arr) then
Clause :=
Get_Attribute_Definition_Clause
(FS, Attribute_Component_Size);
Error_Msg_N
("incorrect component size for "
& "independent components", Clause);
Error_Msg_Uint_1 := Esize (Ctyp);
Error_Msg_N
("\minimum allowed is^", Clause);
else
Error_Msg_N
("?cannot pack independent components (RM 13.2(7))",
Get_Rep_Pragma (FS, Name_Pack));
Set_Is_Packed (Arr, False);
end if;
end if;
end;
end if;
-- If packing was requested or if the component size was
-- set explicitly, then see if bit packing is required. This
-- processing is only done for base types, since all of the
-- representation aspects involved are type-related.
-- This is not just an optimization, if we start processing the
-- subtypes, they interfere with the settings on the base type
-- (this is because Is_Packed has a slightly different meaning
-- before and after freezing).
declare
Csiz : Uint;
Esiz : Uint;
begin
if Is_Packed (Arr)
and then Known_Static_RM_Size (Ctyp)
and then not Has_Component_Size_Clause (Arr)
then
Csiz := UI_Max (RM_Size (Ctyp), 1);
elsif Known_Component_Size (Arr) then
Csiz := Component_Size (Arr);
elsif not Known_Static_Esize (Ctyp) then
Csiz := Uint_0;
else
Esiz := Esize (Ctyp);
-- We can set the component size if it is less than 16,
-- rounding it up to the next storage unit size.
if Esiz <= 8 then
Csiz := Uint_8;
elsif Esiz <= 16 then
Csiz := Uint_16;
else
Csiz := Uint_0;
end if;
-- Set component size up to match alignment if it would
-- otherwise be less than the alignment. This deals with
-- cases of types whose alignment exceeds their size (the
-- padded type cases).
if Csiz /= 0 and then Known_Alignment (Ctyp) then
declare
A : constant Uint := Alignment_In_Bits (Ctyp);
begin
if Csiz < A then
Csiz := A;
end if;
end;
end if;
end if;
-- Case of component size that may result in bit packing
if 1 <= Csiz and then Csiz <= System_Max_Integer_Size then
declare
Ent : constant Entity_Id :=
First_Subtype (Arr);
Pack_Pragma : constant Node_Id :=
Get_Rep_Pragma (Ent, Name_Pack);
Comp_Size_C : constant Node_Id :=
Get_Attribute_Definition_Clause
(Ent, Attribute_Component_Size);
begin
-- Warn if we have pack and component size so that the
-- pack is ignored.
-- Note: here we must check for the presence of a
-- component size before checking for a Pack pragma to
-- deal with the case where the array type is a derived
-- type whose parent is currently private.
if Present (Comp_Size_C)
and then Has_Pragma_Pack (Ent)
and then Warn_On_Redundant_Constructs
then
Error_Msg_Sloc := Sloc (Comp_Size_C);
Error_Msg_NE
("?r?pragma Pack for& ignored!", Pack_Pragma, Ent);
Error_Msg_N
("\?r?explicit component size given#!", Pack_Pragma);
Set_Is_Packed (Base_Type (Ent), False);
Set_Is_Bit_Packed_Array (Base_Type (Ent), False);
end if;
-- Set component size if not already set by a component
-- size clause.
if not Present (Comp_Size_C) then
Set_Component_Size (Arr, Csiz);
end if;
-- Check for base type of 8, 16, 32 bits, where an
-- unsigned subtype has a length one less than the
-- base type (e.g. Natural subtype of Integer).
-- In such cases, if a component size was not set
-- explicitly, then generate a warning.
if Has_Pragma_Pack (Arr)
and then not Present (Comp_Size_C)
and then (Csiz = 7 or else Csiz = 15 or else Csiz = 31)
and then Known_Esize (Base_Type (Ctyp))
and then Esize (Base_Type (Ctyp)) = Csiz + 1
then
Error_Msg_Uint_1 := Csiz;
if Present (Pack_Pragma) then
Error_Msg_N
("??pragma Pack causes component size to be ^!",
Pack_Pragma);
Error_Msg_N
("\??use Component_Size to set desired value!",
Pack_Pragma);
end if;
end if;
-- Bit packing is never needed for 8, 16, 32, 64 or 128
if Addressable (Csiz) then
-- If the Esize of the component is known and equal to
-- the component size then even packing is not needed.
if Known_Static_Esize (Ctyp)
and then Esize (Ctyp) = Csiz
then
-- Here the array was requested to be packed, but
-- the packing request had no effect whatsoever,
-- so flag Is_Packed is reset.
-- Note: semantically this means that we lose track
-- of the fact that a derived type inherited pragma
-- Pack that was non-effective, but that is fine.
-- We regard a Pack pragma as a request to set a
-- representation characteristic, and this request
-- may be ignored.
Set_Is_Packed (Base_Type (Arr), False);
Set_Has_Non_Standard_Rep (Base_Type (Arr), False);
else
Set_Is_Packed (Base_Type (Arr), True);
Set_Has_Non_Standard_Rep (Base_Type (Arr), True);
end if;
Set_Is_Bit_Packed_Array (Base_Type (Arr), False);
-- Bit packing is not needed for multiples of the storage
-- unit if the type is composite because the back end can
-- byte pack composite types efficiently. That's not true
-- for discrete types because every read would generate a
-- lot of instructions, so we keep using the manipulation
-- routines of the runtime for them.
elsif Csiz mod System_Storage_Unit = 0
and then Is_Composite_Type (Ctyp)
then
Set_Is_Packed (Base_Type (Arr), True);
Set_Has_Non_Standard_Rep (Base_Type (Arr), True);
Set_Is_Bit_Packed_Array (Base_Type (Arr), False);
-- In all other cases, bit packing is needed
else
Set_Is_Packed (Base_Type (Arr), True);
Set_Has_Non_Standard_Rep (Base_Type (Arr), True);
Set_Is_Bit_Packed_Array (Base_Type (Arr), True);
end if;
end;
end if;
end;
-- Warn for case of atomic type
Clause := Get_Rep_Pragma (FS, Name_Atomic);
if Present (Clause)
and then not Addressable (Component_Size (FS))
then
Error_Msg_NE
("non-atomic components of type& may not be "
& "accessible by separate tasks??", Clause, Arr);
if Has_Component_Size_Clause (Arr) then
Error_Msg_Sloc := Sloc (Get_Attribute_Definition_Clause
(FS, Attribute_Component_Size));
Error_Msg_N ("\because of component size clause#??", Clause);
elsif Has_Pragma_Pack (Arr) then
Error_Msg_Sloc := Sloc (Get_Rep_Pragma (FS, Name_Pack));
Error_Msg_N ("\because of pragma Pack#??", Clause);
end if;
end if;
-- Check for scalar storage order
declare
Dummy : Boolean;
begin
Check_Component_Storage_Order
(Encl_Type => Arr,
Comp => Empty,
ADC => Get_Attribute_Definition_Clause
(First_Subtype (Arr),
Attribute_Scalar_Storage_Order),
Comp_ADC_Present => Dummy);
end;
-- Processing that is done only for subtypes
else
-- Acquire alignment from base type. Known_Alignment of the base
-- type is False for Wide_String, for example.
if not Known_Alignment (Arr)
and then Known_Alignment (Base_Type (Arr))
then
Set_Alignment (Arr, Alignment (Base_Type (Arr)));
Adjust_Esize_Alignment (Arr);
end if;
end if;
-- Specific checks for bit-packed arrays
if Is_Bit_Packed_Array (Arr) then
-- Check number of elements for bit-packed arrays that come from
-- source and have compile time known ranges. The bit-packed
-- arrays circuitry does not support arrays with more than
-- Integer'Last + 1 elements, and when this restriction is
-- violated, causes incorrect data access.
-- For the case where this is not compile time known, a run-time
-- check should be generated???
if Comes_From_Source (Arr) and then Is_Constrained (Arr) then
declare
Elmts : Uint;
Index : Node_Id;
Ilen : Node_Id;
Ityp : Entity_Id;
begin
Elmts := Uint_1;
Index := First_Index (Arr);
while Present (Index) loop
Ityp := Etype (Index);
-- Never generate an error if any index is of a generic
-- type. We will check this in instances.
if Is_Generic_Type (Ityp) then
Elmts := Uint_0;
exit;
end if;
Ilen :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ityp, Loc),
Attribute_Name => Name_Range_Length);
Analyze_And_Resolve (Ilen);
-- No attempt is made to check number of elements if not
-- compile time known.
if Nkind (Ilen) /= N_Integer_Literal then
Elmts := Uint_0;
exit;
end if;
Elmts := Elmts * Intval (Ilen);
Next_Index (Index);
end loop;
if Elmts > Intval (High_Bound
(Scalar_Range (Standard_Integer))) + 1
then
Error_Msg_N
("bit packed array type may not have "
& "more than Integer''Last+1 elements", Arr);
end if;
end;
end if;
-- Check size
if Known_RM_Size (Arr) then
declare
SizC : constant Node_Id := Size_Clause (Arr);
Discard : Boolean;
begin
-- It is not clear if it is possible to have no size clause
-- at this stage, but it is not worth worrying about. Post
-- error on the entity name in the size clause if present,
-- else on the type entity itself.
if Present (SizC) then
Check_Size (Name (SizC), Arr, RM_Size (Arr), Discard);
else
Check_Size (Arr, Arr, RM_Size (Arr), Discard);
end if;
end;
end if;
end if;
-- If any of the index types was an enumeration type with a non-
-- standard rep clause, then we indicate that the array type is
-- always packed (even if it is not bit-packed).
if Non_Standard_Enum then
Set_Has_Non_Standard_Rep (Base_Type (Arr));
Set_Is_Packed (Base_Type (Arr));
end if;
Set_Component_Alignment_If_Not_Set (Arr);
-- If the array is packed and bit-packed or packed to eliminate holes
-- in the non-contiguous enumeration index types, we must create the
-- packed array type to be used to actually implement the type. This
-- is only needed for real array types (not for string literal types,
-- since they are present only for the front end).
if Is_Packed (Arr)
and then (Is_Bit_Packed_Array (Arr) or else Non_Standard_Enum)
and then Ekind (Arr) /= E_String_Literal_Subtype
then
Create_Packed_Array_Impl_Type (Arr);
Freeze_And_Append (Packed_Array_Impl_Type (Arr), N, Result);
-- Make sure that we have the necessary routines to implement the
-- packing, and complain now if not. Note that we only test this
-- for constrained array types.
if Is_Constrained (Arr)
and then Is_Bit_Packed_Array (Arr)
and then Present (Packed_Array_Impl_Type (Arr))
and then Is_Array_Type (Packed_Array_Impl_Type (Arr))
then
declare
CS : constant Uint := Component_Size (Arr);
RE : constant RE_Id := Get_Id (UI_To_Int (CS));
begin
if RE /= RE_Null
and then not RTE_Available (RE)
then
Error_Msg_CRT
("packing of " & UI_Image (CS) & "-bit components",
First_Subtype (Etype (Arr)));
-- Cancel the packing
Set_Is_Packed (Base_Type (Arr), False);
Set_Is_Bit_Packed_Array (Base_Type (Arr), False);
Set_Packed_Array_Impl_Type (Arr, Empty);
goto Skip_Packed;
end if;
end;
end if;
-- Size information of packed array type is copied to the array
-- type, since this is really the representation. But do not
-- override explicit existing size values. If the ancestor subtype
-- is constrained the Packed_Array_Impl_Type will be inherited
-- from it, but the size may have been provided already, and
-- must not be overridden either.
if not Has_Size_Clause (Arr)
and then
(No (Ancestor_Subtype (Arr))
or else not Has_Size_Clause (Ancestor_Subtype (Arr)))
then
Copy_Esize (To => Arr, From => Packed_Array_Impl_Type (Arr));
Copy_RM_Size (To => Arr, From => Packed_Array_Impl_Type (Arr));
end if;
if not Has_Alignment_Clause (Arr) then
Copy_Alignment
(To => Arr, From => Packed_Array_Impl_Type (Arr));
end if;
end if;
<<Skip_Packed>>
-- A Ghost type cannot have a component of protected or task type
-- (SPARK RM 6.9(19)).
if Is_Ghost_Entity (Arr) and then Is_Concurrent_Type (Ctyp) then
Error_Msg_N
("ghost array type & cannot have concurrent component type",
Arr);
end if;
end Freeze_Array_Type;
-------------------------------
-- Freeze_Object_Declaration --
-------------------------------
procedure Freeze_Object_Declaration (E : Entity_Id) is
procedure Check_Large_Modular_Array (Typ : Entity_Id);
-- Check that the size of array type Typ can be computed without
-- overflow, and generates a Storage_Error otherwise. This is only
-- relevant for array types whose index has System_Max_Integer_Size
-- bits, where wrap-around arithmetic might yield a meaningless value
-- for the length of the array, or its corresponding attribute.
procedure Check_Pragma_Thread_Local_Storage (Var_Id : Entity_Id);
-- Ensure that the initialization state of variable Var_Id subject
-- to pragma Thread_Local_Storage agrees with the semantics of the
-- pragma.
function Has_Default_Initialization
(Obj_Id : Entity_Id) return Boolean;
-- Determine whether object Obj_Id default initialized
-------------------------------
-- Check_Large_Modular_Array --
-------------------------------
procedure Check_Large_Modular_Array (Typ : Entity_Id) is
Obj_Loc : constant Source_Ptr := Sloc (E);
Idx_Typ : Entity_Id;
begin
-- Nothing to do when expansion is disabled because this routine
-- generates a runtime check.
if not Expander_Active then
return;
-- Nothing to do for String literal subtypes because their index
-- cannot be a modular type.
elsif Ekind (Typ) = E_String_Literal_Subtype then
return;
-- Nothing to do for an imported object because the object will
-- be created on the exporting side.
elsif Is_Imported (E) then
return;
-- Nothing to do for unconstrained array types. This case arises
-- when the object declaration is illegal.
elsif not Is_Constrained (Typ) then
return;
end if;
Idx_Typ := Etype (First_Index (Typ));
-- To prevent arithmetic overflow with large values, we raise
-- Storage_Error under the following guard:
--
-- (Arr'Last / 2 - Arr'First / 2) > (2 ** 30)
--
-- This takes care of the boundary case, but it is preferable to
-- use a smaller limit, because even on 64-bit architectures an
-- array of more than 2 ** 30 bytes is likely to raise
-- Storage_Error.
if Is_Modular_Integer_Type (Idx_Typ)
and then RM_Size (Idx_Typ) = RM_Size (Standard_Long_Long_Integer)
then
Insert_Action (Declaration_Node (E),
Make_Raise_Storage_Error (Obj_Loc,
Condition =>
Make_Op_Ge (Obj_Loc,
Left_Opnd =>
Make_Op_Subtract (Obj_Loc,
Left_Opnd =>
Make_Op_Divide (Obj_Loc,
Left_Opnd =>
Make_Attribute_Reference (Obj_Loc,
Prefix =>
New_Occurrence_Of (Typ, Obj_Loc),
Attribute_Name => Name_Last),
Right_Opnd =>
Make_Integer_Literal (Obj_Loc, Uint_2)),
Right_Opnd =>
Make_Op_Divide (Obj_Loc,
Left_Opnd =>
Make_Attribute_Reference (Obj_Loc,
Prefix =>
New_Occurrence_Of (Typ, Obj_Loc),
Attribute_Name => Name_First),
Right_Opnd =>
Make_Integer_Literal (Obj_Loc, Uint_2))),
Right_Opnd =>
Make_Integer_Literal (Obj_Loc, (Uint_2 ** 30))),
Reason => SE_Object_Too_Large));
end if;
end Check_Large_Modular_Array;
---------------------------------------
-- Check_Pragma_Thread_Local_Storage --
---------------------------------------
procedure Check_Pragma_Thread_Local_Storage (Var_Id : Entity_Id) is
function Has_Incompatible_Initialization
(Var_Decl : Node_Id) return Boolean;
-- Determine whether variable Var_Id with declaration Var_Decl is
-- initialized with a value that violates the semantics of pragma
-- Thread_Local_Storage.
-------------------------------------
-- Has_Incompatible_Initialization --
-------------------------------------
function Has_Incompatible_Initialization
(Var_Decl : Node_Id) return Boolean
is
Init_Expr : constant Node_Id := Expression (Var_Decl);
begin
-- The variable is default-initialized. This directly violates
-- the semantics of the pragma.
if Has_Default_Initialization (Var_Id) then
return True;
-- The variable has explicit initialization. In this case only
-- a handful of values satisfy the semantics of the pragma.
elsif Has_Init_Expression (Var_Decl)
and then Present (Init_Expr)
then
-- "null" is a legal form of initialization
if Nkind (Init_Expr) = N_Null then
return False;
-- A static expression is a legal form of initialization
elsif Is_Static_Expression (Init_Expr) then
return False;
-- A static aggregate is a legal form of initialization
elsif Nkind (Init_Expr) = N_Aggregate
and then Compile_Time_Known_Aggregate (Init_Expr)
then
return False;
-- All other initialization expressions violate the semantic
-- of the pragma.
else
return True;
end if;
-- The variable lacks any kind of initialization, which agrees
-- with the semantics of the pragma.
else
return False;
end if;
end Has_Incompatible_Initialization;