-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, 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 Elists; use Elists;
with Exp_Ch11; use Exp_Ch11;
with Exp_Disp; use Exp_Disp;
-with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
with Nlists; use Nlists;
with Output; use Output;
with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
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;
-- 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
-- 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;
- -- Comments needed???
-
end record;
package Actuals_In_Call is new Table.Table (
Nod := Type_Definition (Parent (Typ));
elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
- if Present (Full_View (Typ)) then
+ if Present (Full_View (Typ))
+ and then Nkind (Parent (Full_View (Typ)))
+ = N_Full_Type_Declaration
+ then
Nod := Type_Definition (Parent (Full_View (Typ)));
-- If the full-view is not available we cannot do anything else
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 --
--------------------------
P : constant Node_Id := Prefix (N);
D : Elmt_Id;
Id : Node_Id;
- Indx_Type : Entity_Id;
+ Index_Typ : Entity_Id;
- Deaccessed_T : Entity_Id;
+ Desig_Typ : Entity_Id;
-- This is either a copy of T, or if T is an access type, then it is
-- the directly designated type of this access type.
Old_Lo : Node_Id;
begin
- Indx := First_Index (Deaccessed_T);
+ Indx := First_Index (Desig_Typ);
while Present (Indx) loop
Old_Lo := Type_Low_Bound (Etype (Indx));
Old_Hi := Type_High_Bound (Etype (Indx));
D_Val : Node_Id;
begin
- D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
+ D := First_Elmt (Discriminant_Constraint (Desig_Typ));
while Present (D) loop
if Denotes_Discriminant (Node (D)) then
D_Val := Make_Selected_Component (Loc,
end if;
if Ekind (T) = E_Access_Subtype then
- Deaccessed_T := Designated_Type (T);
+ Desig_Typ := Designated_Type (T);
else
- Deaccessed_T := T;
+ Desig_Typ := T;
end if;
- if Ekind (Deaccessed_T) = E_Array_Subtype then
- Id := First_Index (Deaccessed_T);
+ if Ekind (Desig_Typ) = E_Array_Subtype then
+ Id := First_Index (Desig_Typ);
while Present (Id) loop
- Indx_Type := Underlying_Type (Etype (Id));
+ Index_Typ := Underlying_Type (Etype (Id));
- if Denotes_Discriminant (Type_Low_Bound (Indx_Type))
+ if Denotes_Discriminant (Type_Low_Bound (Index_Typ))
or else
- Denotes_Discriminant (Type_High_Bound (Indx_Type))
+ Denotes_Discriminant (Type_High_Bound (Index_Typ))
then
Remove_Side_Effects (P);
return
Next_Index (Id);
end loop;
- elsif Is_Composite_Type (Deaccessed_T)
- and then Has_Discriminants (Deaccessed_T)
- and then not Has_Unknown_Discriminants (Deaccessed_T)
+ elsif Is_Composite_Type (Desig_Typ)
+ and then Has_Discriminants (Desig_Typ)
+ and then not Has_Unknown_Discriminants (Desig_Typ)
then
- D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
+ if Is_Private_Type (Desig_Typ)
+ and then No (Discriminant_Constraint (Desig_Typ))
+ then
+ Desig_Typ := Full_View (Desig_Typ);
+ end if;
+
+ D := First_Elmt (Discriminant_Constraint (Desig_Typ));
while Present (D) loop
if Denotes_Discriminant (Node (D)) then
Remove_Side_Effects (P);
Name_Buffer (Name_Len + 2) := 'E';
Name_Len := Name_Len + 2;
- -- Create elaboration flag
+ -- Create elaboration counter
- Elab_Ent :=
- Make_Defining_Identifier (Loc, Chars => Name_Find);
+ Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
Set_Elaboration_Entity (Spec_Id, Elab_Ent);
Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Elab_Ent,
- Object_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc),
- Expression =>
- New_Occurrence_Of (Standard_False, Loc));
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Elab_Ent,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Short_Integer, Loc),
+ Expression => Make_Integer_Literal (Loc, Uint_0));
Push_Scope (Standard_Standard);
Add_Global_Declaration (Decl);
end if;
end Cannot_Raise_Constraint_Error;
+ --------------------------------
+ -- Check_Implicit_Dereference --
+ --------------------------------
+
+ procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id)
+ is
+ Disc : Entity_Id;
+ Desig : Entity_Id;
+
+ begin
+ if Ada_Version < Ada_2012
+ or else not Has_Implicit_Dereference (Base_Type (Typ))
+ then
+ return;
+
+ elsif not Comes_From_Source (Nam) then
+ return;
+
+ elsif Is_Entity_Name (Nam)
+ and then Is_Type (Entity (Nam))
+ then
+ null;
+
+ else
+ Disc := First_Discriminant (Typ);
+ while Present (Disc) loop
+ if Has_Implicit_Dereference (Disc) then
+ Desig := Designated_Type (Etype (Disc));
+ Add_One_Interp (Nam, Disc, Desig);
+ exit;
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+ end if;
+ end Check_Implicit_Dereference;
+
+ ---------------------------------------
+ -- Check_Later_Vs_Basic_Declarations --
+ ---------------------------------------
+
+ procedure Check_Later_Vs_Basic_Declarations
+ (Decls : List_Id;
+ During_Parsing : Boolean)
+ is
+ Body_Sloc : Source_Ptr;
+ Decl : Node_Id;
+
+ function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
+ -- Return whether Decl is considered as a declarative item.
+ -- When During_Parsing is True, the semantics of Ada 83 is followed.
+ -- When During_Parsing is False, the semantics of SPARK is followed.
+
+ -------------------------------
+ -- Is_Later_Declarative_Item --
+ -------------------------------
+
+ function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
+ begin
+ if Nkind (Decl) in N_Later_Decl_Item then
+ return True;
+
+ elsif Nkind (Decl) = N_Pragma then
+ return True;
+
+ elsif During_Parsing then
+ return False;
+
+ -- In SPARK, a package declaration is not considered as a later
+ -- declarative item.
+
+ elsif Nkind (Decl) = N_Package_Declaration then
+ return False;
+
+ -- In SPARK, a renaming is considered as a later declarative item
+
+ elsif Nkind (Decl) in N_Renaming_Declaration then
+ return True;
+
+ else
+ return False;
+ end if;
+ end Is_Later_Declarative_Item;
+
+ -- Start of Check_Later_Vs_Basic_Declarations
+
+ begin
+ Decl := First (Decls);
+
+ -- Loop through sequence of basic declarative items
+
+ Outer : while Present (Decl) loop
+ if Nkind (Decl) /= N_Subprogram_Body
+ and then Nkind (Decl) /= N_Package_Body
+ and then Nkind (Decl) /= N_Task_Body
+ and then Nkind (Decl) not in N_Body_Stub
+ then
+ Next (Decl);
+
+ -- Once a body is encountered, we only allow later declarative
+ -- items. The inner loop checks the rest of the list.
+
+ else
+ Body_Sloc := Sloc (Decl);
+
+ Inner : while Present (Decl) loop
+ if not Is_Later_Declarative_Item (Decl) then
+ if During_Parsing then
+ if Ada_Version = Ada_83 then
+ Error_Msg_Sloc := Body_Sloc;
+ Error_Msg_N
+ ("(Ada 83) decl cannot appear after body#", Decl);
+ end if;
+ else
+ Error_Msg_Sloc := Body_Sloc;
+ Check_SPARK_Restriction
+ ("decl cannot appear after body#", Decl);
+ end if;
+ end if;
+
+ Next (Decl);
+ end loop Inner;
+ end if;
+ end loop Outer;
+ end Check_Later_Vs_Basic_Declarations;
+
-----------------------------------------
-- Check_Dynamically_Tagged_Expression --
-----------------------------------------
Act2 : Node_Id;
begin
- -- This could use comments ???
+ if Ada_Version < Ada_2012 then
+ return;
+ end if;
- for J in 0 .. Actuals_In_Call.Last loop
+ -- Ada 2012 AI05-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;
Act1 := Prefix (Act1);
end if;
- for K in 0 .. Actuals_In_Call.Last loop
+ for K in 1 .. Actuals_In_Call.Last loop
if K /= J then
Act2 := Actuals_In_Call.Table (K).Act;
null;
elsif Denotes_Same_Object (Act1, Act2)
- and then False
+ and then Parent (Act1) /= Parent (Act2)
then
- Error_Msg_N ("?,mighty suspicious!!!", Act1);
+ 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;
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;
-- Associate the primary tag component and the primary dispatch table
-- with all the interfaces that are parents of T
- if Is_Ancestor (Iface, T) then
+ if Is_Ancestor (Iface, T, Use_Full_View => True) then
Append_Elmt (First_Tag_Component (T), Components_List);
Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
Comp_Iface := Related_Type (Node (Comp_Elmt));
if Comp_Iface = Iface
- or else Is_Ancestor (Iface, Comp_Iface)
+ or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
then
Append_Elmt (Node (Comp_Elmt), Components_List);
Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
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 --
----------------------------------
if Chars (Id) = Name_Op_Eq
and then Is_Dispatching_Operation (Id)
and then Present (Alias (Id))
- and then Is_Overriding_Operation (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
-------------------------
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 (A1) then
- if Is_Entity_Name (A2) then
- return Entity (A1) = Entity (A2);
+ 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 (A1) /= Nkind (A2) then
+ elsif Nkind (Obj1) /= Nkind (Obj2) then
return False;
-- For selected components, must have same prefix and selector
- elsif Nkind (A1) = N_Selected_Component then
- return Denotes_Same_Object (Prefix (A1), Prefix (A2))
+ elsif Nkind (Obj1) = N_Selected_Component then
+ return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
and then
- Entity (Selector_Name (A1)) = Entity (Selector_Name (A2));
+ Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
-- For explicit dereferences, prefixes must be same
- elsif Nkind (A1) = N_Explicit_Dereference then
- return Denotes_Same_Object (Prefix (A1), Prefix (A2));
+ 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 (A1) = N_Indexed_Component then
- if Denotes_Same_Object (Prefix (A1), Prefix (A2)) then
+ 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 (A1));
- Indx2 := First (Expressions (A2));
+ Indx1 := First (Expressions (Obj1));
+ Indx2 := First (Expressions (Obj2));
while Present (Indx1) loop
- -- Shouldn't we be checking that values are the same???
+ -- 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;
- if not Denotes_Same_Object (Indx1, Indx2) then
+ elsif not Denotes_Same_Object (Indx1, Indx2) then
return False;
end if;
-- For slices, prefixes must match and bounds must match
- elsif Nkind (A1) = N_Slice
- and then Denotes_Same_Object (Prefix (A1), Prefix (A2))
+ 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 (A1), Lo1, Hi1);
- Get_Index_Bounds (Etype (A2), Lo2, Hi2);
+ 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.
- -- What about an array and a slice of an array???
-
return Denotes_Same_Object (Lo1, Lo2)
and then Denotes_Same_Object (Hi1, Hi2);
end;
- -- Literals will appear as indices. Isn't this where we should check
+ -- 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 (A1) = N_Integer_Literal then
- return Intval (A1) = Intval (A2);
+ elsif Nkind (Obj1) = N_Integer_Literal then
+ return Intval (Obj1) = Intval (Obj2);
else
return False;
return Current_Node;
end Enclosing_Lib_Unit_Node;
+ -----------------------
+ -- Enclosing_Package --
+ -----------------------
+
+ function Enclosing_Package (E : Entity_Id) return Entity_Id is
+ Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
+
+ begin
+ if Dynamic_Scope = Standard_Standard then
+ return Standard_Standard;
+
+ elsif Dynamic_Scope = Empty then
+ return Empty;
+
+ elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
+ E_Generic_Package)
+ then
+ return Dynamic_Scope;
+
+ else
+ return Enclosing_Package (Dynamic_Scope);
+ end if;
+ end Enclosing_Package;
+
--------------------------
-- Enclosing_Subprogram --
--------------------------
then
null;
- -- A controller component for a type extension overrides the
- -- inherited component.
-
- elsif Chars (E) = Name_uController then
- null;
-
-- Case of an implicit operation or derived literal. The new entity
-- hides the implicit one, which is removed from all visibility,
-- i.e. the entity list of its scope, and homonym chain of its name.
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
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_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;
Append_Entity (Def_Id, S);
Set_Public_Status (Def_Id);
+ -- Declaring a homonym is not allowed in SPARK ...
+
+ if Present (C)
+ and then Restriction_Check_Required (SPARK)
+ then
+
+ declare
+ Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
+ Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
+ Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C);
+ begin
+
+ -- ... unless the new declaration is in a subprogram, and the
+ -- visible declaration is a variable declaration or a parameter
+ -- specification outside that subprogram.
+
+ if Present (Enclosing_Subp)
+ and then Nkind_In (Parent (C), N_Object_Declaration,
+ N_Parameter_Specification)
+ and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
+ then
+ null;
+
+ -- ... or the new declaration is in a package, and the visible
+ -- declaration occurs outside that package.
+
+ elsif Present (Enclosing_Pack)
+ and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
+ then
+ null;
+
+ -- ... or the new declaration is a component declaration in a
+ -- record type definition.
+
+ elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
+ null;
+
+ -- Don't issue error for non-source entities
+
+ elsif Comes_From_Source (Def_Id)
+ and then Comes_From_Source (C)
+ then
+ Error_Msg_Sloc := Sloc (C);
+ Check_SPARK_Restriction
+ ("redeclaration of identifier &#", Def_Id);
+ end if;
+ end;
+ end if;
+
-- Warn if new entity hides an old one
if Warn_On_Hiding and then Present (C)
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)
then
Call := Parent (Parnt);
- elsif Nkind (Parnt) = N_Procedure_Call_Statement then
+ elsif Nkind_In (Parnt, N_Procedure_Call_Statement, N_Function_Call) then
Call := Parnt;
else
begin
if not Is_Tag (Comp)
and then Chars (Comp) /= Name_uParent
- and then Chars (Comp) /= Name_uController
then
Append_Elmt (Comp, Into);
end if;
end if;
end Get_Actual_Subtype_If_Available;
+ ------------------------
+ -- Get_Body_From_Stub --
+ ------------------------
+
+ function Get_Body_From_Stub (N : Node_Id) return Node_Id is
+ begin
+ return Proper_Body (Unit (Library_Unit (N)));
+ end Get_Body_From_Stub;
+
-------------------------------
-- Get_Default_External_Name --
-------------------------------
Strval => String_From_Name_Buffer);
end Get_Default_External_Name;
+ --------------------------
+ -- Get_Enclosing_Object --
+ --------------------------
+
+ function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
+ begin
+ if Is_Entity_Name (N) then
+ return Entity (N);
+ else
+ case Nkind (N) is
+ when N_Indexed_Component |
+ N_Slice |
+ N_Selected_Component =>
+
+ -- If not generating code, a dereference may be left implicit.
+ -- In thoses cases, return Empty.
+
+ if Is_Access_Type (Etype (Prefix (N))) then
+ return Empty;
+ else
+ return Get_Enclosing_Object (Prefix (N));
+ end if;
+
+ when N_Type_Conversion =>
+ return Get_Enclosing_Object (Expression (N));
+
+ when others =>
+ return Empty;
+ end case;
+ end if;
+ end Get_Enclosing_Object;
+
---------------------------
-- Get_Enum_Lit_From_Pos --
---------------------------
end if;
end Get_Enum_Lit_From_Pos;
+ ---------------------------------------
+ -- Get_Ensures_From_Test_Case_Pragma --
+ ---------------------------------------
+
+ function Get_Ensures_From_Test_Case_Pragma (N : Node_Id) return Node_Id is
+ Args : constant List_Id := Pragma_Argument_Associations (N);
+ Res : Node_Id;
+
+ begin
+ if List_Length (Args) = 4 then
+ Res := Pick (Args, 4);
+
+ else
+ Res := Pick (Args, 3);
+ if Chars (Res) /= Name_Ensures then
+ Res := Empty;
+ end if;
+ end if;
+
+ return Res;
+ end Get_Ensures_From_Test_Case_Pragma;
+
------------------------
-- Get_Generic_Entity --
------------------------
return Entity_Id (Get_Name_Table_Info (Id));
end Get_Name_Entity_Id;
+ ------------------------------------
+ -- Get_Name_From_Test_Case_Pragma --
+ ------------------------------------
+
+ function Get_Name_From_Test_Case_Pragma (N : Node_Id) return String_Id is
+ Arg : constant Node_Id :=
+ Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
+ begin
+ return Strval (Expr_Value_S (Arg));
+ end Get_Name_From_Test_Case_Pragma;
+
-------------------
-- Get_Pragma_Id --
-------------------
return R;
end Get_Renamed_Entity;
+ ----------------------------------------
+ -- Get_Requires_From_Test_Case_Pragma --
+ ----------------------------------------
+
+ function Get_Requires_From_Test_Case_Pragma (N : Node_Id) return Node_Id is
+ Args : constant List_Id := Pragma_Argument_Associations (N);
+ Res : Node_Id;
+
+ begin
+ Res := Pick (Args, 3);
+ if Chars (Res) /= Name_Requires then
+ Res := Empty;
+ end if;
+
+ return Res;
+ end Get_Requires_From_Test_Case_Pragma;
+
-------------------------
-- Get_Subprogram_Body --
-------------------------
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;
-
- Next_Component (Comp);
- end loop;
+ -- Here if type itself does not have a non-null Initialize operation:
+ -- check immediate ancestor.
- 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_In (Ent, E_Component, E_Discriminant) then
+ Exp := Empty;
- -- 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.
+ case Ekind (Ent) is
+ when E_Component =>
- if Present (Declaration_Node (Ent)) then
- Exp := Expression (Declaration_Node (Ent));
- else
- Exp := Empty;
- end if;
+ -- 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.
- -- 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;
+ 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.
- elsif not Is_Preelaborable_Expression (Exp) then
+ Exp := Discriminant_Default_Value (Ent);
+
+ when others =>
+ goto Check_Next_Entity;
+ end case;
+
+ -- 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_Private_Component;
+ -----------------------------
+ -- Has_Static_Array_Bounds --
+ -----------------------------
+
+ function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
+ Ndims : constant Nat := Number_Dimensions (Typ);
+
+ Index : Node_Id;
+ Low : Node_Id;
+ High : Node_Id;
+
+ begin
+ -- Unconstrained types do not have static bounds
+
+ if not Is_Constrained (Typ) then
+ return False;
+ end if;
+
+ -- First treat string literals specially, as the lower bound and length
+ -- of string literals are not stored like those of arrays.
+
+ -- A string literal always has static bounds
+
+ if Ekind (Typ) = E_String_Literal_Subtype then
+ return True;
+ end if;
+
+ -- Treat all dimensions in turn
+
+ Index := First_Index (Typ);
+ for Indx in 1 .. Ndims loop
+
+ -- In case of an erroneous index which is not a discrete type, return
+ -- that the type is not static.
+
+ if not Is_Discrete_Type (Etype (Index))
+ or else Etype (Index) = Any_Type
+ then
+ return False;
+ end if;
+
+ Get_Index_Bounds (Index, Low, High);
+
+ if Error_Posted (Low) or else Error_Posted (High) then
+ return False;
+ end if;
+
+ if Is_OK_Static_Expression (Low)
+ and then
+ Is_OK_Static_Expression (High)
+ then
+ null;
+ else
+ return False;
+ end if;
+
+ Next (Index);
+ end loop;
+
+ -- If we fall through the loop, all indexes matched
+
+ return True;
+ end Has_Static_Array_Bounds;
+
----------------
-- Has_Stream --
----------------
Elmt := First_Elmt (Ifaces_List);
while Present (Elmt) loop
- if Is_Ancestor (Node (Elmt), Typ)
+ if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
and then Exclude_Parents
then
null;
and then not In_Private_Part (Scope_Id);
end In_Visible_Part;
+ --------------------------------
+ -- Incomplete_Or_Private_View --
+ --------------------------------
+
+ function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id is
+ function Inspect_Decls
+ (Decls : List_Id;
+ Taft : Boolean := False) return Entity_Id;
+ -- Check whether a declarative region contains the incomplete or private
+ -- view of Typ.
+
+ -------------------
+ -- Inspect_Decls --
+ -------------------
+
+ function Inspect_Decls
+ (Decls : List_Id;
+ Taft : Boolean := False) return Entity_Id
+ is
+ Decl : Node_Id;
+ Match : Node_Id;
+
+ begin
+ Decl := First (Decls);
+ while Present (Decl) loop
+ Match := Empty;
+
+ if Taft then
+ if Nkind (Decl) = N_Incomplete_Type_Declaration then
+ Match := Defining_Identifier (Decl);
+ end if;
+
+ else
+ if Nkind_In (Decl, N_Private_Extension_Declaration,
+ N_Private_Type_Declaration)
+ then
+ Match := Defining_Identifier (Decl);
+ end if;
+ end if;
+
+ if Present (Match)
+ and then Present (Full_View (Match))
+ and then Full_View (Match) = Typ
+ then
+ return Match;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ return Empty;
+ end Inspect_Decls;
+
+ -- Local variables
+
+ Prev : Entity_Id;
+
+ -- Start of processing for Incomplete_Or_Partial_View
+
+ begin
+ -- Incomplete type case
+
+ Prev := Current_Entity_In_Scope (Typ);
+
+ if Present (Prev)
+ and then Is_Incomplete_Type (Prev)
+ and then Present (Full_View (Prev))
+ and then Full_View (Prev) = Typ
+ then
+ return Prev;
+ end if;
+
+ -- Private or Taft amendment type case
+
+ declare
+ Pkg : constant Entity_Id := Scope (Typ);
+ Pkg_Decl : Node_Id := Pkg;
+
+ begin
+ if Ekind (Pkg) = E_Package then
+ while Nkind (Pkg_Decl) /= N_Package_Specification loop
+ Pkg_Decl := Parent (Pkg_Decl);
+ end loop;
+
+ -- It is knows that Typ has a private view, look for it in the
+ -- visible declarations of the enclosing scope. A special case
+ -- of this is when the two views have been exchanged - the full
+ -- appears earlier than the private.
+
+ if Has_Private_Declaration (Typ) then
+ Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
+
+ -- Exchanged view case, look in the private declarations
+
+ if No (Prev) then
+ Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
+ end if;
+
+ return Prev;
+
+ -- Otherwise if this is the package body, then Typ is a potential
+ -- Taft amendment type. The incomplete view should be located in
+ -- the private declarations of the enclosing scope.
+
+ elsif In_Package_Body (Pkg) then
+ return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
+ end if;
+ end if;
+ end;
+
+ -- The type has no incomplete or private view
+
+ return Empty;
+ end Incomplete_Or_Private_View;
+
---------------------------------
-- Insert_Explicit_Dereference --
---------------------------------
end loop;
end Inspect_Deferred_Constant_Completion;
- -------------------
- -- Is_AAMP_Float --
- -------------------
-
- function Is_AAMP_Float (E : Entity_Id) return Boolean is
- pragma Assert (Is_Type (E));
- begin
- return AAMP_On_Target
- and then Is_Floating_Point_Type (E)
- and then E = Base_Type (E);
- end Is_AAMP_Float;
-
-----------------------------
-- Is_Actual_Out_Parameter --
-----------------------------
end case;
end Is_Actual_Parameter;
+ --------------------------------
+ -- Is_Actual_Tagged_Parameter --
+ --------------------------------
+
+ function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
+ Formal : Entity_Id;
+ Call : Node_Id;
+ begin
+ Find_Actual (N, Formal, Call);
+ return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
+ end Is_Actual_Tagged_Parameter;
+
---------------------
-- Is_Aliased_View --
---------------------
end if;
end Is_Atomic_Object;
- -------------------------
- -- Is_Coextension_Root --
- -------------------------
-
- function Is_Coextension_Root (N : Node_Id) return Boolean is
- begin
- return
- Nkind (N) = N_Allocator
- and then Present (Coextensions (N))
-
- -- Anonymous access discriminants carry a list of all nested
- -- controlled coextensions.
-
- and then not Is_Dynamic_Coextension (N)
- and then not Is_Static_Coextension (N);
- end Is_Coextension_Root;
-
-----------------------------
-- Is_Concurrent_Interface --
-----------------------------
end if;
end Is_Descendent_Of;
+ ----------------------------
+ -- Is_Expression_Function --
+ ----------------------------
+
+ function Is_Expression_Function (Subp : Entity_Id) return Boolean is
+ Decl : constant Node_Id := Unit_Declaration_Node (Subp);
+
+ begin
+ return Ekind (Subp) = E_Function
+ and then Nkind (Decl) = N_Subprogram_Declaration
+ and then
+ (Nkind (Original_Node (Decl)) = N_Expression_Function
+ or else
+ (Present (Corresponding_Body (Decl))
+ and then
+ Nkind (Original_Node
+ (Unit_Declaration_Node (Corresponding_Body (Decl))))
+ = N_Expression_Function));
+ end Is_Expression_Function;
+
--------------
-- Is_False --
--------------
begin
Ent := First_Entity (Typ);
while Present (Ent) loop
- if Chars (Ent) = Name_uController then
- null;
-
- elsif Ekind (Ent) = E_Component
+ if Ekind (Ent) = E_Component
and then (No (Parent (Ent))
or else No (Expression (Parent (Ent))))
and then not Is_Fully_Initialized_Type (Etype (Ent))
function Is_LHS (N : Node_Id) return Boolean is
P : constant Node_Id := Parent (N);
+
begin
- return Nkind (P) = N_Assignment_Statement
- and then Name (P) = N;
+ 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;
----------------------------
and then Is_Derived_Type (Etype (E)));
end Is_Inherited_Operation;
+ -------------------------------------
+ -- Is_Inherited_Operation_For_Type --
+ -------------------------------------
+
+ function Is_Inherited_Operation_For_Type
+ (E : Entity_Id; Typ : Entity_Id) return Boolean
+ is
+ begin
+ return Is_Inherited_Operation (E)
+ and then Etype (Parent (E)) = Typ;
+ end Is_Inherited_Operation_For_Type;
+
-----------------------------
-- Is_Library_Level_Entity --
-----------------------------
-- 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;
begin
-- Verify that prefix is analyzed and has the proper form. Note that
- -- the attributes Elab_Spec, Elab_Body, and UET_Address, which also
- -- produce the address of an entity, do not analyze their prefix
- -- because they denote entities that are not necessarily visible.
+ -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address,
+ -- which also produce the address of an entity, do not analyze their
+ -- prefix because they denote entities that are not necessarily visible.
-- Neither of them can apply to a protected type.
return Ada_Version >= Ada_2005
end if;
end Is_Selector_Name;
+ ----------------------------------
+ -- Is_SPARK_Initialization_Expr --
+ ----------------------------------
+
+ function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is
+ Is_Ok : Boolean;
+ Expr : Node_Id;
+ Comp_Assn : Node_Id;
+ Orig_N : constant Node_Id := Original_Node (N);
+
+ begin
+ Is_Ok := True;
+
+ if not Comes_From_Source (Orig_N) then
+ goto Done;
+ end if;
+
+ pragma Assert (Nkind (Orig_N) in N_Subexpr);
+
+ case Nkind (Orig_N) is
+ when N_Character_Literal |
+ N_Integer_Literal |
+ N_Real_Literal |
+ N_String_Literal =>
+ null;
+
+ when N_Identifier |
+ N_Expanded_Name =>
+ if Is_Entity_Name (Orig_N)
+ and then Present (Entity (Orig_N)) -- needed in some cases
+ then
+ case Ekind (Entity (Orig_N)) is
+ when E_Constant |
+ E_Enumeration_Literal |
+ E_Named_Integer |
+ E_Named_Real =>
+ null;
+ when others =>
+ if Is_Type (Entity (Orig_N)) then
+ null;
+ else
+ Is_Ok := False;
+ end if;
+ end case;
+ end if;
+
+ when N_Qualified_Expression |
+ N_Type_Conversion =>
+ Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N));
+
+ when N_Unary_Op =>
+ Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
+
+ when N_Binary_Op |
+ N_Short_Circuit |
+ N_Membership_Test =>
+ Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N))
+ and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
+
+ when N_Aggregate |
+ N_Extension_Aggregate =>
+ if Nkind (Orig_N) = N_Extension_Aggregate then
+ Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N));
+ end if;
+
+ Expr := First (Expressions (Orig_N));
+ while Present (Expr) loop
+ if not Is_SPARK_Initialization_Expr (Expr) then
+ Is_Ok := False;
+ goto Done;
+ end if;
+
+ Next (Expr);
+ end loop;
+
+ Comp_Assn := First (Component_Associations (Orig_N));
+ while Present (Comp_Assn) loop
+ Expr := Expression (Comp_Assn);
+ if Present (Expr) -- needed for box association
+ and then not Is_SPARK_Initialization_Expr (Expr)
+ then
+ Is_Ok := False;
+ goto Done;
+ end if;
+
+ Next (Comp_Assn);
+ end loop;
+
+ when N_Attribute_Reference =>
+ if Nkind (Prefix (Orig_N)) in N_Subexpr then
+ Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N));
+ end if;
+
+ Expr := First (Expressions (Orig_N));
+ while Present (Expr) loop
+ if not Is_SPARK_Initialization_Expr (Expr) then
+ Is_Ok := False;
+ goto Done;
+ end if;
+
+ Next (Expr);
+ end loop;
+
+ -- Selected components might be expanded named not yet resolved, so
+ -- default on the safe side. (Eg on sparklex.ads)
+
+ when N_Selected_Component =>
+ null;
+
+ when others =>
+ Is_Ok := False;
+ end case;
+
+ <<Done>>
+ return Is_Ok;
+ end Is_SPARK_Initialization_Expr;
+
+ -------------------------------
+ -- Is_SPARK_Object_Reference --
+ -------------------------------
+
+ function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
+ begin
+ if Is_Entity_Name (N) then
+ return Present (Entity (N))
+ and then
+ (Ekind_In (Entity (N), E_Constant, E_Variable)
+ or else Ekind (Entity (N)) in Formal_Kind);
+
+ else
+ case Nkind (N) is
+ when N_Selected_Component =>
+ return Is_SPARK_Object_Reference (Prefix (N));
+
+ when others =>
+ return False;
+ end case;
+ end if;
+ end Is_SPARK_Object_Reference;
+
------------------
-- Is_Statement --
------------------
or else Nkind (N) = N_Procedure_Call_Statement;
end Is_Statement;
+ --------------------------------------------------
+ -- Is_Subprogram_Stub_Without_Prior_Declaration --
+ --------------------------------------------------
+
+ function Is_Subprogram_Stub_Without_Prior_Declaration
+ (N : Node_Id) return Boolean is
+
+ begin
+ -- A subprogram stub without prior declaration serves as declaration for
+ -- the actual subprogram body. As such, it has an attached defining
+ -- entity of E_[Generic_]Function or E_[Generic_]Procedure.
+
+ return Nkind (N) = N_Subprogram_Body_Stub
+ and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
+ end Is_Subprogram_Stub_Without_Prior_Declaration;
+
---------------------------------
-- Is_Synchronized_Tagged_Type --
---------------------------------
and then Is_Synchronized_Interface (E))
or else
(Ekind (E) = E_Record_Type_With_Private
+ and then Nkind (Parent (E)) = N_Private_Extension_Declaration
and then (Synchronized_Present (Parent (E))
or else Is_Synchronized_Interface (Etype (E))));
end Is_Synchronized_Tagged_Type;
-- 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.
+ function Is_Variable
+ (N : Node_Id;
+ Use_Original_Node : Boolean := True) return Boolean
+ is
+ Orig_Node : Node_Id;
function In_Protected_Function (E : Entity_Id) return Boolean;
-- Within a protected function, the private components of the enclosing
-- Start of processing for Is_Variable
begin
+ -- Check if we perform the test on the original node since this may be a
+ -- test of syntactic categories which 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.
+
+ if Use_Original_Node then
+ Orig_Node := Original_Node (N);
+ else
+ Orig_Node := N;
+ end if;
+
-- Definitely OK if Assignment_OK is set. Since this is something that
-- only gets set for expanded nodes, the test is on N, not Orig_Node.
end loop;
end;
- -- Test for appearing in a conversion that itself appears
- -- in an lvalue context, since this should be an lvalue.
+ -- Test for appearing in a conversion that itself appears
+ -- in an lvalue context, since this should be an lvalue.
+
+ when N_Type_Conversion =>
+ return Known_To_Be_Assigned (P);
+
+ -- All other references are definitely not known to be modifications
+
+ when others =>
+ return False;
+
+ end case;
+ end Known_To_Be_Assigned;
+
+ ---------------------------
+ -- Last_Source_Statement --
+ ---------------------------
+
+ function Last_Source_Statement (HSS : Node_Id) return Node_Id is
+ N : Node_Id;
+
+ begin
+ N := Last (Statements (HSS));
+ while Present (N) loop
+ exit when Comes_From_Source (N);
+ Prev (N);
+ end loop;
+
+ return N;
+ end Last_Source_Statement;
+
+ ----------------------------------
+ -- Matching_Static_Array_Bounds --
+ ----------------------------------
+
+ function Matching_Static_Array_Bounds
+ (L_Typ : Node_Id;
+ R_Typ : Node_Id) return Boolean
+ is
+ L_Ndims : constant Nat := Number_Dimensions (L_Typ);
+ R_Ndims : constant Nat := Number_Dimensions (R_Typ);
+
+ L_Index : Node_Id;
+ R_Index : Node_Id;
+ L_Low : Node_Id;
+ L_High : Node_Id;
+ L_Len : Uint;
+ R_Low : Node_Id;
+ R_High : Node_Id;
+ R_Len : Uint;
+
+ begin
+ if L_Ndims /= R_Ndims then
+ return False;
+ end if;
+
+ -- Unconstrained types do not have static bounds
+
+ if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
+ return False;
+ end if;
+
+ -- First treat specially the first dimension, as the lower bound and
+ -- length of string literals are not stored like those of arrays.
+
+ if Ekind (L_Typ) = E_String_Literal_Subtype then
+ L_Low := String_Literal_Low_Bound (L_Typ);
+ L_Len := String_Literal_Length (L_Typ);
+ else
+ L_Index := First_Index (L_Typ);
+ Get_Index_Bounds (L_Index, L_Low, L_High);
+
+ if Is_OK_Static_Expression (L_Low)
+ and then Is_OK_Static_Expression (L_High)
+ then
+ if Expr_Value (L_High) < Expr_Value (L_Low) then
+ L_Len := Uint_0;
+ else
+ L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
+ end if;
+ else
+ return False;
+ end if;
+ end if;
+
+ if Ekind (R_Typ) = E_String_Literal_Subtype then
+ R_Low := String_Literal_Low_Bound (R_Typ);
+ R_Len := String_Literal_Length (R_Typ);
+ else
+ R_Index := First_Index (R_Typ);
+ Get_Index_Bounds (R_Index, R_Low, R_High);
+
+ if Is_OK_Static_Expression (R_Low)
+ and then Is_OK_Static_Expression (R_High)
+ then
+ if Expr_Value (R_High) < Expr_Value (R_Low) then
+ R_Len := Uint_0;
+ else
+ R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
+ end if;
+ else
+ return False;
+ end if;
+ end if;
+
+ if Is_OK_Static_Expression (L_Low)
+ and then Is_OK_Static_Expression (R_Low)
+ and then Expr_Value (L_Low) = Expr_Value (R_Low)
+ and then L_Len = R_Len
+ then
+ null;
+ else
+ return False;
+ end if;
+
+ -- Then treat all other dimensions
- when N_Type_Conversion =>
- return Known_To_Be_Assigned (P);
+ for Indx in 2 .. L_Ndims loop
+ Next (L_Index);
+ Next (R_Index);
- -- All other references are definitely not known to be modifications
+ Get_Index_Bounds (L_Index, L_Low, L_High);
+ Get_Index_Bounds (R_Index, R_Low, R_High);
- when others =>
+ if Is_OK_Static_Expression (L_Low)
+ and then Is_OK_Static_Expression (L_High)
+ and then Is_OK_Static_Expression (R_Low)
+ and then Is_OK_Static_Expression (R_High)
+ and then Expr_Value (L_Low) = Expr_Value (R_Low)
+ and then Expr_Value (L_High) = Expr_Value (R_High)
+ then
+ null;
+ else
return False;
+ end if;
+ end loop;
- end case;
- end Known_To_Be_Assigned;
+ -- If we fall through the loop, all indexes matched
+
+ return True;
+ end Matching_Static_Array_Bounds;
-------------------
-- May_Be_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;
-- 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;
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;
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);
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 --
-----------------------
elsif Is_Record_Type (Btype) then
Component := First_Entity (Btype);
- while Present (Component) loop
-
+ while Present (Component)
+ and then Comes_From_Source (Component)
+ loop
-- Skip anonymous types generated by constrained components
if not Is_Type (Component) then
procedure Process_End_Label
(N : Node_Id;
Typ : Character;
- Ent : Entity_Id)
+ Ent : Entity_Id)
is
Loc : Source_Ptr;
Nam : Node_Id;
Get_Decoded_Name_String (Chars (Endl));
Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
+
+ else
+ -- In SPARK mode, no missing label is allowed for packages and
+ -- subprogram bodies. Detect those cases by testing whether
+ -- Process_End_Label was called for a body (Typ = 't') or a package.
+
+ if Restriction_Check_Required (SPARK)
+ and then (Typ = 't' or else Ekind (Ent) = E_Package)
+ then
+ Error_Msg_Node_1 := Endl;
+ Check_SPARK_Restriction ("`END &` required", Endl, Force => True);
+ end if;
end if;
-- Now generate the e/t reference
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
procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is
begin
- if Is_Entity_Name (N)
+ 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
-- Set_Current_Entity --
------------------------
- -- The given entity is to be set as the currently visible definition
- -- of its associated name (i.e. the Node_Id associated with its name).
- -- All we have to do is to get the name from the identifier, and
- -- then set the associated Node_Id to point to the given entity.
+ -- The given entity is to be set as the currently visible definition of its
+ -- associated name (i.e. the Node_Id associated with its name). All we have
+ -- to do is to get the name from the identifier, and then set the
+ -- associated Node_Id to point to the given entity.
procedure Set_Current_Entity (E : Entity_Id) is
begin
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;
+ ------------------------------------
+ -- Type_Without_Stream_Operation --
+ ------------------------------------
+
+ function Type_Without_Stream_Operation
+ (T : Entity_Id;
+ Op : TSS_Name_Type := TSS_Null) return Entity_Id
+ is
+ BT : constant Entity_Id := Base_Type (T);
+ Op_Missing : Boolean;
+
+ begin
+ if not Restriction_Active (No_Default_Stream_Attributes) then
+ return Empty;
+ end if;
+
+ if Is_Elementary_Type (T) then
+ if Op = TSS_Null then
+ Op_Missing :=
+ No (TSS (BT, TSS_Stream_Read))
+ or else No (TSS (BT, TSS_Stream_Write));
+
+ else
+ Op_Missing := No (TSS (BT, Op));
+ end if;
+
+ if Op_Missing then
+ return T;
+ else
+ return Empty;
+ end if;
+
+ elsif Is_Array_Type (T) then
+ return Type_Without_Stream_Operation (Component_Type (T), Op);
+
+ elsif Is_Record_Type (T) then
+ declare
+ Comp : Entity_Id;
+ C_Typ : Entity_Id;
+
+ begin
+ Comp := First_Component (T);
+ while Present (Comp) loop
+ C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
+
+ if Present (C_Typ) then
+ return C_Typ;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ return Empty;
+ end;
+
+ elsif Is_Private_Type (T)
+ and then Present (Full_View (T))
+ then
+ return Type_Without_Stream_Operation (Full_View (T), Op);
+ else
+ return Empty;
+ end if;
+ end Type_Without_Stream_Operation;
+
+ ----------------------------
+ -- Unique_Defining_Entity --
+ ----------------------------
+
+ function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
+ begin
+ case Nkind (N) is
+ when N_Package_Body =>
+ return Corresponding_Spec (N);
+
+ when N_Subprogram_Body =>
+ if Acts_As_Spec (N) then
+ return Defining_Entity (N);
+ else
+ return Corresponding_Spec (N);
+ end if;
+
+ when others =>
+ return Defining_Entity (N);
+ end case;
+ end Unique_Defining_Entity;
+
+ -----------------
+ -- Unique_Name --
+ -----------------
+
+ function Unique_Name (E : Entity_Id) return String is
+
+ function Get_Scoped_Name (E : Entity_Id) return String;
+ -- Return the name of E prefixed by all the names of the scopes to which
+ -- E belongs, except for Standard.
+
+ ---------------------
+ -- Get_Scoped_Name --
+ ---------------------
+
+ function Get_Scoped_Name (E : Entity_Id) return String is
+ Name : constant String := Get_Name_String (Chars (E));
+ begin
+ if Has_Fully_Qualified_Name (E)
+ or else Scope (E) = Standard_Standard
+ then
+ return Name;
+ else
+ return Get_Scoped_Name (Scope (E)) & "__" & Name;
+ end if;
+ end Get_Scoped_Name;
+
+ -- Start of processing for Unique_Name
+
+ begin
+ if E = Standard_Standard then
+ return Get_Name_String (Name_Standard);
+
+ elsif Scope (E) = Standard_Standard
+ and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
+ then
+ return Get_Name_String (Name_Standard) & "__" &
+ Get_Name_String (Chars (E));
+
+ else
+ return Get_Scoped_Name (E);
+ end if;
+ end Unique_Name;
+
--------------------------
-- Unit_Declaration_Node --
--------------------------
return N;
end Unit_Declaration_Node;
+ ---------------------
+ -- Unit_Is_Visible --
+ ---------------------
+
+ function Unit_Is_Visible (U : Entity_Id) return Boolean is
+ Curr : constant Node_Id := Cunit (Current_Sem_Unit);
+ Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
+
+ function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
+ -- For a child unit, check whether unit appears in a with_clause
+ -- of a parent.
+
+ function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
+ -- Scan the context clause of one compilation unit looking for a
+ -- with_clause for the unit in question.
+
+ ----------------------------
+ -- Unit_In_Parent_Context --
+ ----------------------------
+
+ function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
+ begin
+ if Unit_In_Context (Par_Unit) then
+ return True;
+
+ elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
+ return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
+
+ else
+ return False;
+ end if;
+ end Unit_In_Parent_Context;
+
+ ---------------------
+ -- Unit_In_Context --
+ ---------------------
+
+ function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
+ Clause : Node_Id;
+
+ begin
+ Clause := First (Context_Items (Comp_Unit));
+ while Present (Clause) loop
+ if Nkind (Clause) = N_With_Clause then
+ if Library_Unit (Clause) = U then
+ return True;
+
+ -- The with_clause may denote a renaming of the unit we are
+ -- looking for, eg. Text_IO which renames Ada.Text_IO.
+
+ elsif
+ Renamed_Entity (Entity (Name (Clause))) =
+ Defining_Entity (Unit (U))
+ then
+ return True;
+ end if;
+ end if;
+
+ Next (Clause);
+ end loop;
+
+ return False;
+ end Unit_In_Context;
+
+ -- Start of processing for Unit_Is_Visible
+
+ begin
+ -- The currrent unit is directly visible
+
+ if Curr = U then
+ return True;
+
+ elsif Unit_In_Context (Curr) then
+ return True;
+
+ -- If the current unit is a body, check the context of the spec
+
+ elsif Nkind (Unit (Curr)) = N_Package_Body
+ or else
+ (Nkind (Unit (Curr)) = N_Subprogram_Body
+ and then not Acts_As_Spec (Unit (Curr)))
+ then
+ if Unit_In_Context (Library_Unit (Curr)) then
+ return True;
+ end if;
+ end if;
+
+ -- If the spec is a child unit, examine the parents
+
+ if Is_Child_Unit (Curr_Entity) then
+ if Nkind (Unit (Curr)) in N_Unit_Body then
+ return
+ Unit_In_Parent_Context
+ (Parent_Spec (Unit (Library_Unit (Curr))));
+ else
+ return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
+ end if;
+
+ else
+ return False;
+ end if;
+ end Unit_Is_Visible;
+
------------------------------
-- Universal_Interpretation --
------------------------------
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 --
----------------------
Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
+ Matching_Field : Entity_Id;
+ -- Entity to give a more precise suggestion on how to write a one-
+ -- element positional aggregate.
+
function Has_One_Matching_Field return Boolean;
-- Determines if Expec_Type is a record type with a single component or
-- discriminant whose type matches the found type or is one dimensional
E : Entity_Id;
begin
+ Matching_Field := Empty;
+
if Is_Array_Type (Expec_Type)
and then Number_Dimensions (Expec_Type) = 1
and then
Covers (Etype (Component_Type (Expec_Type)), Found_Type)
then
+ -- Use type name if available. This excludes multidimensional
+ -- arrays and anonymous arrays.
+
+ if Comes_From_Source (Expec_Type) then
+ Matching_Field := Expec_Type;
+
+ -- For an assignment, use name of target
+
+ elsif Nkind (Parent (Expr)) = N_Assignment_Statement
+ and then Is_Entity_Name (Name (Parent (Expr)))
+ then
+ Matching_Field := Entity (Name (Parent (Expr)));
+ end if;
+
return True;
elsif not Is_Record_Type (Expec_Type) then
return False;
else
+ Matching_Field := E;
return True;
end if;
end if;
and then Has_One_Matching_Field
then
Error_Msg_N ("positional aggregate cannot have one component", Expr);
+ if Present (Matching_Field) then
+ if Is_Array_Type (Expec_Type) then
+ Error_Msg_NE
+ ("\write instead `&''First ='> ...`", Expr, Matching_Field);
+
+ else
+ Error_Msg_NE
+ ("\write instead `& ='> ...`", Expr, Matching_Field);
+ end if;
+ end if;
-- Another special check, if we are looking for a pool-specific access
-- type and we found an E_Access_Attribute_Type, then we have the case