-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
with Output; use Output;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
-with Scans; use Scans;
-with Scn; use Scn;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Stand; use Stand;
with Style;
with Stringt; use Stringt;
+with Table;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uname; use Uname;
with GNAT.HTable; use GNAT.HTable;
+
package body Sem_Util is
----------------------------------------
-- safely used by New_Copy_Tree, since there is no case of a recursive
-- call from the processing inside New_Copy_Tree.
- NCT_Hash_Threshhold : constant := 20;
+ NCT_Hash_Threshold : constant := 20;
-- If there are more than this number of pairs of entries in the
-- map, then Hash_Tables_Used will be set, and the hash tables will
-- be initialized and used for the searches.
-- Set to True if hash tables are in use
NCT_Table_Entries : Nat;
- -- Count entries in table to see if threshhold is reached
+ -- Count entries in table to see if threshold is reached
NCT_Hash_Table_Setup : Boolean := False;
-- Set to True if hash table contains data. We set this True if we
subtype NCT_Header_Num is Int range 0 .. 511;
-- Defines range of headers in hash tables (512 headers)
+ ----------------------------------
+ -- Order Dependence (AI05-0144) --
+ ----------------------------------
+
+ -- Each actual in a call is entered into the table below. A flag indicates
+ -- whether the corresponding formal is OUT or IN OUT. Each top-level call
+ -- (procedure call, condition, assignment) examines all the actuals for a
+ -- possible order dependence. The table is reset after each such check.
+ -- The actuals to be checked in a call to Check_Order_Dependence are at
+ -- positions 1 .. Last.
+
+ type Actual_Name is record
+ Act : Node_Id;
+ Is_Writable : Boolean;
+ end record;
+
+ package Actuals_In_Call is new Table.Table (
+ Table_Component_Type => Actual_Name,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Actuals");
+
-----------------------
-- Local Subprograms --
-----------------------
Analyze (N);
end Add_Global_Declaration;
+ -----------------
+ -- Addressable --
+ -----------------
+
+ -- For now, just 8/16/32/64. but analyze later if AAMP is special???
+
+ function Addressable (V : Uint) return Boolean is
+ begin
+ return V = Uint_8 or else
+ V = Uint_16 or else
+ V = Uint_32 or else
+ V = Uint_64;
+ end Addressable;
+
+ function Addressable (V : Int) return Boolean is
+ begin
+ return V = 8 or else
+ V = 16 or else
+ V = 32 or else
+ V = 64;
+ end Addressable;
+
-----------------------
-- Alignment_In_Bits --
-----------------------
end if;
end Apply_Compile_Time_Constraint_Error;
+ --------------------------------
+ -- Bad_Predicated_Subtype_Use --
+ --------------------------------
+
+ procedure Bad_Predicated_Subtype_Use
+ (Msg : String;
+ N : Node_Id;
+ Typ : Entity_Id)
+ is
+ begin
+ if Has_Predicates (Typ) then
+ if Is_Generic_Actual_Type (Typ) then
+ Error_Msg_FE (Msg & '?', N, Typ);
+ Error_Msg_F ("\Program_Error will be raised at run time?", N);
+ Insert_Action (N,
+ Make_Raise_Program_Error (Sloc (N),
+ Reason => PE_Bad_Predicated_Generic_Type));
+
+ else
+ Error_Msg_FE (Msg, N, Typ);
+ end if;
+ end if;
+ end Bad_Predicated_Subtype_Use;
+
--------------------------
-- Build_Actual_Subtype --
--------------------------
end loop;
end if;
- Subt :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('S'));
+ Subt := Make_Temporary (Loc, 'S', Related_Node => N);
Set_Is_Internal (Subt);
Decl :=
and then Is_Constrained (Root_Type (T)))
and then not Has_Unknown_Discriminants (T)
then
- -- If the type of the dereference is already constrained, it
- -- is an actual subtype.
+ -- If the type of the dereference is already constrained, it is an
+ -- actual subtype.
if Is_Array_Type (Etype (N))
and then Is_Constrained (Etype (N))
return Empty;
end if;
- Subt :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('S'));
+ Subt := Make_Temporary (Loc, 'S');
Set_Is_Internal (Subt);
Decl :=
end if;
declare
- Act : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('S'));
-
+ Act : constant Entity_Id := Make_Temporary (Loc, 'S');
Constraints : constant List_Id := New_List;
Decl : Node_Id;
end if;
end Cannot_Raise_Constraint_Error;
+ -----------------------------------------
+ -- Check_Dynamically_Tagged_Expression --
+ -----------------------------------------
+
+ procedure Check_Dynamically_Tagged_Expression
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Related_Nod : Node_Id)
+ is
+ begin
+ pragma Assert (Is_Tagged_Type (Typ));
+
+ -- In order to avoid spurious errors when analyzing the expanded code,
+ -- this check is done only for nodes that come from source and for
+ -- actuals of generic instantiations.
+
+ if (Comes_From_Source (Related_Nod)
+ or else In_Generic_Actual (Expr))
+ and then (Is_Class_Wide_Type (Etype (Expr))
+ or else Is_Dynamically_Tagged (Expr))
+ and then Is_Tagged_Type (Typ)
+ and then not Is_Class_Wide_Type (Typ)
+ then
+ Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
+ end if;
+ end Check_Dynamically_Tagged_Expression;
+
--------------------------
-- Check_Fully_Declared --
--------------------------
end if;
end Check_Nested_Access;
+ ----------------------------
+ -- Check_Order_Dependence --
+ ----------------------------
+
+ procedure Check_Order_Dependence is
+ Act1 : Node_Id;
+ Act2 : Node_Id;
+
+ begin
+ if Ada_Version < Ada_2012 then
+ return;
+ end if;
+
+ -- Ada 2012 AI04-0144-2: Dangerous order dependence. Actuals in nested
+ -- calls within a construct have been collected. If one of them is
+ -- writable and overlaps with another one, evaluation of the enclosing
+ -- construct is nondeterministic. This is illegal in Ada 2012, but is
+ -- treated as a warning for now.
+
+ for J in 1 .. Actuals_In_Call.Last loop
+ if Actuals_In_Call.Table (J).Is_Writable then
+ Act1 := Actuals_In_Call.Table (J).Act;
+
+ if Nkind (Act1) = N_Attribute_Reference then
+ Act1 := Prefix (Act1);
+ end if;
+
+ for K in 1 .. Actuals_In_Call.Last loop
+ if K /= J then
+ Act2 := Actuals_In_Call.Table (K).Act;
+
+ if Nkind (Act2) = N_Attribute_Reference then
+ Act2 := Prefix (Act2);
+ end if;
+
+ if Actuals_In_Call.Table (K).Is_Writable
+ and then K < J
+ then
+ -- Already checked
+
+ null;
+
+ elsif Denotes_Same_Object (Act1, Act2)
+ and then Parent (Act1) /= Parent (Act2)
+ then
+ Error_Msg_N
+ ("result may differ if evaluated "
+ & "after other actual in expression?", Act1);
+ end if;
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ -- Remove checked actuals from table
+
+ Actuals_In_Call.Set_Last (0);
+ end Check_Order_Dependence;
+
------------------------------------------
-- Check_Potentially_Blocking_Operation --
------------------------------------------
procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
S : Entity_Id;
+
begin
-- N is one of the potentially blocking operations listed in 9.5.1(8).
-- When pragma Detect_Blocking is active, the run time will raise
if Is_Protected_Type (S) then
Error_Msg_N
("potentially blocking operation in protected operation?", N);
-
return;
end if;
function Search_Tag (Iface : Entity_Id) return Entity_Id is
ADT : Elmt_Id;
-
begin
- ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
+ if not Is_CPP_Class (T) then
+ ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
+ else
+ ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
+ end if;
+
while Present (ADT)
- and then Ekind (Node (ADT)) = E_Constant
+ and then Is_Tag (Node (ADT))
and then Related_Type (Node (ADT)) /= Iface
loop
- -- Skip the secondary dispatch tables of Iface
+ -- Skip secondary dispatch table referencing thunks to user
+ -- defined primitives covered by this interface.
+ pragma Assert (Has_Suffix (Node (ADT), 'P'));
Next_Elmt (ADT);
- Next_Elmt (ADT);
- Next_Elmt (ADT);
- Next_Elmt (ADT);
+
+ -- Skip secondary dispatch tables of Ada types
+
+ if not Is_CPP_Class (T) then
+
+ -- Skip secondary dispatch table referencing thunks to
+ -- predefined primitives.
+
+ pragma Assert (Has_Suffix (Node (ADT), 'Y'));
+ Next_Elmt (ADT);
+
+ -- Skip secondary dispatch table referencing user-defined
+ -- primitives covered by this interface.
+
+ pragma Assert (Has_Suffix (Node (ADT), 'D'));
+ Next_Elmt (ADT);
+
+ -- Skip secondary dispatch table referencing predefined
+ -- primitives.
+
+ pragma Assert (Has_Suffix (Node (ADT), 'Z'));
+ Next_Elmt (ADT);
+ end if;
end loop;
- pragma Assert (Ekind (Node (ADT)) = E_Constant);
+ pragma Assert (Is_Tag (Node (ADT)));
return Node (ADT);
end Search_Tag;
end loop;
end Collect_Interfaces_Info;
+ ---------------------
+ -- Collect_Parents --
+ ---------------------
+
+ procedure Collect_Parents
+ (T : Entity_Id;
+ List : out Elist_Id;
+ Use_Full_View : Boolean := True)
+ is
+ Current_Typ : Entity_Id := T;
+ Parent_Typ : Entity_Id;
+
+ begin
+ List := New_Elmt_List;
+
+ -- No action if the if the type has no parents
+
+ if T = Etype (T) then
+ return;
+ end if;
+
+ loop
+ Parent_Typ := Etype (Current_Typ);
+
+ if Is_Private_Type (Parent_Typ)
+ and then Present (Full_View (Parent_Typ))
+ and then Use_Full_View
+ then
+ Parent_Typ := Full_View (Base_Type (Parent_Typ));
+ end if;
+
+ Append_Elmt (Parent_Typ, List);
+
+ exit when Parent_Typ = Current_Typ;
+ Current_Typ := Parent_Typ;
+ end loop;
+ end Collect_Parents;
+
----------------------------------
-- Collect_Primitive_Operations --
----------------------------------
Formal_Derived : Boolean := False;
Id : Entity_Id;
+ function Match (E : Entity_Id) return Boolean;
+ -- True if E's base type is B_Type, or E is of an anonymous access type
+ -- and the base type of its designated type is B_Type.
+
+ -----------
+ -- Match --
+ -----------
+
+ function Match (E : Entity_Id) return Boolean is
+ Etyp : Entity_Id := Etype (E);
+
+ begin
+ if Ekind (Etyp) = E_Anonymous_Access_Type then
+ Etyp := Designated_Type (Etyp);
+ end if;
+
+ return Base_Type (Etyp) = B_Type;
+ end Match;
+
+ -- Start of processing for Collect_Primitive_Operations
+
begin
-- For tagged types, the primitive operations are collected as they
-- are declared, and held in an explicit list which is simply returned.
then
Is_Prim := False;
- if Base_Type (Etype (Id)) = B_Type then
+ if Match (Id) then
Is_Prim := True;
+
else
Formal := First_Formal (Id);
while Present (Formal) loop
- if Base_Type (Etype (Formal)) = B_Type then
- Is_Prim := True;
- exit;
-
- elsif Ekind (Etype (Formal)) = E_Anonymous_Access_Type
- and then Base_Type
- (Designated_Type (Etype (Formal))) = B_Type
- then
+ if Match (Formal) then
Is_Prim := True;
exit;
end if;
and then (not Formal_Derived
or else Present (Alias (Id)))
then
- Append_Elmt (Id, Op_List);
+ -- In the special case of an equality operator aliased to
+ -- an overriding dispatching equality belonging to the same
+ -- type, we don't include it in the list of primitives.
+ -- This avoids inheriting multiple equality operators when
+ -- deriving from untagged private types whose full type is
+ -- tagged, which can otherwise cause ambiguities. Note that
+ -- this should only happen for this kind of untagged parent
+ -- type, since normally dispatching operations are inherited
+ -- using the type's Primitive_Operations list.
+
+ if Chars (Id) = Name_Op_Eq
+ and then Is_Dispatching_Operation (Id)
+ and then Present (Alias (Id))
+ and then Present (Overridden_Operation (Alias (Id)))
+ and then Base_Type (Etype (First_Entity (Id))) =
+ Base_Type (Etype (First_Entity (Alias (Id))))
+ then
+ null;
+
+ -- Include the subprogram in the list of primitives
+
+ else
+ Append_Elmt (Id, Op_List);
+ end if;
end if;
end if;
Next_Entity (Id);
- -- For a type declared in System, some of its operations
- -- may appear in the target-specific extension to System.
+ -- For a type declared in System, some of its operations may
+ -- appear in the target-specific extension to System.
if No (Id)
- and then Chars (B_Scope) = Name_System
- and then Scope (B_Scope) = Standard_Standard
+ and then B_Scope = RTU_Entity (System)
and then Present_System_Aux
then
B_Scope := System_Aux_Id;
-- so we can continue semantic analysis
elsif Nam = Error then
- Err :=
- Make_Defining_Identifier (Sloc (N),
- Chars => New_Internal_Name ('T'));
+ Err := Make_Temporary (Sloc (N), 'T');
Set_Defining_Unit_Name (N, Err);
return Err;
end Denotes_Discriminant;
+ -------------------------
+ -- Denotes_Same_Object --
+ -------------------------
+
+ function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
+ Obj1 : Node_Id := A1;
+ Obj2 : Node_Id := A2;
+
+ procedure Check_Renaming (Obj : in out Node_Id);
+ -- If an object is a renaming, examine renamed object. If it is a
+ -- dereference of a variable, or an indexed expression with non-constant
+ -- indexes, no overlap check can be reported.
+
+ --------------------
+ -- Check_Renaming --
+ --------------------
+
+ procedure Check_Renaming (Obj : in out Node_Id) is
+ begin
+ if Is_Entity_Name (Obj)
+ and then Present (Renamed_Entity (Entity (Obj)))
+ then
+ Obj := Renamed_Entity (Entity (Obj));
+ if Nkind (Obj) = N_Explicit_Dereference
+ and then Is_Variable (Prefix (Obj))
+ then
+ Obj := Empty;
+
+ elsif Nkind (Obj) = N_Indexed_Component then
+ declare
+ Indx : Node_Id;
+
+ begin
+ Indx := First (Expressions (Obj));
+ while Present (Indx) loop
+ if not Is_OK_Static_Expression (Indx) then
+ Obj := Empty;
+ exit;
+ end if;
+
+ Next_Index (Indx);
+ end loop;
+ end;
+ end if;
+ end if;
+ end Check_Renaming;
+
+ -- Start of processing for Denotes_Same_Object
+
+ begin
+ Check_Renaming (Obj1);
+ Check_Renaming (Obj2);
+
+ if No (Obj1)
+ or else No (Obj2)
+ then
+ return False;
+ end if;
+
+ -- If we have entity names, then must be same entity
+
+ if Is_Entity_Name (Obj1) then
+ if Is_Entity_Name (Obj2) then
+ return Entity (Obj1) = Entity (Obj2);
+ else
+ return False;
+ end if;
+
+ -- No match if not same node kind
+
+ elsif Nkind (Obj1) /= Nkind (Obj2) then
+ return False;
+
+ -- For selected components, must have same prefix and selector
+
+ elsif Nkind (Obj1) = N_Selected_Component then
+ return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
+ and then
+ Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
+
+ -- For explicit dereferences, prefixes must be same
+
+ elsif Nkind (Obj1) = N_Explicit_Dereference then
+ return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
+
+ -- For indexed components, prefixes and all subscripts must be the same
+
+ elsif Nkind (Obj1) = N_Indexed_Component then
+ if Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
+ declare
+ Indx1 : Node_Id;
+ Indx2 : Node_Id;
+
+ begin
+ Indx1 := First (Expressions (Obj1));
+ Indx2 := First (Expressions (Obj2));
+ while Present (Indx1) loop
+
+ -- Indexes must denote the same static value or same object
+
+ if Is_OK_Static_Expression (Indx1) then
+ if not Is_OK_Static_Expression (Indx2) then
+ return False;
+
+ elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
+ return False;
+ end if;
+
+ elsif not Denotes_Same_Object (Indx1, Indx2) then
+ return False;
+ end if;
+
+ Next (Indx1);
+ Next (Indx2);
+ end loop;
+
+ return True;
+ end;
+ else
+ return False;
+ end if;
+
+ -- For slices, prefixes must match and bounds must match
+
+ elsif Nkind (Obj1) = N_Slice
+ and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
+ then
+ declare
+ Lo1, Lo2, Hi1, Hi2 : Node_Id;
+
+ begin
+ Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
+ Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
+
+ -- Check whether bounds are statically identical. There is no
+ -- attempt to detect partial overlap of slices.
+
+ return Denotes_Same_Object (Lo1, Lo2)
+ and then Denotes_Same_Object (Hi1, Hi2);
+ end;
+
+ -- Literals will appear as indexes. Isn't this where we should check
+ -- Known_At_Compile_Time at least if we are generating warnings ???
+
+ elsif Nkind (Obj1) = N_Integer_Literal then
+ return Intval (Obj1) = Intval (Obj2);
+
+ else
+ return False;
+ end if;
+ end Denotes_Same_Object;
+
+ -------------------------
+ -- Denotes_Same_Prefix --
+ -------------------------
+
+ function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
+
+ begin
+ if Is_Entity_Name (A1) then
+ if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
+ and then not Is_Access_Type (Etype (A1))
+ then
+ return Denotes_Same_Object (A1, Prefix (A2))
+ or else Denotes_Same_Prefix (A1, Prefix (A2));
+ else
+ return False;
+ end if;
+
+ elsif Is_Entity_Name (A2) then
+ return Denotes_Same_Prefix (A2, A1);
+
+ elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
+ and then
+ Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
+ then
+ declare
+ Root1, Root2 : Node_Id;
+ Depth1, Depth2 : Int := 0;
+
+ begin
+ Root1 := Prefix (A1);
+ while not Is_Entity_Name (Root1) loop
+ if not Nkind_In
+ (Root1, N_Selected_Component, N_Indexed_Component)
+ then
+ return False;
+ else
+ Root1 := Prefix (Root1);
+ end if;
+
+ Depth1 := Depth1 + 1;
+ end loop;
+
+ Root2 := Prefix (A2);
+ while not Is_Entity_Name (Root2) loop
+ if not Nkind_In
+ (Root2, N_Selected_Component, N_Indexed_Component)
+ then
+ return False;
+ else
+ Root2 := Prefix (Root2);
+ end if;
+
+ Depth2 := Depth2 + 1;
+ end loop;
+
+ -- If both have the same depth and they do not denote the same
+ -- object, they are disjoint and not warning is needed.
+
+ if Depth1 = Depth2 then
+ return False;
+
+ elsif Depth1 > Depth2 then
+ Root1 := Prefix (A1);
+ for I in 1 .. Depth1 - Depth2 - 1 loop
+ Root1 := Prefix (Root1);
+ end loop;
+
+ return Denotes_Same_Object (Root1, A2);
+
+ else
+ Root2 := Prefix (A2);
+ for I in 1 .. Depth2 - Depth1 - 1 loop
+ Root2 := Prefix (Root2);
+ end loop;
+
+ return Denotes_Same_Object (A1, Root2);
+ end if;
+ end;
+
+ else
+ return False;
+ end if;
+ end Denotes_Same_Prefix;
+
----------------------
-- Denotes_Variable --
----------------------
end if;
end Designate_Same_Unit;
+ --------------------------
+ -- Enclosing_CPP_Parent --
+ --------------------------
+
+ function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
+ Parent_Typ : Entity_Id := Typ;
+
+ begin
+ while not Is_CPP_Class (Parent_Typ)
+ and then Etype (Parent_Typ) /= Parent_Typ
+ loop
+ Parent_Typ := Etype (Parent_Typ);
+
+ if Is_Private_Type (Parent_Typ) then
+ Parent_Typ := Full_View (Base_Type (Parent_Typ));
+ end if;
+ end loop;
+
+ pragma Assert (Is_CPP_Class (Parent_Typ));
+ return Parent_Typ;
+ end Enclosing_CPP_Parent;
+
----------------------------
-- Enclosing_Generic_Body --
----------------------------
elsif Ekind (Dynamic_Scope) = E_Task_Type then
return Get_Task_Body_Procedure (Dynamic_Scope);
- elsif Convention (Dynamic_Scope) = Convention_Protected then
+ elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
+ and then Present (Full_View (Dynamic_Scope))
+ and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
+ then
+ return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
+
+ -- No body is generated if the protected operation is eliminated
+
+ elsif Convention (Dynamic_Scope) = Convention_Protected
+ and then not Is_Eliminated (Dynamic_Scope)
+ and then Present (Protected_Body_Subprogram (Dynamic_Scope))
+ then
return Protected_Body_Subprogram (Dynamic_Scope);
else
Set_Scope (Def_Id, Current_Scope);
return;
- -- Analogous to privals, the discriminal generated for an entry
- -- index parameter acts as a weak declaration. Perform minimal
- -- decoration to avoid bogus errors.
+ -- Analogous to privals, the discriminal generated for an entry index
+ -- parameter acts as a weak declaration. Perform minimal decoration
+ -- to avoid bogus errors.
elsif Is_Discriminal (Def_Id)
and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
Set_Scope (Def_Id, Current_Scope);
return;
- -- In the body or private part of an instance, a type extension
- -- may introduce a component with the same name as that of an
- -- actual. The legality rule is not enforced, but the semantics
- -- of the full type with two components of the same name are not
- -- clear at this point ???
+ -- In the body or private part of an instance, a type extension may
+ -- introduce a component with the same name as that of an actual. The
+ -- legality rule is not enforced, but the semantics of the full type
+ -- with two components of same name are not clear at this point???
elsif In_Instance_Not_Visible then
null;
then
null;
- -- Conversely, with front-end inlining we may compile the parent
- -- body first, and a child unit subsequently. The context is now
- -- the parent spec, and body entities are not visible.
+ -- Conversely, with front-end inlining we may compile the parent body
+ -- first, and a child unit subsequently. The context is now the
+ -- parent spec, and body entities are not visible.
elsif Is_Child_Unit (Def_Id)
and then Is_Package_Body_Entity (E)
Error_Msg_Sloc := Sloc (E);
-- If the previous declaration is an incomplete type declaration
- -- this may be an attempt to complete it with a private type.
- -- The following avoids confusing cascaded errors.
+ -- this may be an attempt to complete it with a private type. The
+ -- following avoids confusing cascaded errors.
if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
Error_Msg_N ("& conflicts with declaration#", E);
return;
- -- If the name of the unit appears in its own context clause,
- -- a dummy package with the name has already been created, and
- -- the error emitted. Try to continue quietly.
+ -- If the name of the unit appears in its own context clause, a
+ -- dummy package with the name has already been created, and the
+ -- error emitted. Try to continue quietly.
elsif Error_Posted (E)
and then Sloc (E) = No_Location
-- Avoid cascaded messages with duplicate components in
-- derived types.
- if Ekind (E) = E_Component
- or else Ekind (E) = E_Discriminant
- then
+ if Ekind_In (E, E_Component, E_Discriminant) then
return;
end if;
end if;
Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
end if;
- -- If entity is in standard, then we are in trouble, because
- -- it means that we have a library package with a duplicated
- -- name. That's hard to recover from, so abort!
+ -- If entity is in standard, then we are in trouble, because it
+ -- means that we have a library package with a duplicated name.
+ -- That's hard to recover from, so abort!
if S = Standard_Standard then
raise Unrecoverable_Error;
end if;
end if;
- -- If we fall through, declaration is OK , or OK enough to continue
+ -- If we fall through, declaration is OK, at least OK enough to continue
- -- If Def_Id is a discriminant or a record component we are in the
- -- midst of inheriting components in a derived record definition.
- -- Preserve their Ekind and Etype.
+ -- If Def_Id is a discriminant or a record component we are in the midst
+ -- of inheriting components in a derived record definition. Preserve
+ -- their Ekind and Etype.
- if Ekind (Def_Id) = E_Discriminant
- or else Ekind (Def_Id) = E_Component
- then
+ if Ekind_In (Def_Id, E_Discriminant, E_Component) then
null;
- -- If a type is already set, leave it alone (happens whey a type
- -- declaration is reanalyzed following a call to the optimizer)
+ -- If a type is already set, leave it alone (happens when a type
+ -- declaration is reanalyzed following a call to the optimizer).
elsif Present (Etype (Def_Id)) then
null;
-- Inherited discriminants and components in derived record types are
-- immediately visible. Itypes are not.
- if Ekind (Def_Id) = E_Discriminant
- or else Ekind (Def_Id) = E_Component
+ if Ekind_In (Def_Id, E_Discriminant, E_Component)
or else (No (Corresponding_Remote_Type (Def_Id))
and then not Is_Itype (Def_Id))
then
and then In_Extended_Main_Source_Unit (Def_Id)
- -- Finally, the hidden entity must be either immediately visible
- -- or use visible (from a used package)
+ -- Finally, the hidden entity must be either immediately visible or
+ -- use visible (i.e. from a used package).
and then
(Is_Immediately_Visible (C)
Call := Empty;
end Find_Actual;
+ ---------------------------
+ -- Find_Body_Discriminal --
+ ---------------------------
+
+ function Find_Body_Discriminal
+ (Spec_Discriminant : Entity_Id) return Entity_Id
+ is
+ pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
+
+ Tsk : constant Entity_Id :=
+ Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
+ Disc : Entity_Id;
+
+ begin
+ -- Find discriminant of original concurrent type, and use its current
+ -- discriminal, which is the renaming within the task/protected body.
+
+ Disc := First_Discriminant (Tsk);
+ while Present (Disc) loop
+ if Chars (Disc) = Chars (Spec_Discriminant) then
+ return Discriminal (Disc);
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ -- That loop should always succeed in finding a matching entry and
+ -- returning. Fatal error if not.
+
+ raise Program_Error;
+ end Find_Body_Discriminal;
+
-------------------------------------
-- Find_Corresponding_Discriminant --
-------------------------------------
end Find_Corresponding_Discriminant;
--------------------------
- -- Find_Overlaid_Object --
+ -- Find_Overlaid_Entity --
--------------------------
- function Find_Overlaid_Object (N : Node_Id) return Entity_Id is
- Expr : Node_Id;
+ procedure Find_Overlaid_Entity
+ (N : Node_Id;
+ Ent : out Entity_Id;
+ Off : out Boolean)
+ is
+ Expr : Node_Id;
begin
-- We are looking for one of the two following forms:
-- In the second case, the expr is either Y'Address, or recursively a
-- constant that eventually references Y'Address.
+ Ent := Empty;
+ Off := False;
+
if Nkind (N) = N_Attribute_Definition_Clause
and then Chars (N) = Name_Address
then
- -- This loop checks the form of the expression for Y'Address where Y
- -- is an object entity name. The first loop checks the original
- -- expression in the attribute definition clause. Subsequent loops
- -- check referenced constants.
-
Expr := Expression (N);
+
+ -- This loop checks the form of the expression for Y'Address,
+ -- using recursion to deal with intermediate constants.
+
loop
- -- Check for Y'Address where Y is an object entity
+ -- Check for Y'Address
if Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address
- and then Is_Entity_Name (Prefix (Expr))
- and then Is_Object (Entity (Prefix (Expr)))
then
- return Entity (Prefix (Expr));
+ Expr := Prefix (Expr);
+ exit;
-- Check for Const where Const is a constant entity
-- Anything else does not need checking
else
- exit;
+ return;
end if;
end loop;
- end if;
- return Empty;
- end Find_Overlaid_Object;
+ -- This loop checks the form of the prefix for an entity,
+ -- using recursion to deal with intermediate components.
+
+ loop
+ -- Check for Y where Y is an entity
+
+ if Is_Entity_Name (Expr) then
+ Ent := Entity (Expr);
+ return;
+
+ -- Check for components
+
+ elsif
+ Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) then
+
+ Expr := Prefix (Expr);
+ Off := True;
+
+ -- Anything else does not need checking
+
+ else
+ return;
+ end if;
+ end loop;
+ end if;
+ end Find_Overlaid_Entity;
-------------------------
-- Find_Parameter_Type --
end if;
end First_Actual;
- -------------------------
- -- Full_Qualified_Name --
- -------------------------
-
- function Full_Qualified_Name (E : Entity_Id) return String_Id is
- Res : String_Id;
- pragma Warnings (Off, Res);
-
- function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id;
- -- Compute recursively the qualified name without NUL at the end
-
- ----------------------------------
- -- Internal_Full_Qualified_Name --
- ----------------------------------
-
- function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id is
- Ent : Entity_Id := E;
- Parent_Name : String_Id := No_String;
-
- begin
- -- Deals properly with child units
-
- if Nkind (Ent) = N_Defining_Program_Unit_Name then
- Ent := Defining_Identifier (Ent);
- end if;
-
- -- Compute qualification recursively (only "Standard" has no scope)
-
- if Present (Scope (Scope (Ent))) then
- Parent_Name := Internal_Full_Qualified_Name (Scope (Ent));
- end if;
-
- -- Every entity should have a name except some expanded blocks
- -- don't bother about those.
-
- if Chars (Ent) = No_Name then
- return Parent_Name;
- end if;
-
- -- Add a period between Name and qualification
-
- if Parent_Name /= No_String then
- Start_String (Parent_Name);
- Store_String_Char (Get_Char_Code ('.'));
-
- else
- Start_String;
- end if;
-
- -- Generates the entity name in upper case
-
- Get_Decoded_Name_String (Chars (Ent));
- Set_All_Upper_Case;
- Store_String_Chars (Name_Buffer (1 .. Name_Len));
- return End_String;
- end Internal_Full_Qualified_Name;
-
- -- Start of processing for Full_Qualified_Name
-
- begin
- Res := Internal_Full_Qualified_Name (E);
- Store_String_Char (Get_Char_Code (ASCII.NUL));
- return End_String;
- end Full_Qualified_Name;
-
-----------------------
-- Gather_Components --
-----------------------
Default : Alignment_Result) return Alignment_Result
is
Result : Alignment_Result := Known_Compatible;
- -- Set to result if Problem_Prefix or Problem_Offset returns True.
- -- Note that once a value of Known_Incompatible is set, it is sticky
- -- and does not get changed to Unknown (the value in Result only gets
- -- worse as we go along, never better).
+ -- Holds the current status of the result. Note that once a value of
+ -- Known_Incompatible is set, it is sticky and does not get changed
+ -- to Unknown (the value in Result only gets worse as we go along,
+ -- never better).
- procedure Check_Offset (Offs : Uint);
- -- Called when Expr is a selected or indexed component with Offs set
- -- to resp Component_First_Bit or Component_Size. Checks that if the
- -- offset is specified it is compatible with the object alignment
- -- requirements. The value in Result is modified accordingly.
+ Offs : Uint := No_Uint;
+ -- Set to a factor of the offset from the base object when Expr is a
+ -- selected or indexed component, based on Component_Bit_Offset and
+ -- Component_Size respectively. A negative value is used to represent
+ -- a value which is not known at compile time.
procedure Check_Prefix;
-- Checks the prefix recursively in the case where the expression
-- compatible, or known incompatible), then set Result to R.
------------------
- -- Check_Offset --
- ------------------
-
- procedure Check_Offset (Offs : Uint) is
- begin
- -- Unspecified or zero offset is always OK
-
- if Offs = No_Uint or else Offs = Uint_0 then
- null;
-
- -- If we do not know required alignment, any non-zero offset is
- -- a potential problem (but certainly may be OK, so result is
- -- unknown).
-
- elsif Unknown_Alignment (Obj) then
- Set_Result (Unknown);
-
- -- If we know the required alignment, see if offset is compatible
-
- else
- if Offs mod (System_Storage_Unit * Alignment (Obj)) /= 0 then
- Set_Result (Known_Incompatible);
- end if;
- end if;
- end Check_Offset;
-
- ------------------
-- Check_Prefix --
------------------
Set_Result (Unknown);
end if;
- -- Check possible bad component offset and check prefix
+ -- Check prefix and component offset
- Check_Offset
- (Component_Bit_Offset (Entity (Selector_Name (Expr))));
Check_Prefix;
+ Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
-- If Expr is an indexed component, we must make sure there is no
-- potentially troublesome Component_Size clause and that the array
-- is not bit-packed.
elsif Nkind (Expr) = N_Indexed_Component then
+ declare
+ Typ : constant Entity_Id := Etype (Prefix (Expr));
+ Ind : constant Node_Id := First_Index (Typ);
- -- Bit packed array always generates unknown alignment
+ begin
+ -- Bit packed array always generates unknown alignment
- if Is_Bit_Packed_Array (Etype (Prefix (Expr))) then
- Set_Result (Unknown);
- end if;
+ if Is_Bit_Packed_Array (Typ) then
+ Set_Result (Unknown);
+ end if;
- -- Check possible bad component size and check prefix
+ -- Check prefix and component offset
- Check_Offset (Component_Size (Etype (Prefix (Expr))));
- Check_Prefix;
+ Check_Prefix;
+ Offs := Component_Size (Typ);
+
+ -- Small optimization: compute the full offset when possible
+
+ if Offs /= No_Uint
+ and then Offs > Uint_0
+ and then Present (Ind)
+ and then Nkind (Ind) = N_Range
+ and then Compile_Time_Known_Value (Low_Bound (Ind))
+ and then Compile_Time_Known_Value (First (Expressions (Expr)))
+ then
+ Offs := Offs * (Expr_Value (First (Expressions (Expr)))
+ - Expr_Value (Low_Bound ((Ind))));
+ end if;
+ end;
end if;
+ -- If we have a null offset, the result is entirely determined by
+ -- the base object and has already been computed recursively.
+
+ if Offs = Uint_0 then
+ null;
+
-- Case where we know the alignment of the object
- if Known_Alignment (Obj) then
+ elsif Known_Alignment (Obj) then
declare
ObjA : constant Uint := Alignment (Obj);
- ExpA : Uint := No_Uint;
- SizA : Uint := No_Uint;
+ ExpA : Uint := No_Uint;
+ SizA : Uint := No_Uint;
begin
-- If alignment of Obj is 1, then we are always OK
-- Alignment of Obj is greater than 1, so we need to check
else
- -- See if Expr is an object with known alignment
+ -- If we have an offset, see if it is compatible
- if Is_Entity_Name (Expr)
+ if Offs /= No_Uint and Offs > Uint_0 then
+ if Offs mod (System_Storage_Unit * ObjA) /= 0 then
+ Set_Result (Known_Incompatible);
+ end if;
+
+ -- See if Expr is an object with known alignment
+
+ elsif Is_Entity_Name (Expr)
and then Known_Alignment (Entity (Expr))
then
ExpA := Alignment (Entity (Expr));
elsif Known_Alignment (Etype (Expr)) then
ExpA := Alignment (Etype (Expr));
+
+ -- Otherwise the alignment is unknown
+
+ else
+ Set_Result (Default);
end if;
-- If we got an alignment, see if it is acceptable
- if ExpA /= No_Uint then
- if ExpA < ObjA then
- Set_Result (Known_Incompatible);
- end if;
+ if ExpA /= No_Uint and then ExpA < ObjA then
+ Set_Result (Known_Incompatible);
+ end if;
- -- Case of Expr alignment unknown
+ -- If Expr is not a piece of a larger object, see if size
+ -- is given. If so, check that it is not too small for the
+ -- required alignment.
- else
- Set_Result (Default);
- end if;
+ if Offs /= No_Uint then
+ null;
- -- See if size is given. If so, check that it is not too
- -- small for the required alignment.
- -- See if Expr is an object with known alignment
+ -- See if Expr is an object with known size
- if Is_Entity_Name (Expr)
+ elsif Is_Entity_Name (Expr)
and then Known_Static_Esize (Entity (Expr))
then
SizA := Esize (Entity (Expr));
end if;
end;
+ -- If we do not know required alignment, any non-zero offset is a
+ -- potential problem (but certainly may be OK, so result is unknown).
+
+ elsif Offs /= No_Uint then
+ Set_Result (Unknown);
+
-- If we can't find the result by direct comparison of alignment
-- values, then there is still one case that we can determine known
-- result, and that is when we can determine that the types are the
if Known_Alignment (Entity (Expr))
and then
- UI_To_Int (Alignment (Entity (Expr)))
- < Ttypes.Maximum_Alignment
+ UI_To_Int (Alignment (Entity (Expr))) <
+ Ttypes.Maximum_Alignment
then
Set_Result (Unknown);
and then
(UI_To_Int (Esize (Entity (Expr))) mod
(Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
- /= 0
+ /= 0
then
Set_Result (Unknown);
-- Unknown, since that result will be set in any case.
elsif Default /= Unknown
- and then (Has_Size_Clause (Etype (Expr))
+ and then (Has_Size_Clause (Etype (Expr))
or else
Has_Alignment_Clause (Etype (Expr)))
then
----------------------
function Has_Declarations (N : Node_Id) return Boolean is
- K : constant Node_Kind := Nkind (N);
- begin
- return K = N_Accept_Statement
- or else K = N_Block_Statement
- or else K = N_Compilation_Unit_Aux
- or else K = N_Entry_Body
- or else K = N_Package_Body
- or else K = N_Protected_Body
- or else K = N_Subprogram_Body
- or else K = N_Task_Body
- or else K = N_Package_Specification;
+ begin
+ return Nkind_In (Nkind (N), N_Accept_Statement,
+ N_Block_Statement,
+ N_Compilation_Unit_Aux,
+ N_Entry_Body,
+ N_Package_Body,
+ N_Protected_Body,
+ N_Subprogram_Body,
+ N_Task_Body,
+ N_Package_Specification);
end Has_Declarations;
-------------------------------------------
(T : Entity_Id;
Use_Full_View : Boolean := True) return Boolean
is
- Typ : Entity_Id;
+ Typ : Entity_Id := Base_Type (T);
begin
-- Handle concurrent types
- if Is_Concurrent_Type (T) then
- Typ := Corresponding_Record_Type (T);
- else
- Typ := T;
+ if Is_Concurrent_Type (Typ) then
+ Typ := Corresponding_Record_Type (Typ);
end if;
if not Present (Typ)
function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
BT : constant Entity_Id := Base_Type (T);
- Comp : Entity_Id;
P : Elmt_Id;
begin
if Is_Controlled (BT) then
-
- -- For derived types, check immediate ancestor, excluding
- -- Controlled itself.
-
- if Is_Derived_Type (BT)
- and then not In_Predefined_Unit (Etype (BT))
- and then Has_Overriding_Initialize (Etype (BT))
- then
- return True;
+ if Is_RTU (Scope (BT), Ada_Finalization) then
+ return False;
elsif Present (Primitive_Operations (BT)) then
P := First_Elmt (Primitive_Operations (BT));
while Present (P) loop
- if Chars (Node (P)) = Name_Initialize
- and then Comes_From_Source (Node (P))
- then
- return True;
- end if;
+ declare
+ Init : constant Entity_Id := Node (P);
+ Formal : constant Entity_Id := First_Formal (Init);
+ begin
+ if Ekind (Init) = E_Procedure
+ and then Chars (Init) = Name_Initialize
+ and then Comes_From_Source (Init)
+ and then Present (Formal)
+ and then Etype (Formal) = BT
+ and then No (Next_Formal (Formal))
+ and then (Ada_Version < Ada_2012
+ or else not Null_Present (Parent (Init)))
+ then
+ return True;
+ end if;
+ end;
Next_Elmt (P);
end loop;
end if;
- return False;
-
- elsif Has_Controlled_Component (BT) then
- Comp := First_Component (BT);
- while Present (Comp) loop
- if Has_Overriding_Initialize (Etype (Comp)) then
- return True;
- end if;
+ -- Here if type itself does not have a non-null Initialize operation:
+ -- check immediate ancestor.
- Next_Component (Comp);
- end loop;
-
- return False;
-
- else
- return False;
+ if Is_Derived_Type (BT)
+ and then Has_Overriding_Initialize (Etype (BT))
+ then
+ return True;
+ end if;
end if;
+
+ return False;
end Has_Overriding_Initialize;
--------------------------------------
-- We are interested only in components and discriminants
- if Ekind (Ent) = E_Component
- or else
- Ekind (Ent) = E_Discriminant
- then
- -- Get default expression if any. If there is no declaration
- -- node, it means we have an internal entity. The parent and
- -- tag fields are examples of such entities. For these cases,
- -- we just test the type of the entity.
+ Exp := Empty;
- if Present (Declaration_Node (Ent)) then
- Exp := Expression (Declaration_Node (Ent));
- else
- Exp := Empty;
- end if;
+ case Ekind (Ent) is
+ when E_Component =>
- -- A component has PI if it has no default expression and the
- -- component type has PI.
+ -- Get default expression if any. If there is no declaration
+ -- node, it means we have an internal entity. The parent and
+ -- tag fields are examples of such entities. For such cases,
+ -- we just test the type of the entity.
- if No (Exp) then
- if not Has_Preelaborable_Initialization (Etype (Ent)) then
- Has_PE := False;
- exit;
+ if Present (Declaration_Node (Ent)) then
+ Exp := Expression (Declaration_Node (Ent));
end if;
- -- Require the default expression to be preelaborable
+ when E_Discriminant =>
+
+ -- Note: for a renamed discriminant, the Declaration_Node
+ -- may point to the one from the ancestor, and have a
+ -- different expression, so use the proper attribute to
+ -- retrieve the expression from the derived constraint.
+
+ Exp := Discriminant_Default_Value (Ent);
+
+ when others =>
+ goto Check_Next_Entity;
+ end case;
- elsif not Is_Preelaborable_Expression (Exp) then
+ -- A component has PI if it has no default expression and the
+ -- component type has PI.
+
+ if No (Exp) then
+ if not Has_Preelaborable_Initialization (Etype (Ent)) then
Has_PE := False;
exit;
end if;
+
+ -- Require the default expression to be preelaborable
+
+ elsif not Is_Preelaborable_Expression (Exp) then
+ Has_PE := False;
+ exit;
end if;
+ <<Check_Next_Entity>>
Next_Entity (Ent);
end loop;
end Check_Components;
end if;
end Has_Stream;
+ ----------------
+ -- Has_Suffix --
+ ----------------
+
+ function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
+ begin
+ Get_Name_String (Chars (E));
+ return Name_Buffer (Name_Len) = Suffix;
+ end Has_Suffix;
+
--------------------------
-- Has_Tagged_Component --
--------------------------
end if;
end Has_Tagged_Component;
+ -------------------------
+ -- Implementation_Kind --
+ -------------------------
+
+ function Implementation_Kind (Subp : Entity_Id) return Name_Id is
+ Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
+ begin
+ pragma Assert (Present (Impl_Prag));
+ return
+ Chars (Expression (Last (Pragma_Argument_Associations (Impl_Prag))));
+ end Implementation_Kind;
+
--------------------------
-- Implements_Interface --
--------------------------
is
Ifaces_List : Elist_Id;
Elmt : Elmt_Id;
- Iface : Entity_Id;
- Typ : Entity_Id;
+ Iface : Entity_Id := Base_Type (Iface_Ent);
+ Typ : Entity_Id := Base_Type (Typ_Ent);
begin
- if Is_Class_Wide_Type (Typ_Ent) then
- Typ := Etype (Typ_Ent);
- else
- Typ := Typ_Ent;
- end if;
-
- if Is_Class_Wide_Type (Iface_Ent) then
- Iface := Etype (Iface_Ent);
- else
- Iface := Iface_Ent;
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
end if;
if not Has_Interfaces (Typ) then
return False;
end if;
+ if Is_Class_Wide_Type (Iface) then
+ Iface := Root_Type (Iface);
+ end if;
+
Collect_Interfaces (Typ, Ifaces_List);
Elmt := First_Elmt (Ifaces_List);
begin
Save_Interps (N, New_Prefix);
- Rewrite (N, Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix));
+
+ Rewrite (N,
+ Make_Explicit_Dereference (Sloc (Parent (N)),
+ Prefix => New_Prefix));
Set_Etype (N, Designated_Type (Etype (New_Prefix)));
if Is_Overloaded (New_Prefix) then
- -- The deference is also overloaded, and its interpretations are the
- -- designated types of the interpretations of the original node.
+ -- The dereference is also overloaded, and its interpretations are
+ -- the designated types of the interpretations of the original node.
Set_Etype (N, Any_Type);
if Is_Entity_Name (New_Prefix) then
Ent := Entity (New_Prefix);
+ Pref := New_Prefix;
-- For a retrieval of a subcomponent of some composite object,
-- retrieve the ultimate entity if there is one.
end if;
end if;
+ -- Place the reference on the entity node
+
if Present (Ent) then
- Generate_Reference (Ent, New_Prefix);
+ Generate_Reference (Ent, Pref);
end if;
end if;
end Insert_Explicit_Dereference;
and then Comes_From_Source (Decl)
- -- The constant is not completed. A full object declaration
- -- or a pragma Import complete a deferred constant.
+ -- The constant is not completed. A full object declaration or a
+ -- pragma Import complete a deferred constant.
and then not Has_Completion (Defining_Identifier (Decl))
then
end loop;
end Inspect_Deferred_Constant_Completion;
- -------------------
- -- Is_AAMP_Float --
- -------------------
+ -----------------------------
+ -- Is_Actual_Out_Parameter --
+ -----------------------------
- function Is_AAMP_Float (E : Entity_Id) return Boolean is
- pragma Assert (Is_Type (E));
+ function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
+ Formal : Entity_Id;
+ Call : Node_Id;
begin
- return AAMP_On_Target
- and then Is_Floating_Point_Type (E)
- and then E = Base_Type (E);
- end Is_AAMP_Float;
+ Find_Actual (N, Formal, Call);
+ return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
+ end Is_Actual_Out_Parameter;
-------------------------
-- Is_Actual_Parameter --
-- Start of processing for Is_Atomic_Object
begin
- if Is_Atomic (Etype (N))
+ -- Predicate is not relevant to subprograms
+
+ if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
+ return False;
+
+ elsif Is_Atomic (Etype (N))
or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
then
return True;
function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
begin
return Nkind (N) = N_Function_Call
- and then Is_Class_Wide_Type (Etype (N))
and then Is_CPP_Class (Etype (Etype (N)))
and then Is_Constructor (Entity (Name (N)))
and then Is_Imported (Entity (Name (N)));
end Is_CPP_Constructor_Call;
+ -----------------
+ -- Is_Delegate --
+ -----------------
+
+ function Is_Delegate (T : Entity_Id) return Boolean is
+ Desig_Type : Entity_Id;
+
+ begin
+ if VM_Target /= CLI_Target then
+ return False;
+ end if;
+
+ -- Access-to-subprograms are delegates in CIL
+
+ if Ekind (T) = E_Access_Subprogram_Type then
+ return True;
+ end if;
+
+ if Ekind (T) not in Access_Kind then
+
+ -- A delegate is a managed pointer. If no designated type is defined
+ -- it means that it's not a delegate.
+
+ return False;
+ end if;
+
+ Desig_Type := Etype (Directly_Designated_Type (T));
+
+ if not Is_Tagged_Type (Desig_Type) then
+ return False;
+ end if;
+
+ -- Test if the type is inherited from [mscorlib]System.Delegate
+
+ while Etype (Desig_Type) /= Desig_Type loop
+ if Chars (Scope (Desig_Type)) /= No_Name
+ and then Is_Imported (Scope (Desig_Type))
+ and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
+ then
+ return True;
+ end if;
+
+ Desig_Type := Etype (Desig_Type);
+ end loop;
+
+ return False;
+ end Is_Delegate;
+
----------------------------------------------
-- Is_Dependent_Component_Of_Mutable_Object --
----------------------------------------------
function Is_Dependent_Component_Of_Mutable_Object
- (Object : Node_Id) return Boolean
+ (Object : Node_Id) return Boolean
is
P : Node_Id;
Prefix_Type : Entity_Id;
P_Aliased := True;
end if;
- -- A discriminant check on a selected component may be
- -- expanded into a dereference when removing side-effects.
- -- Recover the original node and its type, which may be
- -- unconstrained.
+ -- A discriminant check on a selected component may be expanded
+ -- into a dereference when removing side-effects. Recover the
+ -- original node and its type, which may be unconstrained.
elsif Nkind (P) = N_Explicit_Dereference
and then not (Comes_From_Source (P))
Prefix_Type := Etype (P);
else
- -- Check for prefix being an aliased component ???
+ -- Check for prefix being an aliased component???
+
null;
end if;
-- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
-- semantic rules -- these rules are acknowledged to need fixing).
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
if Is_Access_Type (Prefix_Type)
or else Nkind (P) = N_Explicit_Dereference
then
return False;
end if;
- elsif Ada_Version >= Ada_05 then
+ elsif Ada_Version >= Ada_2005 then
if Is_Access_Type (Prefix_Type) then
-- If the access type is pool-specific, and there is no
Comp :=
Original_Record_Component (Entity (Selector_Name (Object)));
- -- As per AI-0017, the renaming is illegal in a generic body,
- -- even if the subtype is indefinite.
+ -- As per AI-0017, the renaming is illegal in a generic body, even
+ -- if the subtype is indefinite.
-- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
and then (Is_Declared_Within_Variant (Comp)
or else Has_Discriminant_Dependent_Constraint (Comp))
- and then (not P_Aliased or else Ada_Version >= Ada_05)
+ and then (not P_Aliased or else Ada_Version >= Ada_2005)
then
return True;
end if;
end Is_Fully_Initialized_Variant;
+ ------------
+ -- Is_LHS --
+ ------------
+
+ -- We seem to have a lot of overlapping functions that do similar things
+ -- (testing for left hand sides or lvalues???). Anyway, since this one is
+ -- purely syntactic, it should be in Sem_Aux I would think???
+
+ function Is_LHS (N : Node_Id) return Boolean is
+ P : constant Node_Id := Parent (N);
+
+ begin
+ if Nkind (P) = N_Assignment_Statement then
+ return Name (P) = N;
+
+ elsif
+ Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
+ then
+ return N = Prefix (P) and then Is_LHS (P);
+
+ else
+ return False;
+ end if;
+ end Is_LHS;
+
----------------------------
-- Is_Inherited_Operation --
----------------------------
-- the corresponding procedure has been created, and which therefore do
-- not have an assigned scope.
- if Ekind (E) in Formal_Kind then
+ if Is_Formal (E) then
return False;
end if;
Ent : constant Entity_Id := Entity (Expr);
Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
begin
- if Ekind (Ent) /= E_Variable
- and then
- Ekind (Ent) /= E_In_Out_Parameter
- then
+ if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
return False;
else
return Present (Sub) and then Sub = Current_Subprogram;
-- Is_Partially_Initialized_Type --
-----------------------------------
- function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean is
+ function Is_Partially_Initialized_Type
+ (Typ : Entity_Id;
+ Include_Implicit : Boolean := True) return Boolean
+ is
begin
if Is_Scalar_Type (Typ) then
return False;
elsif Is_Access_Type (Typ) then
- return True;
+ return Include_Implicit;
elsif Is_Array_Type (Typ) then
-- If component type is partially initialized, so is array type
- if Is_Partially_Initialized_Type (Component_Type (Typ)) then
+ if Is_Partially_Initialized_Type
+ (Component_Type (Typ), Include_Implicit)
+ then
return True;
-- Otherwise we are only partially initialized if we are fully
elsif Is_Record_Type (Typ) then
- -- A discriminated type is always partially initialized
+ -- A discriminated type is always partially initialized if in
+ -- all mode
- if Has_Discriminants (Typ) then
+ if Has_Discriminants (Typ) and then Include_Implicit then
return True;
-- A tagged type is always partially initialized
-- If a component is of a type which is itself partially
-- initialized, then the enclosing record type is also.
- elsif Is_Partially_Initialized_Type (Etype (Ent)) then
+ elsif Is_Partially_Initialized_Type
+ (Etype (Ent), Include_Implicit)
+ then
return True;
end if;
end if;
if No (U) then
return True;
else
- return Is_Partially_Initialized_Type (U);
+ return Is_Partially_Initialized_Type (U, Include_Implicit);
end if;
end;
-- because they denote entities that are not necessarily visible.
-- Neither of them can apply to a protected type.
- return Ada_Version >= Ada_05
+ return Ada_Version >= Ada_2005
and then Is_Entity_Name (N)
and then Present (Entity (N))
and then Is_Protected_Type (Entity (N))
return (U /= 0);
end Is_True;
+ -------------------------------
+ -- Is_Universal_Numeric_Type --
+ -------------------------------
+
+ function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
+ begin
+ return T = Universal_Integer or else T = Universal_Real;
+ end Is_Universal_Numeric_Type;
+
-------------------
-- Is_Value_Type --
-------------------
function Is_Value_Type (T : Entity_Id) return Boolean is
begin
return VM_Target = CLI_Target
+ and then Nkind (T) in N_Has_Chars
and then Chars (T) /= No_Name
and then Get_Name_String (Chars (T)) = "valuetype";
end Is_Value_Type;
+ ---------------------
+ -- Is_VMS_Operator --
+ ---------------------
+
+ function Is_VMS_Operator (Op : Entity_Id) return Boolean is
+ begin
+ -- The VMS operators are declared in a child of System that is loaded
+ -- through pragma Extend_System. In some rare cases a program is run
+ -- with this extension but without indicating that the target is VMS.
+
+ return Ekind (Op) = E_Function
+ and then Is_Intrinsic_Subprogram (Op)
+ and then
+ ((Present_System_Aux
+ and then Scope (Op) = System_Aux_Id)
+ or else
+ (True_VMS_Target
+ and then Scope (Scope (Op)) = RTU_Entity (System)));
+ end Is_VMS_Operator;
+
-----------------
-- Is_Variable --
-----------------
function Is_Variable (N : Node_Id) return Boolean is
Orig_Node : constant Node_Id := Original_Node (N);
- -- We do the test on the original node, since this is basically a
- -- test of syntactic categories, so it must not be disturbed by
- -- whatever rewriting might have occurred. For example, an aggregate,
- -- which is certainly NOT a variable, could be turned into a variable
- -- by expansion.
+ -- We do the test on the original node, since this is basically a test
+ -- of syntactic categories, so it must not be disturbed by whatever
+ -- rewriting might have occurred. For example, an aggregate, which is
+ -- certainly NOT a variable, could be turned into a variable by
+ -- expansion.
function In_Protected_Function (E : Entity_Id) return Boolean;
- -- Within a protected function, the private components of the
- -- enclosing protected type are constants. A function nested within
- -- a (protected) procedure is not itself protected.
+ -- Within a protected function, the private components of the enclosing
+ -- protected type are constants. A function nested within a (protected)
+ -- procedure is not itself protected.
function Is_Variable_Prefix (P : Node_Id) return Boolean;
- -- Prefixes can involve implicit dereferences, in which case we
- -- must test for the case of a reference of a constant access
- -- type, which can never be a variable.
+ -- Prefixes can involve implicit dereferences, in which case we must
+ -- test for the case of a reference of a constant access type, which can
+ -- can never be a variable.
---------------------------
-- In_Protected_Function --
else
S := Current_Scope;
while Present (S) and then S /= Prot loop
- if Ekind (S) = E_Function
- and then Scope (S) = Prot
- then
+ if Ekind (S) = E_Function and then Scope (S) = Prot then
return True;
end if;
if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
return True;
- -- Normally we go to the original node, but there is one exception
- -- where we use the rewritten node, namely when it is an explicit
- -- dereference. The generated code may rewrite a prefix which is an
- -- access type with an explicit dereference. The dereference is a
- -- variable, even though the original node may not be (since it could
- -- be a constant of the access type).
+ -- Normally we go to the original node, but there is one exception where
+ -- we use the rewritten node, namely when it is an explicit dereference.
+ -- The generated code may rewrite a prefix which is an access type with
+ -- an explicit dereference. The dereference is a variable, even though
+ -- the original node may not be (since it could be a constant of the
+ -- access type).
- -- In Ada 2005 we have a further case to consider: the prefix may be
- -- a function call given in prefix notation. The original node appears
- -- to be a selected component, but we need to examine the call.
+ -- In Ada 2005 we have a further case to consider: the prefix may be a
+ -- function call given in prefix notation. The original node appears to
+ -- be a selected component, but we need to examine the call.
elsif Nkind (N) = N_Explicit_Dereference
and then Nkind (Orig_Node) /= N_Explicit_Dereference
end if;
end Is_Variable;
+ ---------------------------
+ -- Is_Visibly_Controlled --
+ ---------------------------
+
+ function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
+ Root : constant Entity_Id := Root_Type (T);
+ begin
+ return Chars (Scope (Root)) = Name_Finalization
+ and then Chars (Scope (Scope (Root))) = Name_Ada
+ and then Scope (Scope (Scope (Root))) = Standard_Standard;
+ end Is_Visibly_Controlled;
+
------------------------
-- Is_Volatile_Object --
------------------------
Last_Assignment_Only : Boolean := False)
is
begin
+ -- ??? do we have to worry about clearing cached checks?
+
if Is_Assignable (Ent) then
Set_Last_Assignment (Ent, Empty);
end if;
- if not Last_Assignment_Only and then Is_Object (Ent) then
- Kill_Checks (Ent);
- Set_Current_Value (Ent, Empty);
+ if Is_Object (Ent) then
+ if not Last_Assignment_Only then
+ Kill_Checks (Ent);
+ Set_Current_Value (Ent, Empty);
+
+ if not Can_Never_Be_Null (Ent) then
+ Set_Is_Known_Non_Null (Ent, False);
+ end if;
+
+ Set_Is_Known_Null (Ent, False);
- if not Can_Never_Be_Null (Ent) then
- Set_Is_Known_Non_Null (Ent, False);
- end if;
+ -- Reset Is_Known_Valid unless type is always valid, or if we have
+ -- a loop parameter (loop parameters are always valid, since their
+ -- bounds are defined by the bounds given in the loop header).
- Set_Is_Known_Null (Ent, False);
+ if not Is_Known_Valid (Etype (Ent))
+ and then Ekind (Ent) /= E_Loop_Parameter
+ then
+ Set_Is_Known_Valid (Ent, False);
+ end if;
+ end if;
end if;
end Kill_Current_Values;
return False;
end if;
- -- For a selected component A.B, A is certainly an Lvalue if A.B is
- -- an Lvalue. B is a little interesting, if we have A.B:=3, there is
- -- some discussion as to whether B is an Lvalue or not, we choose to
- -- say it is. Note however that A is not an Lvalue if it is of an
- -- access type since this is an implicit dereference.
+ -- For a selected component A.B, A is certainly an lvalue if A.B is.
+ -- B is a little interesting, if we have A.B := 3, there is some
+ -- discussion as to whether B is an lvalue or not, we choose to say
+ -- it is. Note however that A is not an lvalue if it is of an access
+ -- type since this is an implicit dereference.
when N_Selected_Component =>
if N = Prefix (P)
end if;
-- For an indexed component or slice, the index or slice bounds is
- -- never an Lvalue. The prefix is an lvalue if the indexed component
- -- or slice is an Lvalue, except if it is an access type, where we
+ -- never an lvalue. The prefix is an lvalue if the indexed component
+ -- or slice is an lvalue, except if it is an access type, where we
-- have an implicit dereference.
when N_Indexed_Component =>
return May_Be_Lvalue (P);
end if;
- -- Prefix of a reference is an Lvalue if the reference is an Lvalue
+ -- Prefix of a reference is an lvalue if the reference is an lvalue
when N_Reference =>
return May_Be_Lvalue (P);
- -- Prefix of explicit dereference is never an Lvalue
+ -- Prefix of explicit dereference is never an lvalue
when N_Explicit_Dereference =>
return False;
- -- Function call arguments are never Lvalues
-
- when N_Function_Call =>
- return False;
-
- -- Positional parameter for procedure, entry, or accept call
+ -- Positional parameter for subprogram, entry, or accept call.
+ -- In older versions of Ada function call arguments are never
+ -- lvalues. In Ada 2012 functions can have in-out parameters.
- when N_Procedure_Call_Statement |
+ when N_Function_Call |
+ N_Procedure_Call_Statement |
N_Entry_Call_Statement |
N_Accept_Statement
=>
+ if Nkind (P) = N_Function_Call
+ and then Ada_Version < Ada_2012
+ then
+ return False;
+ end if;
+
+ -- The following mechanism is clumsy and fragile. A single
+ -- flag set in Resolve_Actuals would be preferable ???
+
declare
Proc : Entity_Id;
Form : Entity_Id;
when N_Object_Renaming_Declaration =>
return True;
- -- All other references are definitely not Lvalues
+ -- All other references are definitely not lvalues
when others =>
return False;
if Nkind (N) = N_Allocator then
if Is_Dynamic then
Set_Is_Dynamic_Coextension (N);
+
+ -- If the allocator expression is potentially dynamic, it may
+ -- be expanded out of order and require dynamic allocation
+ -- anyway, so we treat the coextension itself as dynamic.
+ -- Potential optimization ???
+
+ elsif Nkind (Expression (N)) = N_Qualified_Expression
+ and then Nkind (Expression (Expression (N))) = N_Op_Concat
+ then
+ Set_Is_Dynamic_Coextension (N);
+
else
Set_Is_Static_Coextension (N);
end if;
Formal : Entity_Id;
begin
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Present (First_Formal (E))
then
Formal := Next_Formal (First_Formal (E));
-- Itype references within the copied tree.
-- The following hash tables are used if the Map supplied has more
- -- than hash threshhold entries to speed up access to the map. If
+ -- than hash threshold entries to speed up access to the map. If
-- there are fewer entries, then the map is searched sequentially
-- (because setting up a hash table for only a few entries takes
-- more time than it saves.
else
NCT_Table_Entries := NCT_Table_Entries + 1;
- if NCT_Table_Entries > NCT_Hash_Threshhold then
+ if NCT_Table_Entries > NCT_Hash_Threshold then
Build_NCT_Hash_Tables;
end if;
end if;
-- If a record subtype is simply copied, the entity list will be
-- shared. Thus cloned_Subtype must be set to indicate the sharing.
- if Ekind (Old_Itype) = E_Record_Subtype
- or else Ekind (Old_Itype) = E_Class_Wide_Subtype
- then
+ if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
Set_Cloned_Subtype (New_Itype, Old_Itype);
end if;
Next_Elmt (Elmt);
end loop;
- if NCT_Table_Entries > NCT_Hash_Threshhold then
+ if NCT_Table_Entries > NCT_Hash_Threshold then
Build_NCT_Hash_Tables;
else
NCT_Hash_Tables_Used := False;
Sloc_Value : Source_Ptr;
Id_Char : Character) return Entity_Id
is
- N : constant Entity_Id :=
- Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char));
+ N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
begin
Set_Ekind (N, Kind);
if Comes_From_Source (Exp)
or else Modification_Comes_From_Source
then
- if Has_Pragma_Unmodified (Ent) then
+ -- Give warning if pragma unmodified given and we are
+ -- sure this is a modification.
+
+ if Has_Pragma_Unmodified (Ent) and then Sure then
Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent);
end if;
if Modification_Comes_From_Source then
Generate_Reference (Ent, Exp, 'm');
+
+ -- If the target of the assignment is the bound variable
+ -- in an iterator, indicate that the corresponding array
+ -- or container is also modified.
+
+ if Ada_Version >= Ada_2012
+ and then
+ Nkind (Parent (Ent)) = N_Iterator_Specification
+ then
+ declare
+ Domain : constant Node_Id := Name (Parent (Ent));
+
+ begin
+ -- TBD : in the full version of the construct, the
+ -- domain of iteration can be given by an expression.
+
+ if Is_Entity_Name (Domain) then
+ Generate_Reference (Entity (Domain), Exp, 'm');
+ Set_Is_True_Constant (Entity (Domain), False);
+ Set_Never_Set_In_Source (Entity (Domain), False);
+ end if;
+ end;
+ end if;
end if;
Check_Nested_Access (Ent);
then
return Object_Access_Level (Expression (Obj));
- -- Function results are objects, so we get either the access level of
- -- the function or, in the case of an indirect call, the level of the
- -- access-to-subprogram type.
-
elsif Nkind (Obj) = N_Function_Call then
- if Is_Entity_Name (Name (Obj)) then
- return Subprogram_Access_Level (Entity (Name (Obj)));
+
+ -- Function results are objects, so we get either the access level of
+ -- the function or, in the case of an indirect call, the level of the
+ -- access-to-subprogram type. (This code is used for Ada 95, but it
+ -- looks wrong, because it seems that we should be checking the level
+ -- of the call itself, even for Ada 95. However, using the Ada 2005
+ -- version of the code causes regressions in several tests that are
+ -- compiled with -gnat95. ???)
+
+ if Ada_Version < Ada_2005 then
+ if Is_Entity_Name (Name (Obj)) then
+ return Subprogram_Access_Level (Entity (Name (Obj)));
+ else
+ return Type_Access_Level (Etype (Prefix (Name (Obj))));
+ end if;
+
+ -- For Ada 2005, the level of the result object of a function call is
+ -- defined to be the level of the call's innermost enclosing master.
+ -- We determine that by querying the depth of the innermost enclosing
+ -- dynamic scope.
+
else
- return Type_Access_Level (Etype (Prefix (Name (Obj))));
+ Return_Master_Scope_Depth_Of_Call : declare
+
+ function Innermost_Master_Scope_Depth
+ (N : Node_Id) return Uint;
+ -- Returns the scope depth of the given node's innermost
+ -- enclosing dynamic scope (effectively the accessibility
+ -- level of the innermost enclosing master).
+
+ ----------------------------------
+ -- Innermost_Master_Scope_Depth --
+ ----------------------------------
+
+ function Innermost_Master_Scope_Depth
+ (N : Node_Id) return Uint
+ is
+ Node_Par : Node_Id := Parent (N);
+
+ begin
+ -- Locate the nearest enclosing node (by traversing Parents)
+ -- that Defining_Entity can be applied to, and return the
+ -- depth of that entity's nearest enclosing dynamic scope.
+
+ while Present (Node_Par) loop
+ case Nkind (Node_Par) is
+ when N_Component_Declaration |
+ N_Entry_Declaration |
+ N_Formal_Object_Declaration |
+ N_Formal_Type_Declaration |
+ N_Full_Type_Declaration |
+ N_Incomplete_Type_Declaration |
+ N_Loop_Parameter_Specification |
+ N_Object_Declaration |
+ N_Protected_Type_Declaration |
+ N_Private_Extension_Declaration |
+ N_Private_Type_Declaration |
+ N_Subtype_Declaration |
+ N_Function_Specification |
+ N_Procedure_Specification |
+ N_Task_Type_Declaration |
+ N_Body_Stub |
+ N_Generic_Instantiation |
+ N_Proper_Body |
+ N_Implicit_Label_Declaration |
+ N_Package_Declaration |
+ N_Single_Task_Declaration |
+ N_Subprogram_Declaration |
+ N_Generic_Declaration |
+ N_Renaming_Declaration |
+ N_Block_Statement |
+ N_Formal_Subprogram_Declaration |
+ N_Abstract_Subprogram_Declaration |
+ N_Entry_Body |
+ N_Exception_Declaration |
+ N_Formal_Package_Declaration |
+ N_Number_Declaration |
+ N_Package_Specification |
+ N_Parameter_Specification |
+ N_Single_Protected_Declaration |
+ N_Subunit =>
+
+ return Scope_Depth
+ (Nearest_Dynamic_Scope
+ (Defining_Entity (Node_Par)));
+
+ when others =>
+ null;
+ end case;
+
+ Node_Par := Parent (Node_Par);
+ end loop;
+
+ pragma Assert (False);
+
+ -- Should never reach the following return
+
+ return Scope_Depth (Current_Scope) + 1;
+ end Innermost_Master_Scope_Depth;
+
+ -- Start of processing for Return_Master_Scope_Depth_Of_Call
+
+ begin
+ return Innermost_Master_Scope_Depth (Obj);
+ end Return_Master_Scope_Depth_Of_Call;
end if;
-- For convenience we handle qualified expressions, even though
end if;
end Object_Access_Level;
+ --------------------------------------
+ -- Original_Corresponding_Operation --
+ --------------------------------------
+
+ function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
+ is
+ Typ : constant Entity_Id := Find_Dispatching_Type (S);
+
+ begin
+ -- If S is an inherited primitive S2 the original corresponding
+ -- operation of S is the original corresponding operation of S2
+
+ if Present (Alias (S))
+ and then Find_Dispatching_Type (Alias (S)) /= Typ
+ then
+ return Original_Corresponding_Operation (Alias (S));
+
+ -- If S overrides an inherited subprogram S2 the original corresponding
+ -- operation of S is the original corresponding operation of S2
+
+ elsif Present (Overridden_Operation (S)) then
+ return Original_Corresponding_Operation (Overridden_Operation (S));
+
+ -- otherwise it is S itself
+
+ else
+ return S;
+ end if;
+ end Original_Corresponding_Operation;
+
-----------------------
-- Private_Component --
-----------------------
Set_Sloc (Endl, Loc);
end Process_End_Label;
- ------------------
- -- Real_Convert --
- ------------------
-
- -- We do the conversion to get the value of the real string by using
- -- the scanner, see Sinput for details on use of the internal source
- -- buffer for scanning internal strings.
-
- function Real_Convert (S : String) return Node_Id is
- Save_Src : constant Source_Buffer_Ptr := Source;
- Negative : Boolean;
-
- begin
- Source := Internal_Source_Ptr;
- Scan_Ptr := 1;
-
- for J in S'Range loop
- Source (Source_Ptr (J)) := S (J);
- end loop;
-
- Source (S'Length + 1) := EOF;
-
- if Source (Scan_Ptr) = '-' then
- Negative := True;
- Scan_Ptr := Scan_Ptr + 1;
- else
- Negative := False;
- end if;
-
- Scan;
-
- if Negative then
- Set_Realval (Token_Node, UR_Negate (Realval (Token_Node)));
- end if;
-
- Source := Save_Src;
- return Token_Node;
- end Real_Convert;
-
------------------------------------
-- References_Generic_Formal_Type --
------------------------------------
if Requires_Transient_Scope (Component_Type (Typ)) then
return True;
- -- Otherwise, we only need a transient scope if the size is not
- -- known at compile time.
+ -- Otherwise, we only need a transient scope if the size depends on
+ -- the value of one or more discriminants.
else
- return not Size_Known_At_Compile_Time (Typ);
+ return Size_Depends_On_Discriminant (Typ);
end if;
-- All other cases do not require a transient scope
while R_Scope /= Standard_Standard loop
exit when R_Scope = E_Scope;
- if Ekind (R_Scope) /= E_Package
- and then
- Ekind (R_Scope) /= E_Block
- and then
- Ekind (R_Scope) /= E_Loop
- then
+ if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
return False;
else
R_Scope := Scope (R_Scope);
P := Parent (N);
while Present (P) loop
- if Nkind (P) = N_If_Statement
+ if Nkind (P) = N_If_Statement
or else Nkind (P) = N_Case_Statement
- or else (Nkind (P) = N_And_Then and then Desc = Right_Opnd (P))
- or else (Nkind (P) = N_Or_Else and then Desc = Right_Opnd (P))
+ or else (Nkind (P) in N_Short_Circuit
+ and then Desc = Right_Opnd (P))
+ or else (Nkind (P) = N_Conditional_Expression
+ and then Desc /= First (Expressions (P)))
or else Nkind (P) = N_Exception_Handler
or else Nkind (P) = N_Selective_Accept
or else Nkind (P) = N_Conditional_Entry_Call
begin
-- First case, both are entities with same entity
- if K1 in N_Has_Entity
- and then K2 in N_Has_Entity
- and then Present (Entity (N1))
- and then Present (Entity (N2))
- and then (Ekind (Entity (N1)) = E_Variable
- or else
- Ekind (Entity (N1)) = E_Constant)
- and then Entity (N1) = Entity (N2)
- then
- return True;
+ if K1 in N_Has_Entity and then K2 in N_Has_Entity then
+ declare
+ EN1 : constant Entity_Id := Entity (N1);
+ EN2 : constant Entity_Id := Entity (N2);
+ begin
+ if Present (EN1) and then Present (EN2)
+ and then (Ekind_In (EN1, E_Variable, E_Constant)
+ or else Is_Formal (EN1))
+ and then EN1 = EN2
+ then
+ return True;
+ end if;
+ end;
+ end if;
-- Second case, selected component with same selector, same record
- elsif K1 = N_Selected_Component
+ if K1 = N_Selected_Component
and then K2 = N_Selected_Component
and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
then
end if;
end Same_Value;
+ -----------------
+ -- Save_Actual --
+ -----------------
+
+ procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is
+ begin
+ if Ada_Version < Ada_2012 then
+ return;
+
+ elsif Is_Entity_Name (N)
+ or else
+ Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice)
+ or else
+ (Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Access)
+
+ then
+ -- We are only interested in IN OUT parameters of inner calls
+
+ if not Writable
+ or else Nkind (Parent (N)) = N_Function_Call
+ or else Nkind (Parent (N)) in N_Op
+ then
+ Actuals_In_Call.Increment_Last;
+ Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable);
+ end if;
+ end if;
+ end Save_Actual;
+
------------------------
-- Scope_Is_Transient --
------------------------
end loop;
end;
+ -- For a class wide subtype, we also need debug information
+ -- for the equivalent type.
+
+ if Ekind (T) = E_Class_Wide_Subtype then
+ Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
+ end if;
+
elsif Is_Array_Type (T) then
Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
begin
-- Deal with indexed or selected component where prefix is modified
- if Nkind (N) = N_Indexed_Component
- or else
- Nkind (N) = N_Selected_Component
- then
+ if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
Pref := Prefix (N);
-- If prefix is access type, then it is the designated object that is
end Set_Size_Info;
--------------------
+ -- Static_Boolean --
+ --------------------
+
+ function Static_Boolean (N : Node_Id) return Uint is
+ begin
+ Analyze_And_Resolve (N, Standard_Boolean);
+
+ if N = Error
+ or else Error_Posted (N)
+ or else Etype (N) = Any_Type
+ then
+ return No_Uint;
+ end if;
+
+ if Is_Static_Expression (N) then
+ if not Raises_Constraint_Error (N) then
+ return Expr_Value (N);
+ else
+ return No_Uint;
+ end if;
+
+ elsif Etype (N) = Any_Type then
+ return No_Uint;
+
+ else
+ Flag_Non_Static_Expr
+ ("static boolean expression required here", N);
+ return No_Uint;
+ end if;
+ end Static_Boolean;
+
+ --------------------
-- Static_Integer --
--------------------
return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
end Type_Access_Level;
- --------------------
- -- Ultimate_Alias --
- --------------------
- -- To do: add occurrences calling this new subprogram
-
- function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
- E : Entity_Id := Prim;
-
- begin
- while Present (Alias (E)) loop
- E := Alias (E);
- end loop;
-
- return E;
- end Ultimate_Alias;
-
--------------------------
-- Unit_Declaration_Node --
--------------------------
end if;
end Unqualify;
+ -----------------------
+ -- Visible_Ancestors --
+ -----------------------
+
+ function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
+ List_1 : Elist_Id;
+ List_2 : Elist_Id;
+ Elmt : Elmt_Id;
+
+ begin
+ pragma Assert (Is_Record_Type (Typ)
+ and then Is_Tagged_Type (Typ));
+
+ -- Collect all the parents and progenitors of Typ. If the full-view of
+ -- private parents and progenitors is available then it is used to
+ -- generate the list of visible ancestors; otherwise their partial
+ -- view is added to the resulting list.
+
+ Collect_Parents
+ (T => Typ,
+ List => List_1,
+ Use_Full_View => True);
+
+ Collect_Interfaces
+ (T => Typ,
+ Ifaces_List => List_2,
+ Exclude_Parents => True,
+ Use_Full_View => True);
+
+ -- Join the two lists. Avoid duplications because an interface may
+ -- simultaneously be parent and progenitor of a type.
+
+ Elmt := First_Elmt (List_2);
+ while Present (Elmt) loop
+ Append_Unique_Elmt (Node (Elmt), List_1);
+ Next_Elmt (Elmt);
+ end loop;
+
+ return List_1;
+ end Visible_Ancestors;
+
----------------------
-- Within_Init_Proc --
----------------------
and then Covers
(Designated_Type (Expec_Type), Designated_Type (Found_Type))
then
- Error_Msg_N ("result must be general access type!", Expr);
- Error_Msg_NE ("add ALL to }!", Expr, Expec_Type);
+ Error_Msg_N -- CODEFIX
+ ("result must be general access type!", Expr);
+ Error_Msg_NE -- CODEFIX
+ ("add ALL to }!", Expr, Expec_Type);
-- Another special check, if the expected type is an integer type,
-- but the expression is of type System.Address, and the parent is
if From_With_Type (Found_Type) then
Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
Error_Msg_Qual_Level := 99;
- Error_Msg_NE ("\\missing `WITH &;", Expr, Scope (Found_Type));
+ Error_Msg_NE -- CODEFIX
+ ("\\missing `WITH &;", Expr, Scope (Found_Type));
Error_Msg_Qual_Level := 0;
else
Error_Msg_NE ("found}!", Expr, Found_Type);
Error_Msg_NE ("\\found}!", Expr, Found_Type);
end if;
+ -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
+ -- of the same modular type, and (M1 and M2) = 0 was intended.
+
+ if Expec_Type = Standard_Boolean
+ and then Is_Modular_Integer_Type (Found_Type)
+ and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
+ and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
+ then
+ declare
+ Op : constant Node_Id := Right_Opnd (Parent (Expr));
+ L : constant Node_Id := Left_Opnd (Op);
+ R : constant Node_Id := Right_Opnd (Op);
+ begin
+ -- The case for the message is when the left operand of the
+ -- comparison is the same modular type, or when it is an
+ -- integer literal (or other universal integer expression),
+ -- which would have been typed as the modular type if the
+ -- parens had been there.
+
+ if (Etype (L) = Found_Type
+ or else
+ Etype (L) = Universal_Integer)
+ and then Is_Integer_Type (Etype (R))
+ then
+ Error_Msg_N
+ ("\\possible missing parens for modular operation", Expr);
+ end if;
+ end;
+ end if;
+
+ -- Reset error message qualification indication
+
Error_Msg_Qual_Level := 0;
end if;
end Wrong_Type;
OSDN Git Service
