-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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 Freeze; use Freeze;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Output; use Output;
with Scans; use Scans;
with Scn; use Scn;
with Sem; use Sem;
+with Sem_Attr; use Sem_Attr;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
elsif Ekind (Typ) = E_Record_Subtype then
Nod := Type_Definition (Parent (Etype (Typ)));
+ elsif Ekind (Typ) = E_Record_Subtype_With_Private then
+
+ -- Recurse, because parent may still be a private extension
+
+ return Abstract_Interface_List (Etype (Full_View (Typ)));
+
else pragma Assert ((Ekind (Typ)) = E_Record_Type);
if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
Nod := Formal_Type_Definition (Parent (Typ));
Append_Elmt (A, L);
end Add_Access_Type_To_Process;
+ ----------------------------
+ -- Add_Global_Declaration --
+ ----------------------------
+
+ procedure Add_Global_Declaration (N : Node_Id) is
+ Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
+
+ begin
+ if No (Declarations (Aux_Node)) then
+ Set_Declarations (Aux_Node, New_List);
+ end if;
+
+ Append_To (Declarations (Aux_Node), N);
+ Analyze (N);
+ end Add_Global_Declaration;
+
-----------------------
-- Alignment_In_Bits --
-----------------------
------------------------------
procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
- Decl : Node_Id;
- P : Natural;
- Elab_Ent : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Decl : Node_Id;
+ Elab_Ent : Entity_Id;
+
+ procedure Set_Package_Name (Ent : Entity_Id);
+ -- Given an entity, sets the fully qualified name of the entity in
+ -- Name_Buffer, with components separated by double underscores. This
+ -- is a recursive routine that climbs the scope chain to Standard.
+
+ ----------------------
+ -- Set_Package_Name --
+ ----------------------
+
+ procedure Set_Package_Name (Ent : Entity_Id) is
+ begin
+ if Scope (Ent) /= Standard_Standard then
+ Set_Package_Name (Scope (Ent));
+
+ declare
+ Nam : constant String := Get_Name_String (Chars (Ent));
+ begin
+ Name_Buffer (Name_Len + 1) := '_';
+ Name_Buffer (Name_Len + 2) := '_';
+ Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
+ Name_Len := Name_Len + Nam'Length + 2;
+ end;
+
+ else
+ Get_Name_String (Chars (Ent));
+ end if;
+ end Set_Package_Name;
+
+ -- Start of processing for Build_Elaboration_Entity
begin
-- Ignore if already constructed
return;
end if;
- -- Construct name of elaboration entity as xxx_E, where xxx
- -- is the unit name with dots replaced by double underscore.
- -- We have to manually construct this name, since it will
- -- be elaborated in the outer scope, and thus will not have
- -- the unit name automatically prepended.
-
- Get_Name_String (Unit_Name (Unum));
+ -- Construct name of elaboration entity as xxx_E, where xxx is the unit
+ -- name with dots replaced by double underscore. We have to manually
+ -- construct this name, since it will be elaborated in the outer scope,
+ -- and thus will not have the unit name automatically prepended.
- -- Replace the %s by _E
+ Set_Package_Name (Spec_Id);
- Name_Buffer (Name_Len - 1 .. Name_Len) := "_E";
+ -- Append _E
- -- Replace dots by double underscore
-
- P := 2;
- while P < Name_Len - 2 loop
- if Name_Buffer (P) = '.' then
- Name_Buffer (P + 2 .. Name_Len + 1) :=
- Name_Buffer (P + 1 .. Name_Len);
- Name_Len := Name_Len + 1;
- Name_Buffer (P) := '_';
- Name_Buffer (P + 1) := '_';
- P := P + 3;
- else
- P := P + 1;
- end if;
- end loop;
+ Name_Buffer (Name_Len + 1) := '_';
+ Name_Buffer (Name_Len + 2) := 'E';
+ Name_Len := Name_Len + 2;
-- Create elaboration flag
Make_Defining_Identifier (Loc, Chars => Name_Find);
Set_Elaboration_Entity (Spec_Id, Elab_Ent);
- if No (Declarations (Aux_Decls_Node (N))) then
- Set_Declarations (Aux_Decls_Node (N), New_List);
- end if;
-
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Elab_Ent,
Expression =>
New_Occurrence_Of (Standard_False, Loc));
- Append_To (Declarations (Aux_Decls_Node (N)), Decl);
- Analyze (Decl);
+ Push_Scope (Standard_Standard);
+ Add_Global_Declaration (Decl);
+ Pop_Scope;
-- Reset True_Constant indication, since we will indeed assign a value
-- to the variable in the binder main. We also kill the Current_Value
end if;
end Check_Fully_Declared;
+ -------------------------
+ -- Check_Nested_Access --
+ -------------------------
+
+ procedure Check_Nested_Access (Ent : Entity_Id) is
+ Scop : constant Entity_Id := Current_Scope;
+ Current_Subp : Entity_Id;
+
+ begin
+ -- Currently only enabled for VM back-ends for efficiency, should we
+ -- enable it more systematically ???
+
+ if VM_Target /= No_VM
+ and then (Ekind (Ent) = E_Variable
+ or else
+ Ekind (Ent) = E_Constant
+ or else
+ Ekind (Ent) = E_Loop_Parameter)
+ and then Scope (Ent) /= Empty
+ and then not Is_Library_Level_Entity (Ent)
+ then
+ if Is_Subprogram (Scop)
+ or else Is_Generic_Subprogram (Scop)
+ or else Is_Entry (Scop)
+ then
+ Current_Subp := Scop;
+ else
+ Current_Subp := Current_Subprogram;
+ end if;
+
+ if Enclosing_Subprogram (Ent) /= Current_Subp then
+ Set_Has_Up_Level_Access (Ent, True);
+ end if;
+ end if;
+ end Check_Nested_Access;
+
------------------------------------------
-- Check_Potentially_Blocking_Operation --
------------------------------------------
procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
- S : Entity_Id;
-
+ 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
end Collect_Abstract_Interfaces;
----------------------------------
+ -- Collect_Interface_Components --
+ ----------------------------------
+
+ procedure Collect_Interface_Components
+ (Tagged_Type : Entity_Id;
+ Components_List : out Elist_Id)
+ is
+ procedure Collect (Typ : Entity_Id);
+ -- Subsidiary subprogram used to climb to the parents
+
+ -------------
+ -- Collect --
+ -------------
+
+ procedure Collect (Typ : Entity_Id) is
+ Tag_Comp : Entity_Id;
+
+ begin
+ if Etype (Typ) /= Typ
+
+ -- Protect the frontend against wrong sources. For example:
+
+ -- package P is
+ -- type A is tagged null record;
+ -- type B is new A with private;
+ -- type C is new A with private;
+ -- private
+ -- type B is new C with null record;
+ -- type C is new B with null record;
+ -- end P;
+
+ and then Etype (Typ) /= Tagged_Type
+ then
+ Collect (Etype (Typ));
+ end if;
+
+ -- Collect the components containing tags of secondary dispatch
+ -- tables.
+
+ Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
+ while Present (Tag_Comp) loop
+ pragma Assert (Present (Related_Interface (Tag_Comp)));
+ Append_Elmt (Tag_Comp, Components_List);
+
+ Tag_Comp := Next_Tag_Component (Tag_Comp);
+ end loop;
+ end Collect;
+
+ -- Start of processing for Collect_Interface_Components
+
+ begin
+ pragma Assert (Ekind (Tagged_Type) = E_Record_Type
+ and then Is_Tagged_Type (Tagged_Type));
+
+ Components_List := New_Elmt_List;
+ Collect (Tagged_Type);
+ end Collect_Interface_Components;
+
+ ----------------------------------
-- Collect_Primitive_Operations --
----------------------------------
raise Program_Error;
end Find_Corresponding_Discriminant;
+ --------------------------------------------
+ -- Find_Overridden_Synchronized_Primitive --
+ --------------------------------------------
+
+ function Find_Overridden_Synchronized_Primitive
+ (Def_Id : Entity_Id;
+ First_Hom : Entity_Id;
+ Ifaces_List : Elist_Id;
+ In_Scope : Boolean := True) return Entity_Id
+ is
+ Candidate : Entity_Id := Empty;
+ Hom : Entity_Id := Empty;
+ Iface_Typ : Entity_Id;
+ Subp : Entity_Id := Empty;
+ Tag_Typ : Entity_Id;
+
+ function Find_Parameter_Type (Param : Node_Id) return Entity_Id;
+ -- Return the type of a formal parameter as determined by its
+ -- specification.
+
+ function Has_Correct_Formal_Mode (Subp : Entity_Id) return Boolean;
+ -- For an overridden subprogram Subp, check whether the mode of its
+ -- first parameter is correct depending on the kind of Tag_Typ.
+
+ function Matches_Prefixed_View_Profile
+ (Prim_Params : List_Id;
+ Iface_Params : List_Id) return Boolean;
+ -- Determine whether a subprogram's parameter profile Prim_Params
+ -- matches that of a potentially overriden interface subprogram
+ -- Iface_Params. Also determine if the type of first parameter of
+ -- Iface_Params is an implemented interface.
+
+ -------------------------
+ -- Find_Parameter_Type --
+ -------------------------
+
+ function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
+ begin
+ pragma Assert (Nkind (Param) = N_Parameter_Specification);
+
+ if Nkind (Parameter_Type (Param)) = N_Access_Definition then
+ return Etype (Subtype_Mark (Parameter_Type (Param)));
+
+ else
+ return Etype (Parameter_Type (Param));
+ end if;
+ end Find_Parameter_Type;
+
+ -----------------------------
+ -- Has_Correct_Formal_Mode --
+ -----------------------------
+
+ function Has_Correct_Formal_Mode (Subp : Entity_Id) return Boolean is
+ Param : Node_Id;
+
+ begin
+ Param := First_Formal (Subp);
+
+ -- In order for an entry or a protected procedure to override, the
+ -- first parameter of the overridden routine must be of mode "out",
+ -- "in out" or access-to-variable.
+
+ if (Ekind (Subp) = E_Entry
+ or else Ekind (Subp) = E_Procedure)
+ and then Is_Protected_Type (Tag_Typ)
+ and then Ekind (Param) /= E_In_Out_Parameter
+ and then Ekind (Param) /= E_Out_Parameter
+ and then Nkind (Parameter_Type (Parent (Param))) /=
+ N_Access_Definition
+ then
+ return False;
+ end if;
+
+ -- All other cases are OK since a task entry or routine does not
+ -- have a restriction on the mode of the first parameter of the
+ -- overridden interface routine.
+
+ return True;
+ end Has_Correct_Formal_Mode;
+
+ -----------------------------------
+ -- Matches_Prefixed_View_Profile --
+ -----------------------------------
+
+ function Matches_Prefixed_View_Profile
+ (Prim_Params : List_Id;
+ Iface_Params : List_Id) return Boolean
+ is
+ Iface_Id : Entity_Id;
+ Iface_Param : Node_Id;
+ Iface_Typ : Entity_Id;
+ Prim_Id : Entity_Id;
+ Prim_Param : Node_Id;
+ Prim_Typ : Entity_Id;
+
+ function Is_Implemented (Iface : Entity_Id) return Boolean;
+ -- Determine if Iface is implemented by the current task or
+ -- protected type.
+
+ --------------------
+ -- Is_Implemented --
+ --------------------
+
+ function Is_Implemented (Iface : Entity_Id) return Boolean is
+ Iface_Elmt : Elmt_Id;
+
+ begin
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ if Node (Iface_Elmt) = Iface then
+ return True;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+
+ return False;
+ end Is_Implemented;
+
+ -- Start of processing for Matches_Prefixed_View_Profile
+
+ begin
+ Iface_Param := First (Iface_Params);
+ Iface_Typ := Find_Parameter_Type (Iface_Param);
+ Prim_Param := First (Prim_Params);
+
+ -- The first parameter of the potentially overriden subprogram
+ -- must be an interface implemented by Prim.
+
+ if not Is_Interface (Iface_Typ)
+ or else not Is_Implemented (Iface_Typ)
+ then
+ return False;
+ end if;
+
+ -- The checks on the object parameters are done, move onto the rest
+ -- of the parameters.
+
+ if not In_Scope then
+ Prim_Param := Next (Prim_Param);
+ end if;
+
+ Iface_Param := Next (Iface_Param);
+ while Present (Iface_Param) and then Present (Prim_Param) loop
+ Iface_Id := Defining_Identifier (Iface_Param);
+ Iface_Typ := Find_Parameter_Type (Iface_Param);
+ Prim_Id := Defining_Identifier (Prim_Param);
+ Prim_Typ := Find_Parameter_Type (Prim_Param);
+
+ -- Case of multiple interface types inside a parameter profile
+
+ -- (Obj_Param : in out Iface; ...; Param : Iface)
+
+ -- If the interface type is implemented, then the matching type
+ -- in the primitive should be the implementing record type.
+
+ if Ekind (Iface_Typ) = E_Record_Type
+ and then Is_Interface (Iface_Typ)
+ and then Is_Implemented (Iface_Typ)
+ then
+ if Prim_Typ /= Tag_Typ then
+ return False;
+ end if;
+
+ -- The two parameters must be both mode and subtype conformant
+
+ elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
+ or else
+ not Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
+ then
+ return False;
+ end if;
+
+ Next (Iface_Param);
+ Next (Prim_Param);
+ end loop;
+
+ -- One of the two lists contains more parameters than the other
+
+ if Present (Iface_Param) or else Present (Prim_Param) then
+ return False;
+ end if;
+
+ return True;
+ end Matches_Prefixed_View_Profile;
+
+ -- Start of processing for Find_Overridden_Synchronized_Primitive
+
+ begin
+ -- At this point the caller should have collected the interfaces
+ -- implemented by the synchronized type.
+
+ pragma Assert (Present (Ifaces_List));
+
+ -- Find the tagged type to which subprogram Def_Id is primitive. If the
+ -- subprogram was declared within a protected or a task type, the type
+ -- is the scope itself, otherwise it is the type of the first parameter.
+
+ if In_Scope then
+ Tag_Typ := Scope (Def_Id);
+
+ elsif Present (First_Formal (Def_Id)) then
+ Tag_Typ := Find_Parameter_Type (Parent (First_Formal (Def_Id)));
+
+ -- A parameterless subprogram which is declared outside a synchronized
+ -- type cannot act as a primitive, thus it cannot override anything.
+
+ else
+ return Empty;
+ end if;
+
+ -- Traverse the homonym chain, looking at a potentially overriden
+ -- subprogram that belongs to an implemented interface.
+
+ Hom := First_Hom;
+ while Present (Hom) loop
+ Subp := Hom;
+
+ -- Entries can override abstract or null interface procedures
+
+ if Ekind (Def_Id) = E_Entry
+ and then Ekind (Subp) = E_Procedure
+ and then Nkind (Parent (Subp)) = N_Procedure_Specification
+ and then (Is_Abstract_Subprogram (Subp)
+ or else Null_Present (Parent (Subp)))
+ then
+ while Present (Alias (Subp)) loop
+ Subp := Alias (Subp);
+ end loop;
+
+ if Matches_Prefixed_View_Profile
+ (Parameter_Specifications (Parent (Def_Id)),
+ Parameter_Specifications (Parent (Subp)))
+ then
+ Candidate := Subp;
+
+ -- Absolute match
+
+ if Has_Correct_Formal_Mode (Candidate) then
+ return Candidate;
+ end if;
+ end if;
+
+ -- Procedures can override abstract or null interface procedures
+
+ elsif Ekind (Def_Id) = E_Procedure
+ and then Ekind (Subp) = E_Procedure
+ and then Nkind (Parent (Subp)) = N_Procedure_Specification
+ and then (Is_Abstract_Subprogram (Subp)
+ or else Null_Present (Parent (Subp)))
+ and then Matches_Prefixed_View_Profile
+ (Parameter_Specifications (Parent (Def_Id)),
+ Parameter_Specifications (Parent (Subp)))
+ then
+ Candidate := Subp;
+
+ -- Absolute match
+
+ if Has_Correct_Formal_Mode (Candidate) then
+ return Candidate;
+ end if;
+
+ -- Functions can override abstract interface functions
+
+ elsif Ekind (Def_Id) = E_Function
+ and then Ekind (Subp) = E_Function
+ and then Nkind (Parent (Subp)) = N_Function_Specification
+ and then Is_Abstract_Subprogram (Subp)
+ and then Matches_Prefixed_View_Profile
+ (Parameter_Specifications (Parent (Def_Id)),
+ Parameter_Specifications (Parent (Subp)))
+ and then Etype (Result_Definition (Parent (Def_Id))) =
+ Etype (Result_Definition (Parent (Subp)))
+ then
+ return Subp;
+ end if;
+
+ Hom := Homonym (Hom);
+ end loop;
+
+ -- After examining all candidates for overriding, we are left with
+ -- the best match which is a mode incompatible interface routine.
+ -- Do not emit an error of the Expander is active since this error
+ -- will be detected later on after all concurrent types are expanded
+ -- and all wrappers are built. This check is meant for spec-only
+ -- compilations.
+
+ if Present (Candidate)
+ and then not Expander_Active
+ then
+ Iface_Typ := Find_Parameter_Type (Parent (First_Formal (Candidate)));
+
+ -- Def_Id is primitive of a protected type, the candidate is
+ -- primitive of a limited or synchronized interface.
+
+ if Is_Protected_Type (Tag_Typ)
+ and then
+ (Is_Limited_Interface (Iface_Typ)
+ or else Is_Protected_Interface (Iface_Typ)
+ or else Is_Synchronized_Interface (Iface_Typ)
+ or else Is_Task_Interface (Iface_Typ))
+ then
+ Error_Msg_NE
+ ("first formal of & must be of mode `OUT`, `IN OUT` or " &
+ "access-to-variable", Tag_Typ, Candidate);
+
+ Error_Msg_N
+ ("\to be overridden by protected procedure or entry " &
+ "(`R`M 9.4(11))", Tag_Typ);
+ end if;
+ end if;
+
+ return Candidate;
+ end Find_Overridden_Synchronized_Primitive;
+
-----------------------------
-- Find_Static_Alternative --
-----------------------------
end Get_Name_Entity_Id;
---------------------------
- -- Get_Subprogram_Entity --
- ---------------------------
-
- function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
- Nam : Node_Id;
- Proc : Entity_Id;
-
- begin
- if Nkind (Nod) = N_Accept_Statement then
- Nam := Entry_Direct_Name (Nod);
-
- -- For an entry call, the prefix of the call is a selected component.
- -- Need additional code for internal calls ???
-
- elsif Nkind (Nod) = N_Entry_Call_Statement then
- if Nkind (Name (Nod)) = N_Selected_Component then
- Nam := Entity (Selector_Name (Name (Nod)));
- else
- Nam := Empty;
- end if;
-
- else
- Nam := Name (Nod);
- end if;
-
- if Nkind (Nam) = N_Explicit_Dereference then
- Proc := Etype (Prefix (Nam));
- elsif Is_Entity_Name (Nam) then
- Proc := Entity (Nam);
- else
- return Empty;
- end if;
-
- if Is_Object (Proc) then
- Proc := Etype (Proc);
- end if;
-
- if Ekind (Proc) = E_Access_Subprogram_Type then
- Proc := Directly_Designated_Type (Proc);
- end if;
-
- if not Is_Subprogram (Proc)
- and then Ekind (Proc) /= E_Subprogram_Type
- then
- return Empty;
- else
- return Proc;
- end if;
- end Get_Subprogram_Entity;
-
- ---------------------------
-- Get_Referenced_Object --
---------------------------
return R;
end Get_Referenced_Object;
+ ------------------------
+ -- Get_Renamed_Entity --
+ ------------------------
+
+ function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
+ R : Entity_Id;
+
+ begin
+ R := E;
+ while Present (Renamed_Entity (R)) loop
+ R := Renamed_Entity (R);
+ end loop;
+
+ return R;
+ end Get_Renamed_Entity;
+
-------------------------
-- Get_Subprogram_Body --
-------------------------
else -- Nkind (Decl) = N_Subprogram_Declaration
- if Present (Corresponding_Body (Decl)) then
- return Unit_Declaration_Node (Corresponding_Body (Decl));
+ if Present (Corresponding_Body (Decl)) then
+ return Unit_Declaration_Node (Corresponding_Body (Decl));
+
+ -- Imported subprogram case
+
+ else
+ return Empty;
+ end if;
+ end if;
+ end Get_Subprogram_Body;
+
+ ---------------------------
+ -- Get_Subprogram_Entity --
+ ---------------------------
+
+ function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
+ Nam : Node_Id;
+ Proc : Entity_Id;
+
+ begin
+ if Nkind (Nod) = N_Accept_Statement then
+ Nam := Entry_Direct_Name (Nod);
+
+ -- For an entry call, the prefix of the call is a selected component.
+ -- Need additional code for internal calls ???
+
+ elsif Nkind (Nod) = N_Entry_Call_Statement then
+ if Nkind (Name (Nod)) = N_Selected_Component then
+ Nam := Entity (Selector_Name (Name (Nod)));
+ else
+ Nam := Empty;
+ end if;
+
+ else
+ Nam := Name (Nod);
+ end if;
+
+ if Nkind (Nam) = N_Explicit_Dereference then
+ Proc := Etype (Prefix (Nam));
+ elsif Is_Entity_Name (Nam) then
+ Proc := Entity (Nam);
+ else
+ return Empty;
+ end if;
+
+ if Is_Object (Proc) then
+ Proc := Etype (Proc);
+ end if;
- -- Imported subprogram case
+ if Ekind (Proc) = E_Access_Subprogram_Type then
+ Proc := Directly_Designated_Type (Proc);
+ end if;
- else
- return Empty;
- end if;
+ if not Is_Subprogram (Proc)
+ and then Ekind (Proc) /= E_Subprogram_Type
+ then
+ return Empty;
+ else
+ return Proc;
end if;
- end Get_Subprogram_Body;
+ end Get_Subprogram_Entity;
-----------------------------
-- Get_Task_Body_Procedure --
-- Start of processing for Has_Preelaborable_Initialization
begin
- -- Immediate return if already marked as known preelaborable init
+ -- Immediate return if already marked as known preelaborable init. This
+ -- covers types for which this function has already been called once
+ -- and returned True (in which case the result is cached), and also
+ -- types to which a pragma Preelaborable_Initialization applies.
if Known_To_Have_Preelab_Init (E) then
return True;
end if;
+ -- Other private types never have preelaborable initialization
+
+ if Is_Private_Type (E) then
+ return False;
+ end if;
+
+ -- Here for all non-private view
+
-- All elementary types have preelaborable initialization
if Is_Elementary_Type (E) then
elsif Is_Array_Type (E) then
Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
- -- Record types have PI if all components have PI
+ -- A derived type has preelaborable initialization if its parent type
+ -- has preelaborable initialization and (in the case of a derived record
+ -- extension) if the non-inherited components all have preelaborable
+ -- initialization. However, a user-defined controlled type with an
+ -- overriding Initialize procedure does not have preelaborable
+ -- initialization.
- elsif Is_Record_Type (E) then
- Has_PE := True;
- Check_Components (First_Entity (E));
+ elsif Is_Derived_Type (E) then
+
+ -- First check whether ancestor type has preelaborable initialization
+
+ Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
+
+ -- If OK, check extension components (if any)
+
+ if Has_PE and then Is_Record_Type (E) then
+ Check_Components (First_Entity (E));
+ end if;
- -- Another check here, if this is a controlled type, see if it has a
- -- user defined Initialize procedure. If so, then there is a special
- -- rule that means this type does not have PI.
+ -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
+ -- with a user defined Initialize procedure does not have PI.
- if Is_Controlled (E)
+ if Has_PE
+ and then Is_Controlled (E)
and then Present (Primitive_Operations (E))
then
declare
end;
end if;
- -- Protected types, must not have entries, and components must meet
+ -- Record type has PI if it is non private and all components have PI
+
+ elsif Is_Record_Type (E) then
+ Has_PE := True;
+ Check_Components (First_Entity (E));
+
+ -- Protected types must not have entries, and components must meet
-- same set of rules as for record components.
elsif Is_Protected_Type (E) then
Check_Components (First_Private_Entity (E));
end if;
- -- A derived type has preelaborable initialization if its parent type
- -- has preelaborable initialization and (in the case of a derived record
- -- extension) if the non-inherited components all have preelaborable
- -- initialization. However, a user-defined controlled type with an
- -- overriding Initialize procedure does not have preelaborable
- -- initialization.
-
- -- TBD ???
-
-- Type System.Address always has preelaborable initialization
elsif Is_RTE (E, RE_Address) then
Has_PE := True;
- -- In all other cases, type does not have preelaborable init
+ -- In all other cases, type does not have preelaborable initialization
else
return False;
end if;
+ -- If type has preelaborable initialization, cache result
+
if Has_PE then
Set_Known_To_Have_Preelab_Init (E);
end if;
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_Coextension (N)
+ and then not Is_Static_Coextension (N);
+ end Is_Coextension_Root;
+
--------------------------------------
-- Is_Controlling_Limited_Procedure --
--------------------------------------
return (U /= 0);
end Is_True;
+ -------------------
+ -- Is_Value_Type --
+ -------------------
+
+ function Is_Value_Type (T : Entity_Id) return Boolean is
+ begin
+ return VM_Target = CLI_Target
+ and then Chars (T) /= No_Name
+ and then Get_Name_String (Chars (T)) = "valuetype";
+ end Is_Value_Type;
+
-----------------
-- Is_Variable --
-----------------
elsif Nkind (N) = N_Explicit_Dereference
and then Nkind (Orig_Node) /= N_Explicit_Dereference
+ and then Present (Etype (Orig_Node))
and then Is_Access_Type (Etype (Orig_Node))
then
return Is_Variable_Prefix (Original_Node (Prefix (N)));
-- Test prefix of component or attribute
- when N_Attribute_Reference |
- N_Expanded_Name |
+ when N_Attribute_Reference =>
+ return N = Prefix (P)
+ and then Name_Modifies_Prefix (Attribute_Name (P));
+
+ when N_Expanded_Name |
N_Explicit_Dereference |
N_Indexed_Component |
N_Reference |
N_Slice =>
return N = Prefix (P);
- -- Function call arguments are never lvalues
+ -- Function call arguments are never lvalues
when N_Function_Call =>
return False;
-- Positional parameter for procedure, entry, or accept call
when N_Procedure_Call_Statement |
- N_Entry_Call_Statement |
+ N_Entry_Call_Statement |
N_Accept_Statement
- =>
+ =>
declare
Proc : Entity_Id;
Form : Entity_Id;
end case;
end May_Be_Lvalue;
+ ------------------------------
+ -- Mark_Static_Coextensions --
+ ------------------------------
+
+ procedure Mark_Static_Coextensions (Root_Node : Node_Id) is
+ function Mark_Allocator (N : Node_Id) return Traverse_Result;
+ -- Recognize an allocator node and label it as a static coextension
+
+ --------------------
+ -- Mark_Allocator --
+ --------------------
+
+ function Mark_Allocator (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Allocator then
+ Set_Is_Static_Coextension (N);
+ end if;
+
+ return OK;
+ end Mark_Allocator;
+
+ procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
+
+ -- Start of processing for Mark_Static_Coextensions
+
+ begin
+ -- Do not mark allocators that stem from an initial allocator because
+ -- these will never be static.
+
+ if Nkind (Root_Node) /= N_Allocator then
+ Mark_Allocators (Root_Node);
+ end if;
+ end Mark_Static_Coextensions;
+
----------------------
-- Needs_One_Actual --
----------------------
if Modification_Comes_From_Source then
Generate_Reference (Ent, Exp, 'm');
end if;
+
+ Check_Nested_Access (Ent);
end if;
Kill_Checks (Ent);
end if;
end Object_Access_Level;
- --------------------------------------
- -- Overrides_Synchronized_Primitive --
- --------------------------------------
-
- function Overrides_Synchronized_Primitive
- (Def_Id : Entity_Id;
- First_Hom : Entity_Id;
- Ifaces_List : Elist_Id;
- In_Scope : Boolean := True) return Entity_Id
- is
- Candidate : Entity_Id;
- Hom : Entity_Id;
-
- function Matches_Prefixed_View_Profile
- (Subp_Params : List_Id;
- Over_Params : List_Id) return Boolean;
- -- Determine if a subprogram parameter profile (Subp_Params)
- -- matches that of a potentially overriden subprogram (Over_Params).
- -- Determine if the type of first parameter in the list Over_Params
- -- is an implemented interface, that is to say, the interface is in
- -- Ifaces_List.
-
- -----------------------------------
- -- Matches_Prefixed_View_Profile --
- -----------------------------------
-
- function Matches_Prefixed_View_Profile
- (Subp_Params : List_Id;
- Over_Params : List_Id) return Boolean
- is
- Subp_Param : Node_Id;
- Over_Param : Node_Id;
- Over_Param_Typ : Entity_Id;
-
- function Is_Implemented (Iface : Entity_Id) return Boolean;
- -- Determine if Iface is implemented by the current task or
- -- protected type.
-
- --------------------
- -- Is_Implemented --
- --------------------
-
- function Is_Implemented (Iface : Entity_Id) return Boolean is
- Iface_Elmt : Elmt_Id;
-
- begin
- Iface_Elmt := First_Elmt (Ifaces_List);
- while Present (Iface_Elmt) loop
- if Node (Iface_Elmt) = Iface then
- return True;
- end if;
-
- Next_Elmt (Iface_Elmt);
- end loop;
-
- return False;
- end Is_Implemented;
-
- -- Start of processing for Matches_Prefixed_View_Profile
-
- begin
- Subp_Param := First (Subp_Params);
- Over_Param := First (Over_Params);
-
- if Nkind (Parameter_Type (Over_Param)) = N_Access_Definition then
- Over_Param_Typ :=
- Etype (Subtype_Mark (Parameter_Type (Over_Param)));
- else
- Over_Param_Typ := Etype (Parameter_Type (Over_Param));
- end if;
-
- -- The first parameter of the potentially overriden subprogram
- -- must be an interface implemented by Def_Id.
-
- if not Is_Interface (Over_Param_Typ)
- or else not Is_Implemented (Over_Param_Typ)
- then
- return False;
- end if;
-
- -- This may be a primitive declared after a task or protected type.
- -- We need to skip the first parameter since it is irrelevant.
-
- if not In_Scope then
- Subp_Param := Next (Subp_Param);
- end if;
- Over_Param := Next (Over_Param);
-
- while Present (Subp_Param) and then Present (Over_Param) loop
-
- -- The two parameters must be mode conformant and both types
- -- must be the same.
-
- if Ekind (Defining_Identifier (Subp_Param)) /=
- Ekind (Defining_Identifier (Over_Param))
- or else
- not Conforming_Types
- (Etype (Parameter_Type (Subp_Param)),
- Etype (Parameter_Type (Over_Param)),
- Subtype_Conformant)
- then
- return False;
- end if;
-
- Next (Subp_Param);
- Next (Over_Param);
- end loop;
-
- -- One of the two lists contains more parameters than the other
-
- if Present (Subp_Param) or else Present (Over_Param) then
- return False;
- end if;
-
- return True;
- end Matches_Prefixed_View_Profile;
-
- -- Start of processing for Overrides_Synchronized_Primitive
-
- begin
- -- At this point the caller should have collected the interfaces
- -- implemented by the synchronized type.
-
- pragma Assert (Present (Ifaces_List));
-
- -- Traverse the homonym chain, looking at a potentially overriden
- -- subprogram that belongs to an implemented interface.
-
- Hom := First_Hom;
- while Present (Hom) loop
- Candidate := Hom;
-
- -- Entries can override abstract or null interface procedures
-
- if Ekind (Def_Id) = E_Entry
- and then Ekind (Candidate) = E_Procedure
- and then Nkind (Parent (Candidate)) = N_Procedure_Specification
- and then (Is_Abstract_Subprogram (Candidate)
- or else Null_Present (Parent (Candidate)))
- then
- while Present (Alias (Candidate)) loop
- Candidate := Alias (Candidate);
- end loop;
-
- if Matches_Prefixed_View_Profile
- (Parameter_Specifications (Parent (Def_Id)),
- Parameter_Specifications (Parent (Candidate)))
- then
- return Candidate;
- end if;
-
- -- Procedure can override abstract or null interface procedures
-
- elsif Ekind (Def_Id) = E_Procedure
- and then Ekind (Candidate) = E_Procedure
- and then Nkind (Parent (Candidate)) = N_Procedure_Specification
- and then (Is_Abstract_Subprogram (Candidate)
- or else Null_Present (Parent (Candidate)))
- and then Matches_Prefixed_View_Profile
- (Parameter_Specifications (Parent (Def_Id)),
- Parameter_Specifications (Parent (Candidate)))
- then
- return Candidate;
-
- -- Function can override abstract interface functions
-
- elsif Ekind (Def_Id) = E_Function
- and then Ekind (Candidate) = E_Function
- and then Nkind (Parent (Candidate)) = N_Function_Specification
- and then Is_Abstract_Subprogram (Candidate)
- and then Matches_Prefixed_View_Profile
- (Parameter_Specifications (Parent (Def_Id)),
- Parameter_Specifications (Parent (Candidate)))
- and then Etype (Result_Definition (Parent (Def_Id))) =
- Etype (Result_Definition (Parent (Candidate)))
- then
- return Candidate;
- end if;
-
- Hom := Homonym (Hom);
- end loop;
-
- return Empty;
- end Overrides_Synchronized_Primitive;
-
-----------------------
-- Private_Component --
-----------------------
elsif Is_Tagged_Type (Typ)
or else Has_Controlled_Component (Typ)
then
- return True;
+ return not Is_Value_Type (Typ);
-- Record type
elsif Is_Record_Type (Typ) then
+ declare
+ Comp : Entity_Id;
+ begin
+ Comp := First_Entity (Typ);
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component
+ and then Requires_Transient_Scope (Etype (Comp))
+ then
+ return True;
+ else
+ Next_Entity (Comp);
+ end if;
+ end loop;
+ end;
- -- In GCC 2, discriminated records always require a transient
- -- scope because the back end otherwise tries to allocate a
- -- variable length temporary for the particular variant.
-
- if Opt.GCC_Version = 2
- and then Has_Discriminants (Typ)
- then
- return True;
-
- -- For GCC 3, or for a non-discriminated record in GCC 2, we are
- -- OK if none of the component types requires a transient scope.
- -- Note that we already know that this is a definite type (i.e.
- -- has discriminant defaults if it is a discriminated record).
-
- else
- declare
- Comp : Entity_Id;
- begin
- Comp := First_Entity (Typ);
- while Present (Comp) loop
- if Ekind (Comp) = E_Component
- and then Requires_Transient_Scope (Etype (Comp))
- then
- return True;
- else
- Next_Entity (Comp);
- end if;
- end loop;
- end;
-
- return False;
- end if;
+ return False;
-- String literal types never require transient scope
-- Skip volatile and aliased variables, since funny things might
-- be going on in these cases which we cannot necessarily track.
- -- Also skip any variable for which an address clause is given.
+ -- Also skip any variable for which an address clause is given,
+ -- or whose address is taken
if Treat_As_Volatile (Ent)
or else Is_Aliased (Ent)
or else Present (Address_Clause (Ent))
+ or else Address_Taken (Ent)
then
return False;
end if;
Btyp : Entity_Id;
begin
- -- If the type is an anonymous access type we treat it as being
- -- declared at the library level to ensure that names such as
- -- X.all'access don't fail static accessibility checks.
-
- -- Ada 2005 (AI-230): In case of anonymous access types that are
- -- component_definition or discriminants of a nonlimited type,
- -- the level is the same as that of the enclosing component type.
-
Btyp := Base_Type (Typ);
+ -- Ada 2005 (AI-230): For most cases of anonymous access types, we
+ -- simply use the level where the type is declared. This is true for
+ -- stand-alone object declarations, and for anonymous access types
+ -- associated with components the level is the same as that of the
+ -- enclosing composite type. However, special treatment is needed for
+ -- the cases of access parameters, return objects of an anonymous access
+ -- type, and, in Ada 95, access discriminants of limited types.
+
if Ekind (Btyp) in Access_Kind then
- if Ekind (Btyp) = E_Anonymous_Access_Type
- and then not Is_Local_Anonymous_Access (Typ) -- Ada 2005 (AI-230)
- then
+ if Ekind (Btyp) = E_Anonymous_Access_Type then
+
+ -- If the type is a nonlocal anonymous access type (such as for
+ -- an access parameter) we treat it as being declared at the
+ -- library level to ensure that names such as X.all'access don't
+ -- fail static accessibility checks.
+
+ if not Is_Local_Anonymous_Access (Typ) then
+ return Scope_Depth (Standard_Standard);
- -- If this is a return_subtype, the accessibility level is that
- -- of the result subtype of the enclosing function.
+ -- If this is a return object, the accessibility level is that of
+ -- the result subtype of the enclosing function. The test here is
+ -- little complicated, because we have to account for extended
+ -- return statements that have been rewritten as blocks, in which
+ -- case we have to find and the Is_Return_Object attribute of the
+ -- itype's associated object. It would be nice to find a way to
+ -- simplify this test, but it doesn't seem worthwhile to add a new
+ -- flag just for purposes of this test. ???
- if Ekind (Scope (Btyp)) = E_Return_Statement then
+ elsif Ekind (Scope (Btyp)) = E_Return_Statement
+ or else
+ (Is_Itype (Btyp)
+ and then Nkind (Associated_Node_For_Itype (Btyp)) =
+ N_Object_Declaration
+ and then Is_Return_Object
+ (Defining_Identifier
+ (Associated_Node_For_Itype (Btyp))))
+ then
declare
Scop : Entity_Id;
+
begin
Scop := Scope (Scope (Btyp));
while Present (Scop) loop
Scop := Scope (Scop);
end loop;
- return Scope_Depth (Scope (Scop));
- end;
+ -- Treat the return object's type as having the level of the
+ -- function's result subtype (as per RM05-6.5(5.3/2)).
- else
- return Scope_Depth (Standard_Standard);
+ return Type_Access_Level (Etype (Scop));
+ end;
end if;
end if;
-- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
-- AI-402: access discriminants have accessibility based on the
- -- object rather than the type in Ada2005, so the above
- -- paragraph doesn't apply
+ -- object rather than the type in Ada 2005, so the above paragraph
+ -- doesn't apply.
-- ??? Needs completion with rules from AI-416
OSDN Git Service
