end if;
end Check_Stream_Attributes;
- -----------------------------
- -- Expand_Record_Extension --
- -----------------------------
+ ----------------------
+ -- Clean_Task_Names --
+ ----------------------
- -- Add a field _parent at the beginning of the record extension. This is
- -- used to implement inheritance. Here are some examples of expansion:
+ procedure Clean_Task_Names
+ (Typ : Entity_Id;
+ Proc_Id : Entity_Id)
+ is
+ begin
+ if Has_Task (Typ)
+ and then not Restriction_Active (No_Implicit_Heap_Allocations)
+ and then not Global_Discard_Names
+ and then Tagged_Type_Expansion
+ then
+ Set_Uses_Sec_Stack (Proc_Id);
+ end if;
+ end Clean_Task_Names;
- -- 1. no discriminants
- -- type T2 is new T1 with null record;
- -- gives
- -- type T2 is new T1 with record
- -- _Parent : T1;
- -- end record;
+ ------------------------------
+ -- Expand_Freeze_Array_Type --
+ ------------------------------
- -- 2. renamed discriminants
- -- type T2 (B, C : Int) is new T1 (A => B) with record
- -- _Parent : T1 (A => B);
- -- D : Int;
- -- end;
+ procedure Expand_Freeze_Array_Type (N : Node_Id) is
+ Typ : constant Entity_Id := Entity (N);
+ Base : constant Entity_Id := Base_Type (Typ);
+ Comp_Typ : constant Entity_Id := Component_Type (Typ);
- -- 3. inherited discriminants
- -- type T2 is new T1 with record -- discriminant A inherited
- -- _Parent : T1 (A);
- -- D : Int;
- -- end;
+ Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
- procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
- Indic : constant Node_Id := Subtype_Indication (Def);
- Loc : constant Source_Ptr := Sloc (Def);
- Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
- Par_Subtype : Entity_Id;
- Comp_List : Node_Id;
- Comp_Decl : Node_Id;
- Parent_N : Node_Id;
- D : Entity_Id;
- List_Constr : constant List_Id := New_List;
+ Ins_Node : Node_Id;
begin
- -- Expand_Record_Extension is called directly from the semantics, so
- -- we must check to see whether expansion is active before proceeding,
- -- because this affects the visibility of selected components in bodies
- -- of instances.
+ -- Ensure that all freezing activities are properly flagged as Ghost
- if not Expander_Active then
- return;
- end if;
+ Set_Ghost_Mode_From_Entity (Typ);
- -- This may be a derivation of an untagged private type whose full
- -- view is tagged, in which case the Derived_Type_Definition has no
- -- extension part. Build an empty one now.
+ if not Is_Bit_Packed_Array (Typ) then
- if No (Rec_Ext_Part) then
- Rec_Ext_Part :=
- Make_Record_Definition (Loc,
- End_Label => Empty,
- Component_List => Empty,
- Null_Present => True);
+ -- If the component contains tasks, so does the array type. This may
+ -- not be indicated in the array type because the component may have
+ -- been a private type at the point of definition. Same if component
+ -- type is controlled or contains protected objects.
- Set_Record_Extension_Part (Def, Rec_Ext_Part);
- Mark_Rewrite_Insertion (Rec_Ext_Part);
- end if;
+ Set_Has_Task (Base, Has_Task (Comp_Typ));
+ Set_Has_Protected (Base, Has_Protected (Comp_Typ));
+ Set_Has_Controlled_Component
+ (Base, Has_Controlled_Component
+ (Comp_Typ)
+ or else
+ Is_Controlled (Comp_Typ));
- Comp_List := Component_List (Rec_Ext_Part);
+ if No (Init_Proc (Base)) then
- Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
+ -- If this is an anonymous array created for a declaration with
+ -- an initial value, its init_proc will never be called. The
+ -- initial value itself may have been expanded into assignments,
+ -- in which case the object declaration is carries the
+ -- No_Initialization flag.
- -- If the derived type inherits its discriminants the type of the
- -- _parent field must be constrained by the inherited discriminants
+ if Is_Itype (Base)
+ and then Nkind (Associated_Node_For_Itype (Base)) =
+ N_Object_Declaration
+ and then
+ (Present (Expression (Associated_Node_For_Itype (Base)))
+ or else No_Initialization (Associated_Node_For_Itype (Base)))
+ then
+ null;
- if Has_Discriminants (T)
- and then Nkind (Indic) /= N_Subtype_Indication
- and then not Is_Constrained (Entity (Indic))
- then
- D := First_Discriminant (T);
- while Present (D) loop
- Append_To (List_Constr, New_Occurrence_Of (D, Loc));
- Next_Discriminant (D);
- end loop;
+ -- We do not need an init proc for string or wide [wide] string,
+ -- since the only time these need initialization in normalize or
+ -- initialize scalars mode, and these types are treated specially
+ -- and do not need initialization procedures.
- Par_Subtype :=
- Process_Subtype (
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => List_Constr)),
- Def);
+ elsif Is_Standard_String_Type (Base) then
+ null;
- -- Otherwise the original subtype_indication is just what is needed
+ -- Otherwise we have to build an init proc for the subtype
- else
- Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
- end if;
+ else
+ Build_Array_Init_Proc (Base, N);
+ end if;
+ end if;
- Set_Parent_Subtype (T, Par_Subtype);
+ if Typ = Base then
+ if Has_Controlled_Component (Base) then
+ Build_Controlling_Procs (Base);
- Comp_Decl :=
- Make_Component_Declaration (Loc,
- Defining_Identifier => Parent_N,
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc)));
+ if not Is_Limited_Type (Comp_Typ)
+ and then Number_Dimensions (Typ) = 1
+ then
+ Build_Slice_Assignment (Typ);
+ end if;
+ end if;
- if Null_Present (Rec_Ext_Part) then
- Set_Component_List (Rec_Ext_Part,
- Make_Component_List (Loc,
- Component_Items => New_List (Comp_Decl),
- Variant_Part => Empty,
- Null_Present => False));
- Set_Null_Present (Rec_Ext_Part, False);
+ -- Create a finalization master to service the anonymous access
+ -- components of the array.
- elsif Null_Present (Comp_List)
- or else Is_Empty_List (Component_Items (Comp_List))
- then
- Set_Component_Items (Comp_List, New_List (Comp_Decl));
- Set_Null_Present (Comp_List, False);
+ if Ekind (Comp_Typ) = E_Anonymous_Access_Type
+ and then Needs_Finalization (Designated_Type (Comp_Typ))
+ then
+ -- The finalization master is inserted before the declaration
+ -- of the array type. The only exception to this is when the
+ -- array type is an itype, in which case the master appears
+ -- before the related context.
- else
- Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
- end if;
+ if Is_Itype (Typ) then
+ Ins_Node := Associated_Node_For_Itype (Typ);
+ else
+ Ins_Node := Parent (Typ);
+ end if;
- Analyze (Comp_Decl);
- end Expand_Record_Extension;
+ Build_Finalization_Master
+ (Typ => Comp_Typ,
+ For_Anonymous => True,
+ Context_Scope => Scope (Typ),
+ Insertion_Node => Ins_Node);
+ end if;
+ end if;
- ------------------------------------
- -- Expand_N_Full_Type_Declaration --
- ------------------------------------
+ -- For packed case, default initialization, except if the component type
+ -- is itself a packed structure with an initialization procedure, or
+ -- initialize/normalize scalars active, and we have a base type, or the
+ -- type is public, because in that case a client might specify
+ -- Normalize_Scalars and there better be a public Init_Proc for it.
- procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
- procedure Build_Master (Ptr_Typ : Entity_Id);
- -- Create the master associated with Ptr_Typ
+ elsif (Present (Init_Proc (Component_Type (Base)))
+ and then No (Base_Init_Proc (Base)))
+ or else (Init_Or_Norm_Scalars and then Base = Typ)
+ or else Is_Public (Typ)
+ then
+ Build_Array_Init_Proc (Base, N);
+ end if;
- ------------------
- -- Build_Master --
- ------------------
+ if Has_Invariants (Component_Type (Base))
+ and then Typ = Base
+ and then In_Open_Scopes (Scope (Component_Type (Base)))
+ then
+ -- Generate component invariant checking procedure. This is only
+ -- relevant if the array type is within the scope of the component
+ -- type. Otherwise an array object can only be built using the public
+ -- subprograms for the component type, and calls to those will have
+ -- invariant checks. The invariant procedure is only generated for
+ -- a base type, not a subtype.
- procedure Build_Master (Ptr_Typ : Entity_Id) is
- Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ);
+ Insert_Component_Invariant_Checks
+ (N, Base, Build_Array_Invariant_Proc (Base, N));
+ end if;
- begin
- -- If the designated type is an incomplete view coming from a
- -- limited-with'ed package, we need to use the nonlimited view in
- -- case it has tasks.
+ Ghost_Mode := Save_Ghost_Mode;
+ end Expand_Freeze_Array_Type;
- if Ekind (Desig_Typ) in Incomplete_Kind
- and then Present (Non_Limited_View (Desig_Typ))
- then
- Desig_Typ := Non_Limited_View (Desig_Typ);
- end if;
+ -----------------------------------
+ -- Expand_Freeze_Class_Wide_Type --
+ -----------------------------------
- -- Anonymous access types are created for the components of the
- -- record parameter for an entry declaration. No master is created
- -- for such a type.
+ procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is
+ function Is_C_Derivation (Typ : Entity_Id) return Boolean;
+ -- Given a type, determine whether it is derived from a C or C++ root
- if Comes_From_Source (N) and then Has_Task (Desig_Typ) then
- Build_Master_Entity (Ptr_Typ);
- Build_Master_Renaming (Ptr_Typ);
+ ---------------------
+ -- Is_C_Derivation --
+ ---------------------
- -- Create a class-wide master because a Master_Id must be generated
- -- for access-to-limited-class-wide types whose root may be extended
- -- with task components.
+ function Is_C_Derivation (Typ : Entity_Id) return Boolean is
+ T : Entity_Id;
- -- Note: This code covers access-to-limited-interfaces because they
- -- can be used to reference tasks implementing them.
+ begin
+ T := Typ;
+ loop
+ if Is_CPP_Class (T)
+ or else Convention (T) = Convention_C
+ or else Convention (T) = Convention_CPP
+ then
+ return True;
+ end if;
- elsif Is_Limited_Class_Wide_Type (Desig_Typ)
- and then Tasking_Allowed
- then
- Build_Class_Wide_Master (Ptr_Typ);
- end if;
- end Build_Master;
+ exit when T = Etype (T);
- -- Local declarations
+ T := Etype (T);
+ end loop;
- Def_Id : constant Entity_Id := Defining_Identifier (N);
- B_Id : constant Entity_Id := Base_Type (Def_Id);
- FN : Node_Id;
- Par_Id : Entity_Id;
+ return False;
+ end Is_C_Derivation;
- -- Start of processing for Expand_N_Full_Type_Declaration
+ -- Local variables
- begin
- if Is_Access_Type (Def_Id) then
- Build_Master (Def_Id);
+ Typ : constant Entity_Id := Entity (N);
+ Root : constant Entity_Id := Root_Type (Typ);
- if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
- Expand_Access_Protected_Subprogram_Type (N);
- end if;
+ Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
- -- Array of anonymous access-to-task pointers
+ -- Start of processing for Expand_Freeze_Class_Wide_Type
- elsif Ada_Version >= Ada_2005
- and then Is_Array_Type (Def_Id)
- and then Is_Access_Type (Component_Type (Def_Id))
- and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
- then
- Build_Master (Component_Type (Def_Id));
+ begin
+ -- Certain run-time configurations and targets do not provide support
+ -- for controlled types.
- elsif Has_Task (Def_Id) then
- Expand_Previous_Access_Type (Def_Id);
+ if Restriction_Active (No_Finalization) then
+ return;
- -- Check the components of a record type or array of records for
- -- anonymous access-to-task pointers.
+ -- Do not create TSS routine Finalize_Address when dispatching calls are
+ -- disabled since the core of the routine is a dispatching call.
- elsif Ada_Version >= Ada_2005
- and then (Is_Record_Type (Def_Id)
- or else
- (Is_Array_Type (Def_Id)
- and then Is_Record_Type (Component_Type (Def_Id))))
- then
- declare
- Comp : Entity_Id;
- First : Boolean;
- M_Id : Entity_Id;
- Typ : Entity_Id;
+ elsif Restriction_Active (No_Dispatching_Calls) then
+ return;
- begin
- if Is_Array_Type (Def_Id) then
- Comp := First_Entity (Component_Type (Def_Id));
- else
- Comp := First_Entity (Def_Id);
- end if;
+ -- Do not create TSS routine Finalize_Address for concurrent class-wide
+ -- types. Ignore C, C++, CIL and Java types since it is assumed that the
+ -- non-Ada side will handle their destruction.
- -- Examine all components looking for anonymous access-to-task
- -- types.
+ elsif Is_Concurrent_Type (Root)
+ or else Is_C_Derivation (Root)
+ or else Convention (Typ) = Convention_CPP
+ then
+ return;
- First := True;
- while Present (Comp) loop
- Typ := Etype (Comp);
+ -- Do not create TSS routine Finalize_Address when compiling in CodePeer
+ -- mode since the routine contains an Unchecked_Conversion.
- if Ekind (Typ) = E_Anonymous_Access_Type
- and then Has_Task (Available_View (Designated_Type (Typ)))
- and then No (Master_Id (Typ))
- then
- -- Ensure that the record or array type have a _master
+ elsif CodePeer_Mode then
+ return;
+ end if;
- if First then
- Build_Master_Entity (Def_Id);
- Build_Master_Renaming (Typ);
- M_Id := Master_Id (Typ);
+ -- Ensure that all freezing activities are properly flagged as Ghost
- First := False;
+ Set_Ghost_Mode_From_Entity (Typ);
- -- Reuse the same master to service any additional types
+ -- Create the body of TSS primitive Finalize_Address. This automatically
+ -- sets the TSS entry for the class-wide type.
- else
- Set_Master_Id (Typ, M_Id);
- end if;
- end if;
+ Make_Finalize_Address_Body (Typ);
+ Ghost_Mode := Save_Ghost_Mode;
+ end Expand_Freeze_Class_Wide_Type;
- Next_Entity (Comp);
- end loop;
- end;
- end if;
+ ------------------------------------
+ -- Expand_Freeze_Enumeration_Type --
+ ------------------------------------
- Par_Id := Etype (B_Id);
+ procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is
+ Typ : constant Entity_Id := Entity (N);
+ Loc : constant Source_Ptr := Sloc (Typ);
- -- The parent type is private then we need to inherit any TSS operations
- -- from the full view.
+ Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
- if Ekind (Par_Id) in Private_Kind
- and then Present (Full_View (Par_Id))
- then
- Par_Id := Base_Type (Full_View (Par_Id));
- end if;
+ Arr : Entity_Id;
+ Ent : Entity_Id;
+ Fent : Entity_Id;
+ Is_Contiguous : Boolean;
+ Ityp : Entity_Id;
+ Last_Repval : Uint;
+ Lst : List_Id;
+ Num : Nat;
+ Pos_Expr : Node_Id;
- if Nkind (Type_Definition (Original_Node (N))) =
- N_Derived_Type_Definition
- and then not Is_Tagged_Type (Def_Id)
- and then Present (Freeze_Node (Par_Id))
- and then Present (TSS_Elist (Freeze_Node (Par_Id)))
- then
- Ensure_Freeze_Node (B_Id);
- FN := Freeze_Node (B_Id);
+ Func : Entity_Id;
+ pragma Warnings (Off, Func);
- if No (TSS_Elist (FN)) then
- Set_TSS_Elist (FN, New_Elmt_List);
- end if;
+ begin
+ -- Ensure that all freezing activities are properly flagged as Ghost
- declare
- T_E : constant Elist_Id := TSS_Elist (FN);
- Elmt : Elmt_Id;
+ Set_Ghost_Mode_From_Entity (Typ);
- begin
- Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
- while Present (Elmt) loop
- if Chars (Node (Elmt)) /= Name_uInit then
- Append_Elmt (Node (Elmt), T_E);
- end if;
+ -- Various optimizations possible if given representation is contiguous
- Next_Elmt (Elmt);
- end loop;
+ Is_Contiguous := True;
- -- If the derived type itself is private with a full view, then
- -- associate the full view with the inherited TSS_Elist as well.
+ Ent := First_Literal (Typ);
+ Last_Repval := Enumeration_Rep (Ent);
- if Ekind (B_Id) in Private_Kind
- and then Present (Full_View (B_Id))
- then
- Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
- Set_TSS_Elist
- (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
- end if;
- end;
- end if;
- end Expand_N_Full_Type_Declaration;
+ Next_Literal (Ent);
+ while Present (Ent) loop
+ if Enumeration_Rep (Ent) - Last_Repval /= 1 then
+ Is_Contiguous := False;
+ exit;
+ else
+ Last_Repval := Enumeration_Rep (Ent);
+ end if;
- ---------------------------------
- -- Expand_N_Object_Declaration --
- ---------------------------------
+ Next_Literal (Ent);
+ end loop;
- procedure Expand_N_Object_Declaration (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Def_Id : constant Entity_Id := Defining_Identifier (N);
- Expr : constant Node_Id := Expression (N);
- Obj_Def : constant Node_Id := Object_Definition (N);
- Typ : constant Entity_Id := Etype (Def_Id);
- Base_Typ : constant Entity_Id := Base_Type (Typ);
- Expr_Q : Node_Id;
+ if Is_Contiguous then
+ Set_Has_Contiguous_Rep (Typ);
+ Ent := First_Literal (Typ);
+ Num := 1;
+ Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent)));
- function Build_Equivalent_Aggregate return Boolean;
- -- If the object has a constrained discriminated type and no initial
- -- value, it may be possible to build an equivalent aggregate instead,
- -- and prevent an actual call to the initialization procedure.
+ else
+ -- Build list of literal references
- procedure Default_Initialize_Object (After : Node_Id);
- -- Generate all default initialization actions for object Def_Id. Any
- -- new code is inserted after node After.
+ Lst := New_List;
+ Num := 0;
- function Rewrite_As_Renaming return Boolean;
- -- Indicate whether to rewrite a declaration with initialization into an
- -- object renaming declaration (see below).
+ Ent := First_Literal (Typ);
+ while Present (Ent) loop
+ Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent)));
+ Num := Num + 1;
+ Next_Literal (Ent);
+ end loop;
+ end if;
- --------------------------------
- -- Build_Equivalent_Aggregate --
- --------------------------------
+ -- Now build an array declaration
- function Build_Equivalent_Aggregate return Boolean is
- Aggr : Node_Id;
- Comp : Entity_Id;
- Discr : Elmt_Id;
- Full_Type : Entity_Id;
+ -- typA : array (Natural range 0 .. num - 1) of ctype :=
+ -- (v, v, v, v, v, ....)
- begin
- Full_Type := Typ;
+ -- where ctype is the corresponding integer type. If the representation
+ -- is contiguous, we only keep the first literal, which provides the
+ -- offset for Pos_To_Rep computations.
- if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
- Full_Type := Full_View (Typ);
- end if;
+ Arr :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), 'A'));
- -- Only perform this transformation if Elaboration_Code is forbidden
- -- or undesirable, and if this is a global entity of a constrained
- -- record type.
-
- -- If Initialize_Scalars might be active this transformation cannot
- -- be performed either, because it will lead to different semantics
- -- or because elaboration code will in fact be created.
-
- if Ekind (Full_Type) /= E_Record_Subtype
- or else not Has_Discriminants (Full_Type)
- or else not Is_Constrained (Full_Type)
- or else Is_Controlled (Full_Type)
- or else Is_Limited_Type (Full_Type)
- or else not Restriction_Active (No_Initialize_Scalars)
- then
- return False;
- end if;
-
- if Ekind (Current_Scope) = E_Package
- and then
- (Restriction_Active (No_Elaboration_Code)
- or else Is_Preelaborated (Current_Scope))
- then
- -- Building a static aggregate is possible if the discriminants
- -- have static values and the other components have static
- -- defaults or none.
-
- Discr := First_Elmt (Discriminant_Constraint (Full_Type));
- while Present (Discr) loop
- if not Is_OK_Static_Expression (Node (Discr)) then
- return False;
- end if;
+ Append_Freeze_Action (Typ,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Arr,
+ Constant_Present => True,
- Next_Elmt (Discr);
- end loop;
+ Object_Definition =>
+ Make_Constrained_Array_Definition (Loc,
+ Discrete_Subtype_Definitions => New_List (
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
+ Constraint =>
+ Make_Range_Constraint (Loc,
+ Range_Expression =>
+ Make_Range (Loc,
+ Low_Bound =>
+ Make_Integer_Literal (Loc, 0),
+ High_Bound =>
+ Make_Integer_Literal (Loc, Num - 1))))),
- -- Check that initialized components are OK, and that non-
- -- initialized components do not require a call to their own
- -- initialization procedure.
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Occurrence_Of (Typ, Loc))),
- Comp := First_Component (Full_Type);
- while Present (Comp) loop
- if Ekind (Comp) = E_Component
- and then Present (Expression (Parent (Comp)))
- and then
- not Is_OK_Static_Expression (Expression (Parent (Comp)))
- then
- return False;
+ Expression =>
+ Make_Aggregate (Loc,
+ Expressions => Lst)));
- elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
- return False;
+ Set_Enum_Pos_To_Rep (Typ, Arr);
- end if;
+ -- Now we build the function that converts representation values to
+ -- position values. This function has the form:
- Next_Component (Comp);
- end loop;
+ -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
+ -- begin
+ -- case ityp!(A) is
+ -- when enum-lit'Enum_Rep => return posval;
+ -- when enum-lit'Enum_Rep => return posval;
+ -- ...
+ -- when others =>
+ -- [raise Constraint_Error when F "invalid data"]
+ -- return -1;
+ -- end case;
+ -- end;
- -- Everything is static, assemble the aggregate, discriminant
- -- values first.
+ -- Note: the F parameter determines whether the others case (no valid
+ -- representation) raises Constraint_Error or returns a unique value
+ -- of minus one. The latter case is used, e.g. in 'Valid code.
- Aggr :=
- Make_Aggregate (Loc,
- Expressions => New_List,
- Component_Associations => New_List);
+ -- Note: the reason we use Enum_Rep values in the case here is to avoid
+ -- the code generator making inappropriate assumptions about the range
+ -- of the values in the case where the value is invalid. ityp is a
+ -- signed or unsigned integer type of appropriate width.
- Discr := First_Elmt (Discriminant_Constraint (Full_Type));
- while Present (Discr) loop
- Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
- Next_Elmt (Discr);
- end loop;
+ -- Note: if exceptions are not supported, then we suppress the raise
+ -- and return -1 unconditionally (this is an erroneous program in any
+ -- case and there is no obligation to raise Constraint_Error here). We
+ -- also do this if pragma Restrictions (No_Exceptions) is active.
- -- Now collect values of initialized components
+ -- Is this right??? What about No_Exception_Propagation???
- Comp := First_Component (Full_Type);
- while Present (Comp) loop
- if Ekind (Comp) = E_Component
- and then Present (Expression (Parent (Comp)))
- then
- Append_To (Component_Associations (Aggr),
- Make_Component_Association (Loc,
- Choices => New_List (New_Occurrence_Of (Comp, Loc)),
- Expression => New_Copy_Tree
- (Expression (Parent (Comp)))));
- end if;
+ -- Representations are signed
- Next_Component (Comp);
- end loop;
+ if Enumeration_Rep (First_Literal (Typ)) < 0 then
- -- Finally, box-initialize remaining components
+ -- The underlying type is signed. Reset the Is_Unsigned_Type
+ -- explicitly, because it might have been inherited from
+ -- parent type.
- Append_To (Component_Associations (Aggr),
- Make_Component_Association (Loc,
- Choices => New_List (Make_Others_Choice (Loc)),
- Expression => Empty));
- Set_Box_Present (Last (Component_Associations (Aggr)));
- Set_Expression (N, Aggr);
+ Set_Is_Unsigned_Type (Typ, False);
- if Typ /= Full_Type then
- Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type)));
- Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
- Analyze_And_Resolve (Aggr, Typ);
- else
- Analyze_And_Resolve (Aggr, Full_Type);
- end if;
+ if Esize (Typ) <= Standard_Integer_Size then
+ Ityp := Standard_Integer;
+ else
+ Ityp := Universal_Integer;
+ end if;
- return True;
+ -- Representations are unsigned
+ else
+ if Esize (Typ) <= Standard_Integer_Size then
+ Ityp := RTE (RE_Unsigned);
else
- return False;
+ Ityp := RTE (RE_Long_Long_Unsigned);
end if;
- end Build_Equivalent_Aggregate;
-
- -------------------------------
- -- Default_Initialize_Object --
- -------------------------------
+ end if;
- procedure Default_Initialize_Object (After : Node_Id) is
- function New_Object_Reference return Node_Id;
- -- Return a new reference to Def_Id with attributes Assignment_OK and
- -- Must_Not_Freeze already set.
+ -- The body of the function is a case statement. First collect case
+ -- alternatives, or optimize the contiguous case.
- --------------------------
- -- New_Object_Reference --
- --------------------------
+ Lst := New_List;
- function New_Object_Reference return Node_Id is
- Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
+ -- If representation is contiguous, Pos is computed by subtracting
+ -- the representation of the first literal.
- begin
- -- The call to the type init proc or [Deep_]Finalize must not
- -- freeze the related object as the call is internally generated.
- -- This way legal rep clauses that apply to the object will not be
- -- flagged. Note that the initialization call may be removed if
- -- pragma Import is encountered or moved to the freeze actions of
- -- the object because of an address clause.
+ if Is_Contiguous then
+ Ent := First_Literal (Typ);
- Set_Assignment_OK (Obj_Ref);
- Set_Must_Not_Freeze (Obj_Ref);
+ if Enumeration_Rep (Ent) = Last_Repval then
- return Obj_Ref;
- end New_Object_Reference;
+ -- Another special case: for a single literal, Pos is zero
- -- Local variables
+ Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
- Abrt_Blk : Node_Id;
- Abrt_HSS : Node_Id;
- Abrt_Id : Entity_Id;
- Abrt_Stmts : List_Id;
- Aggr_Init : Node_Id;
- Comp_Init : List_Id := No_List;
- Fin_Call : Node_Id;
- Fin_Stmts : List_Id := No_List;
- Obj_Init : Node_Id := Empty;
- Obj_Ref : Node_Id;
+ else
+ Pos_Expr :=
+ Convert_To (Standard_Integer,
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To
+ (Ityp, Make_Identifier (Loc, Name_uA)),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Intval => Enumeration_Rep (First_Literal (Typ)))));
+ end if;
- Dummy : Entity_Id;
- -- This variable captures a dummy internal entity, see the comment
- -- associated with its use.
+ Append_To (Lst,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices => New_List (
+ Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
+ Low_Bound =>
+ Make_Integer_Literal (Loc,
+ Intval => Enumeration_Rep (Ent)),
+ High_Bound =>
+ Make_Integer_Literal (Loc, Intval => Last_Repval))),
- -- Start of processing for Default_Initialize_Object
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => Pos_Expr))));
- begin
- -- Default initialization is suppressed for objects that are already
- -- known to be imported (i.e. whose declaration specifies the Import
- -- aspect). Note that for objects with a pragma Import, we generate
- -- initialization here, and then remove it downstream when processing
- -- the pragma. It is also suppressed for variables for which a pragma
- -- Suppress_Initialization has been explicitly given
+ else
+ Ent := First_Literal (Typ);
+ while Present (Ent) loop
+ Append_To (Lst,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices => New_List (
+ Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
+ Intval => Enumeration_Rep (Ent))),
- if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then
- return;
- end if;
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Integer_Literal (Loc,
+ Intval => Enumeration_Pos (Ent))))));
- -- Step 1: Initialize the object
+ Next_Literal (Ent);
+ end loop;
+ end if;
- if Needs_Finalization (Typ) and then not No_Initialization (N) then
- Obj_Init :=
- Make_Init_Call
- (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
- Typ => Typ);
- end if;
+ -- In normal mode, add the others clause with the test
- -- Step 2: Initialize the components of the object
-
- -- Do not initialize the components if their initialization is
- -- prohibited.
+ if not No_Exception_Handlers_Set then
+ Append_To (Lst,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices => New_List (Make_Others_Choice (Loc)),
+ Statements => New_List (
+ Make_Raise_Constraint_Error (Loc,
+ Condition => Make_Identifier (Loc, Name_uF),
+ Reason => CE_Invalid_Data),
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Integer_Literal (Loc, -1)))));
- if Has_Non_Null_Base_Init_Proc (Typ)
- and then not No_Initialization (N)
- and then not Initialization_Suppressed (Typ)
- then
- -- Do not initialize the components if No_Default_Initialization
- -- applies as the actual restriction check will occur later
- -- when the object is frozen as it is not known yet whether the
- -- object is imported or not.
+ -- If either of the restrictions No_Exceptions_Handlers/Propagation is
+ -- active then return -1 (we cannot usefully raise Constraint_Error in
+ -- this case). See description above for further details.
- if not Restriction_Active (No_Default_Initialization) then
+ else
+ Append_To (Lst,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices => New_List (Make_Others_Choice (Loc)),
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Integer_Literal (Loc, -1)))));
+ end if;
- -- If the values of the components are compile-time known, use
- -- their prebuilt aggregate form directly.
+ -- Now we can build the function body
- Aggr_Init := Static_Initialization (Base_Init_Proc (Typ));
+ Fent :=
+ Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
- if Present (Aggr_Init) then
- Set_Expression
- (N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope));
+ Func :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Fent,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uA),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc)),
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uF),
+ Parameter_Type =>
+ New_Occurrence_Of (Standard_Boolean, Loc))),
- -- If type has discriminants, try to build an equivalent
- -- aggregate using discriminant values from the declaration.
- -- This is a useful optimization, in particular if restriction
- -- No_Elaboration_Code is active.
+ Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)),
- elsif Build_Equivalent_Aggregate then
- null;
+ Declarations => Empty_List,
- -- Otherwise invoke the type init proc
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Case_Statement (Loc,
+ Expression =>
+ Unchecked_Convert_To
+ (Ityp, Make_Identifier (Loc, Name_uA)),
+ Alternatives => Lst))));
- else
- Obj_Ref := New_Object_Reference;
+ Set_TSS (Typ, Fent);
- if Comes_From_Source (Def_Id) then
- Initialization_Warning (Obj_Ref);
- end if;
+ -- Set Pure flag (it will be reset if the current context is not Pure).
+ -- We also pretend there was a pragma Pure_Function so that for purposes
+ -- of optimization and constant-folding, we will consider the function
+ -- Pure even if we are not in a Pure context).
- Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ);
- end if;
- end if;
+ Set_Is_Pure (Fent);
+ Set_Has_Pragma_Pure_Function (Fent);
- -- Provide a default value if the object needs simple initialization
- -- and does not already have an initial value. A generated temporary
- -- does not require initialization because it will be assigned later.
+ -- Unless we are in -gnatD mode, where we are debugging generated code,
+ -- this is an internal entity for which we don't need debug info.
- elsif Needs_Simple_Initialization
- (Typ, Initialize_Scalars
- and then No (Following_Address_Clause (N)))
- and then not Is_Internal (Def_Id)
- and then not Has_Init_Expression (N)
- then
- Set_No_Initialization (N, False);
- Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
- Analyze_And_Resolve (Expression (N), Typ);
- end if;
+ if not Debug_Generated_Code then
+ Set_Debug_Info_Off (Fent);
+ end if;
- -- Step 3: Add partial finalization and abort actions, generate:
+ Ghost_Mode := Save_Ghost_Mode;
- -- Type_Init_Proc (Obj);
- -- begin
- -- Deep_Initialize (Obj);
- -- exception
- -- when others =>
- -- Deep_Finalize (Obj, Self => False);
- -- raise;
- -- end;
+ exception
+ when RE_Not_Available =>
+ Ghost_Mode := Save_Ghost_Mode;
+ return;
+ end Expand_Freeze_Enumeration_Type;
- -- Step 3a: Build the finalization block (if applicable)
+ -------------------------------
+ -- Expand_Freeze_Record_Type --
+ -------------------------------
- -- The finalization block is required when both the object and its
- -- controlled components are to be initialized. The block finalizes
- -- the components if the object initialization fails.
+ procedure Expand_Freeze_Record_Type (N : Node_Id) is
+ Typ : constant Node_Id := Entity (N);
+ Typ_Decl : constant Node_Id := Parent (Typ);
- if Has_Controlled_Component (Typ)
- and then Present (Comp_Init)
- and then Present (Obj_Init)
- and then not Restriction_Active (No_Exception_Propagation)
- then
- -- Generate:
- -- Type_Init_Proc (Obj);
+ Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
- Fin_Stmts := Comp_Init;
+ Comp : Entity_Id;
+ Comp_Typ : Entity_Id;
+ Has_AACC : Boolean;
+ Predef_List : List_Id;
- -- Generate:
- -- begin
- -- Deep_Initialize (Obj);
- -- exception
- -- when others =>
- -- Deep_Finalize (Obj, Self => False);
- -- raise;
- -- end;
+ Renamed_Eq : Node_Id := Empty;
+ -- Defining unit name for the predefined equality function in the case
+ -- where the type has a primitive operation that is a renaming of
+ -- predefined equality (but only if there is also an overriding
+ -- user-defined equality function). Used to pass this entity from
+ -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
- Fin_Call :=
- Make_Final_Call
- (Obj_Ref => New_Object_Reference,
- Typ => Typ,
- Skip_Self => True);
+ Wrapper_Decl_List : List_Id := No_List;
+ Wrapper_Body_List : List_Id := No_List;
- if Present (Fin_Call) then
+ -- Start of processing for Expand_Freeze_Record_Type
- -- Do not emit warnings related to the elaboration order when a
- -- controlled object is declared before the body of Finalize is
- -- seen.
+ begin
+ -- Ensure that all freezing activities are properly flagged as Ghost
- Set_No_Elaboration_Check (Fin_Call);
+ Set_Ghost_Mode_From_Entity (Typ);
- Append_To (Fin_Stmts,
- Make_Block_Statement (Loc,
- Declarations => No_List,
+ -- Build discriminant checking functions if not a derived type (for
+ -- derived types that are not tagged types, always use the discriminant
+ -- checking functions of the parent type). However, for untagged types
+ -- the derivation may have taken place before the parent was frozen, so
+ -- we copy explicitly the discriminant checking functions from the
+ -- parent into the components of the derived type.
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Obj_Init),
+ if not Is_Derived_Type (Typ)
+ or else Has_New_Non_Standard_Rep (Typ)
+ or else Is_Tagged_Type (Typ)
+ then
+ Build_Discr_Checking_Funcs (Typ_Decl);
- Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
- Exception_Choices => New_List (
- Make_Others_Choice (Loc)),
+ elsif Is_Derived_Type (Typ)
+ and then not Is_Tagged_Type (Typ)
- Statements => New_List (
- Fin_Call,
- Make_Raise_Statement (Loc)))))));
- end if;
+ -- If we have a derived Unchecked_Union, we do not inherit the
+ -- discriminant checking functions from the parent type since the
+ -- discriminants are non existent.
- -- Finalization is not required, the initialization calls are passed
- -- to the abort block building circuitry, generate:
+ and then not Is_Unchecked_Union (Typ)
+ and then Has_Discriminants (Typ)
+ then
+ declare
+ Old_Comp : Entity_Id;
- -- Type_Init_Proc (Obj);
- -- Deep_Initialize (Obj);
+ begin
+ Old_Comp :=
+ First_Component (Base_Type (Underlying_Type (Etype (Typ))));
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component
+ and then Chars (Comp) = Chars (Old_Comp)
+ then
+ Set_Discriminant_Checking_Func (Comp,
+ Discriminant_Checking_Func (Old_Comp));
+ end if;
- else
- if Present (Comp_Init) then
- Fin_Stmts := Comp_Init;
- end if;
+ Next_Component (Old_Comp);
+ Next_Component (Comp);
+ end loop;
+ end;
+ end if;
- if Present (Obj_Init) then
- if No (Fin_Stmts) then
- Fin_Stmts := New_List;
- end if;
+ if Is_Derived_Type (Typ)
+ and then Is_Limited_Type (Typ)
+ and then Is_Tagged_Type (Typ)
+ then
+ Check_Stream_Attributes (Typ);
+ end if;
- Append_To (Fin_Stmts, Obj_Init);
- end if;
- end if;
+ -- Update task, protected, and controlled component flags, because some
+ -- of the component types may have been private at the point of the
+ -- record declaration. Detect anonymous access-to-controlled components.
- -- Step 3b: Build the abort block (if applicable)
+ Has_AACC := False;
- -- The abort block is required when aborts are allowed in order to
- -- protect both initialization calls.
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ Comp_Typ := Etype (Comp);
- if Present (Comp_Init) and then Present (Obj_Init) then
- if Abort_Allowed then
+ if Has_Task (Comp_Typ) then
+ Set_Has_Task (Typ);
+ end if;
- -- Generate:
- -- Abort_Defer;
+ if Has_Protected (Comp_Typ) then
+ Set_Has_Protected (Typ);
+ end if;
- Prepend_To
- (Fin_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+ -- Do not set Has_Controlled_Component on a class-wide equivalent
+ -- type. See Make_CW_Equivalent_Type.
- -- Generate:
- -- begin
- -- Abort_Defer;
- -- <finalization statements>
- -- at end
- -- Abort_Undefer_Direct;
- -- end;
+ if not Is_Class_Wide_Equivalent_Type (Typ)
+ and then
+ (Has_Controlled_Component (Comp_Typ)
+ or else (Chars (Comp) /= Name_uParent
+ and then (Is_Controlled_Active (Comp_Typ))))
+ then
+ Set_Has_Controlled_Component (Typ);
+ end if;
- declare
- AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
+ -- Non-self-referential anonymous access-to-controlled component
- begin
- Abrt_HSS :=
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Fin_Stmts,
- At_End_Proc => New_Occurrence_Of (AUD, Loc));
+ if Ekind (Comp_Typ) = E_Anonymous_Access_Type
+ and then Needs_Finalization (Designated_Type (Comp_Typ))
+ and then Designated_Type (Comp_Typ) /= Typ
+ then
+ Has_AACC := True;
+ end if;
- -- Present the Abort_Undefer_Direct function to the backend
- -- so that it can inline the call to the function.
+ Next_Component (Comp);
+ end loop;
- Add_Inlined_Body (AUD, N);
- end;
+ -- Handle constructors of untagged CPP_Class types
- Abrt_Blk :=
- Make_Block_Statement (Loc,
- Declarations => No_List,
- Handled_Statement_Sequence => Abrt_HSS);
+ if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then
+ Set_CPP_Constructors (Typ);
+ end if;
- Add_Block_Identifier (Abrt_Blk, Abrt_Id);
- Expand_At_End_Handler (Abrt_HSS, Abrt_Id);
+ -- Creation of the Dispatch Table. Note that a Dispatch Table is built
+ -- for regular tagged types as well as for Ada types deriving from a C++
+ -- Class, but not for tagged types directly corresponding to C++ classes
+ -- In the later case we assume that it is created in the C++ side and we
+ -- just use it.
- Abrt_Stmts := New_List (Abrt_Blk);
+ if Is_Tagged_Type (Typ) then
- -- Abort is not required
+ -- Add the _Tag component
- else
- -- Generate a dummy entity to ensure that the internal symbols
- -- are in sync when a unit is compiled with and without aborts.
- -- The entity is a block with proper scope and type.
+ if Underlying_Type (Etype (Typ)) = Typ then
+ Expand_Tagged_Root (Typ);
+ end if;
- Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
- Set_Etype (Dummy, Standard_Void_Type);
- Abrt_Stmts := Fin_Stmts;
- end if;
+ if Is_CPP_Class (Typ) then
+ Set_All_DT_Position (Typ);
- -- No initialization calls present
+ -- Create the tag entities with a minimum decoration
- else
- Abrt_Stmts := Fin_Stmts;
- end if;
+ if Tagged_Type_Expansion then
+ Append_Freeze_Actions (Typ, Make_Tags (Typ));
+ end if;
- -- Step 4: Insert the whole initialization sequence into the tree
- -- If the object has a delayed freeze, as will be the case when
- -- it has aspect specifications, the initialization sequence is
- -- part of the freeze actions.
+ Set_CPP_Constructors (Typ);
- if Has_Delayed_Freeze (Def_Id) then
- Append_Freeze_Actions (Def_Id, Abrt_Stmts);
else
- Insert_Actions_After (After, Abrt_Stmts);
- end if;
- end Default_Initialize_Object;
+ if not Building_Static_DT (Typ) then
- -------------------------
- -- Rewrite_As_Renaming --
- -------------------------
-
- function Rewrite_As_Renaming return Boolean is
- begin
- return not Aliased_Present (N)
- and then Is_Entity_Name (Expr_Q)
- and then Ekind (Entity (Expr_Q)) = E_Variable
- and then OK_To_Rename (Entity (Expr_Q))
- and then Is_Entity_Name (Obj_Def);
- end Rewrite_As_Renaming;
+ -- Usually inherited primitives are not delayed but the first
+ -- Ada extension of a CPP_Class is an exception since the
+ -- address of the inherited subprogram has to be inserted in
+ -- the new Ada Dispatch Table and this is a freezing action.
- -- Local variables
+ -- Similarly, if this is an inherited operation whose parent is
+ -- not frozen yet, it is not in the DT of the parent, and we
+ -- generate an explicit freeze node for the inherited operation
+ -- so it is properly inserted in the DT of the current type.
- Next_N : constant Node_Id := Next (N);
- Id_Ref : Node_Id;
- Tag_Assign : Node_Id;
+ declare
+ Elmt : Elmt_Id;
+ Subp : Entity_Id;
- Init_After : Node_Id := N;
- -- Node after which the initialization actions are to be inserted. This
- -- is normally N, except for the case of a shared passive variable, in
- -- which case the init proc call must be inserted only after the bodies
- -- of the shared variable procedures have been seen.
+ begin
+ Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
- -- Start of processing for Expand_N_Object_Declaration
+ if Present (Alias (Subp)) then
+ if Is_CPP_Class (Etype (Typ)) then
+ Set_Has_Delayed_Freeze (Subp);
- begin
- -- Don't do anything for deferred constants. All proper actions will be
- -- expanded during the full declaration.
+ elsif Has_Delayed_Freeze (Alias (Subp))
+ and then not Is_Frozen (Alias (Subp))
+ then
+ Set_Is_Frozen (Subp, False);
+ Set_Has_Delayed_Freeze (Subp);
+ end if;
+ end if;
- if No (Expr) and Constant_Present (N) then
- return;
- end if;
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
- -- The type of the object cannot be abstract. This is diagnosed at the
- -- point the object is frozen, which happens after the declaration is
- -- fully expanded, so simply return now.
+ -- Unfreeze momentarily the type to add the predefined primitives
+ -- operations. The reason we unfreeze is so that these predefined
+ -- operations will indeed end up as primitive operations (which
+ -- must be before the freeze point).
- if Is_Abstract_Type (Typ) then
- return;
- end if;
+ Set_Is_Frozen (Typ, False);
- -- First we do special processing for objects of a tagged type where
- -- this is the point at which the type is frozen. The creation of the
- -- dispatch table and the initialization procedure have to be deferred
- -- to this point, since we reference previously declared primitive
- -- subprograms.
+ -- Do not add the spec of predefined primitives in case of
+ -- CPP tagged type derivations that have convention CPP.
- -- Force construction of dispatch tables of library level tagged types
+ if Is_CPP_Class (Root_Type (Typ))
+ and then Convention (Typ) = Convention_CPP
+ then
+ null;
- if Tagged_Type_Expansion
- and then Static_Dispatch_Tables
- and then Is_Library_Level_Entity (Def_Id)
- and then Is_Library_Level_Tagged_Type (Base_Typ)
- and then Ekind_In (Base_Typ, E_Record_Type,
- E_Protected_Type,
- E_Task_Type)
- and then not Has_Dispatch_Table (Base_Typ)
- then
- declare
- New_Nodes : List_Id := No_List;
+ -- Do not add the spec of the predefined primitives if we are
+ -- compiling under restriction No_Dispatching_Calls.
- begin
- if Is_Concurrent_Type (Base_Typ) then
- New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N);
- else
- New_Nodes := Make_DT (Base_Typ, N);
+ elsif not Restriction_Active (No_Dispatching_Calls) then
+ Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq);
+ Insert_List_Before_And_Analyze (N, Predef_List);
end if;
- if not Is_Empty_List (New_Nodes) then
- Insert_List_Before (N, New_Nodes);
+ -- Ada 2005 (AI-391): For a nonabstract null extension, create
+ -- wrapper functions for each nonoverridden inherited function
+ -- with a controlling result of the type. The wrapper for such
+ -- a function returns an extension aggregate that invokes the
+ -- parent function.
+
+ if Ada_Version >= Ada_2005
+ and then not Is_Abstract_Type (Typ)
+ and then Is_Null_Extension (Typ)
+ then
+ Make_Controlling_Function_Wrappers
+ (Typ, Wrapper_Decl_List, Wrapper_Body_List);
+ Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
end if;
- end;
- end if;
- -- Make shared memory routines for shared passive variable
+ -- Ada 2005 (AI-251): For a nonabstract type extension, build
+ -- null procedure declarations for each set of homographic null
+ -- procedures that are inherited from interface types but not
+ -- overridden. This is done to ensure that the dispatch table
+ -- entry associated with such null primitives are properly filled.
- if Is_Shared_Passive (Def_Id) then
- Init_After := Make_Shared_Var_Procs (N);
- end if;
+ if Ada_Version >= Ada_2005
+ and then Etype (Typ) /= Typ
+ and then not Is_Abstract_Type (Typ)
+ and then Has_Interfaces (Typ)
+ then
+ Insert_Actions (N, Make_Null_Procedure_Specs (Typ));
+ end if;
- -- If tasks being declared, make sure we have an activation chain
- -- defined for the tasks (has no effect if we already have one), and
- -- also that a Master variable is established and that the appropriate
- -- enclosing construct is established as a task master.
+ Set_Is_Frozen (Typ);
- if Has_Task (Typ) then
- Build_Activation_Chain_Entity (N);
- Build_Master_Entity (Def_Id);
- end if;
+ if not Is_Derived_Type (Typ)
+ or else Is_Tagged_Type (Etype (Typ))
+ then
+ Set_All_DT_Position (Typ);
- -- Default initialization required, and no expression present
+ -- If this is a type derived from an untagged private type whose
+ -- full view is tagged, the type is marked tagged for layout
+ -- reasons, but it has no dispatch table.
- if No (Expr) then
+ elsif Is_Derived_Type (Typ)
+ and then Is_Private_Type (Etype (Typ))
+ and then not Is_Tagged_Type (Etype (Typ))
+ then
+ return;
+ end if;
- -- If we have a type with a variant part, the initialization proc
- -- will contain implicit tests of the discriminant values, which
- -- counts as a violation of the restriction No_Implicit_Conditionals.
+ -- Create and decorate the tags. Suppress their creation when
+ -- not Tagged_Type_Expansion because the dispatching mechanism is
+ -- handled internally by the virtual target.
- if Has_Variant_Part (Typ) then
- declare
- Msg : Boolean;
+ if Tagged_Type_Expansion then
+ Append_Freeze_Actions (Typ, Make_Tags (Typ));
- begin
- Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def);
+ -- Generate dispatch table of locally defined tagged type.
+ -- Dispatch tables of library level tagged types are built
+ -- later (see Analyze_Declarations).
- if Msg then
- Error_Msg_N
- ("\initialization of variant record tests discriminants",
- Obj_Def);
- return;
+ if not Building_Static_DT (Typ) then
+ Append_Freeze_Actions (Typ, Make_DT (Typ));
end if;
- end;
- end if;
-
- -- For the default initialization case, if we have a private type
- -- with invariants, and invariant checks are enabled, then insert an
- -- invariant check after the object declaration. Note that it is OK
- -- to clobber the object with an invalid value since if the exception
- -- is raised, then the object will go out of scope. In the case where
- -- an array object is initialized with an aggregate, the expression
- -- is removed. Check flag Has_Init_Expression to avoid generating a
- -- junk invariant check and flag No_Initialization to avoid checking
- -- an uninitialized object such as a compiler temporary used for an
- -- aggregate.
+ end if;
- if Has_Invariants (Base_Typ)
- and then Present (Invariant_Procedure (Base_Typ))
- and then not Has_Init_Expression (N)
- and then not No_Initialization (N)
- then
- -- If entity has an address clause or aspect, make invariant
- -- call into a freeze action for the explicit freeze node for
- -- object. Otherwise insert invariant check after declaration.
+ -- If the type has unknown discriminants, propagate dispatching
+ -- information to its underlying record view, which does not get
+ -- its own dispatch table.
- if Present (Following_Address_Clause (N))
- or else Has_Aspect (Def_Id, Aspect_Address)
+ if Is_Derived_Type (Typ)
+ and then Has_Unknown_Discriminants (Typ)
+ and then Present (Underlying_Record_View (Typ))
then
- Ensure_Freeze_Node (Def_Id);
- Set_Has_Delayed_Freeze (Def_Id);
- Set_Is_Frozen (Def_Id, False);
+ declare
+ Rep : constant Entity_Id := Underlying_Record_View (Typ);
+ begin
+ Set_Access_Disp_Table
+ (Rep, Access_Disp_Table (Typ));
+ Set_Dispatch_Table_Wrappers
+ (Rep, Dispatch_Table_Wrappers (Typ));
+ Set_Direct_Primitive_Operations
+ (Rep, Direct_Primitive_Operations (Typ));
+ end;
+ end if;
- if not Partial_View_Has_Unknown_Discr (Typ) then
- Append_Freeze_Action (Def_Id,
- Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
+ -- Make sure that the primitives Initialize, Adjust and Finalize
+ -- are Frozen before other TSS subprograms. We don't want them
+ -- Frozen inside.
+
+ if Is_Controlled (Typ) then
+ if not Is_Limited_Type (Typ) then
+ Append_Freeze_Actions (Typ,
+ Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ));
end if;
- elsif not Partial_View_Has_Unknown_Discr (Typ) then
- Insert_After (N,
- Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
+ Append_Freeze_Actions (Typ,
+ Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ));
+
+ Append_Freeze_Actions (Typ,
+ Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ));
+ end if;
+
+ -- Freeze rest of primitive operations. There is no need to handle
+ -- the predefined primitives if we are compiling under restriction
+ -- No_Dispatching_Calls.
+
+ if not Restriction_Active (No_Dispatching_Calls) then
+ Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ));
end if;
end if;
- Default_Initialize_Object (Init_After);
+ -- In the untagged case, ever since Ada 83 an equality function must
+ -- be provided for variant records that are not unchecked unions.
+ -- In Ada 2012 the equality function composes, and thus must be built
+ -- explicitly just as for tagged records.
- -- Generate attribute for Persistent_BSS if needed
+ elsif Has_Discriminants (Typ)
+ and then not Is_Limited_Type (Typ)
+ then
+ declare
+ Comps : constant Node_Id :=
+ Component_List (Type_Definition (Typ_Decl));
+ begin
+ if Present (Comps)
+ and then Present (Variant_Part (Comps))
+ then
+ Build_Variant_Record_Equality (Typ);
+ end if;
+ end;
- if Persistent_BSS_Mode
- and then Comes_From_Source (N)
- and then Is_Potentially_Persistent_Type (Typ)
- and then not Has_Init_Expression (N)
- and then Is_Library_Level_Entity (Def_Id)
- then
- declare
- Prag : Node_Id;
- begin
- Prag :=
- Make_Linker_Section_Pragma
- (Def_Id, Sloc (N), ".persistent.bss");
- Insert_After (N, Prag);
- Analyze (Prag);
- end;
- end if;
+ -- Otherwise create primitive equality operation (AI05-0123)
- -- If access type, then we know it is null if not initialized
+ -- This is done unconditionally to ensure that tools can be linked
+ -- properly with user programs compiled with older language versions.
+ -- In addition, this is needed because "=" composes for bounded strings
+ -- in all language versions (see Exp_Ch4.Expand_Composite_Equality).
- if Is_Access_Type (Typ) then
- Set_Is_Known_Null (Def_Id);
- end if;
+ elsif Comes_From_Source (Typ)
+ and then Convention (Typ) = Convention_Ada
+ and then not Is_Limited_Type (Typ)
+ then
+ Build_Untagged_Equality (Typ);
+ end if;
- -- Explicit initialization present
+ -- Before building the record initialization procedure, if we are
+ -- dealing with a concurrent record value type, then we must go through
+ -- the discriminants, exchanging discriminals between the concurrent
+ -- type and the concurrent record value type. See the section "Handling
+ -- of Discriminants" in the Einfo spec for details.
- else
- -- Obtain actual expression from qualified expression
+ if Is_Concurrent_Record_Type (Typ)
+ and then Has_Discriminants (Typ)
+ then
+ declare
+ Ctyp : constant Entity_Id :=
+ Corresponding_Concurrent_Type (Typ);
+ Conc_Discr : Entity_Id;
+ Rec_Discr : Entity_Id;
+ Temp : Entity_Id;
- if Nkind (Expr) = N_Qualified_Expression then
- Expr_Q := Expression (Expr);
- else
- Expr_Q := Expr;
- end if;
+ begin
+ Conc_Discr := First_Discriminant (Ctyp);
+ Rec_Discr := First_Discriminant (Typ);
+ while Present (Conc_Discr) loop
+ Temp := Discriminal (Conc_Discr);
+ Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
+ Set_Discriminal (Rec_Discr, Temp);
- -- When we have the appropriate type of aggregate in the expression
- -- (it has been determined during analysis of the aggregate by
- -- setting the delay flag), let's perform in place assignment and
- -- thus avoid creating a temporary.
+ Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
+ Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr);
- if Is_Delayed_Aggregate (Expr_Q) then
- Convert_Aggr_In_Object_Decl (N);
+ Next_Discriminant (Conc_Discr);
+ Next_Discriminant (Rec_Discr);
+ end loop;
+ end;
+ end if;
- -- Ada 2005 (AI-318-02): If the initialization expression is a call
- -- to a build-in-place function, then access to the declared object
- -- must be passed to the function. Currently we limit such functions
- -- to those with constrained limited result subtypes, but eventually
- -- plan to expand the allowed forms of functions that are treated as
- -- build-in-place.
+ if Has_Controlled_Component (Typ) then
+ Build_Controlling_Procs (Typ);
+ end if;
- elsif Ada_Version >= Ada_2005
- and then Is_Build_In_Place_Function_Call (Expr_Q)
- then
- Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
+ Adjust_Discriminants (Typ);
- -- The previous call expands the expression initializing the
- -- built-in-place object into further code that will be analyzed
- -- later. No further expansion needed here.
+ -- Do not need init for interfaces on virtual targets since they're
+ -- abstract.
- return;
+ if Tagged_Type_Expansion or else not Is_Interface (Typ) then
+ Build_Record_Init_Proc (Typ_Decl, Typ);
+ end if;
- -- Ada 2005 (AI-251): Rewrite the expression that initializes a
- -- class-wide interface object to ensure that we copy the full
- -- object, unless we are targetting a VM where interfaces are handled
- -- by VM itself. Note that if the root type of Typ is an ancestor of
- -- Expr's type, both types share the same dispatch table and there is
- -- no need to displace the pointer.
+ -- For tagged type that are not interfaces, build bodies of primitive
+ -- operations. Note: do this after building the record initialization
+ -- procedure, since the primitive operations may need the initialization
+ -- routine. There is no need to add predefined primitives of interfaces
+ -- because all their predefined primitives are abstract.
- elsif Is_Interface (Typ)
+ if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then
- -- Avoid never-ending recursion because if Equivalent_Type is set
- -- then we've done it already and must not do it again.
+ -- Do not add the body of predefined primitives in case of CPP tagged
+ -- type derivations that have convention CPP.
- and then not
- (Nkind (Obj_Def) = N_Identifier
- and then Present (Equivalent_Type (Entity (Obj_Def))))
+ if Is_CPP_Class (Root_Type (Typ))
+ and then Convention (Typ) = Convention_CPP
then
- pragma Assert (Is_Class_Wide_Type (Typ));
+ null;
- -- If the object is a return object of an inherently limited type,
- -- which implies build-in-place treatment, bypass the special
- -- treatment of class-wide interface initialization below. In this
- -- case, the expansion of the return statement will take care of
- -- creating the object (via allocator) and initializing it.
+ -- Do not add the body of the predefined primitives if we are
+ -- compiling under restriction No_Dispatching_Calls or if we are
+ -- compiling a CPP tagged type.
- if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then
- null;
+ elsif not Restriction_Active (No_Dispatching_Calls) then
- elsif Tagged_Type_Expansion then
- declare
- Iface : constant Entity_Id := Root_Type (Typ);
- Expr_N : Node_Id := Expr;
- Expr_Typ : Entity_Id;
- New_Expr : Node_Id;
- Obj_Id : Entity_Id;
- Tag_Comp : Node_Id;
+ -- Create the body of TSS primitive Finalize_Address. This must
+ -- be done before the bodies of all predefined primitives are
+ -- created. If Typ is limited, Stream_Input and Stream_Read may
+ -- produce build-in-place allocations and for those the expander
+ -- needs Finalize_Address.
- begin
- -- If the original node of the expression was a conversion
- -- to this specific class-wide interface type then restore
- -- the original node because we must copy the object before
- -- displacing the pointer to reference the secondary tag
- -- component. This code must be kept synchronized with the
- -- expansion done by routine Expand_Interface_Conversion
+ Make_Finalize_Address_Body (Typ);
+ Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq);
+ Append_Freeze_Actions (Typ, Predef_List);
+ end if;
- if not Comes_From_Source (Expr_N)
- and then Nkind (Expr_N) = N_Explicit_Dereference
- and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
- and then Etype (Original_Node (Expr_N)) = Typ
- then
- Rewrite (Expr_N, Original_Node (Expression (N)));
- end if;
+ -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
+ -- inherited functions, then add their bodies to the freeze actions.
- -- Avoid expansion of redundant interface conversion
+ if Present (Wrapper_Body_List) then
+ Append_Freeze_Actions (Typ, Wrapper_Body_List);
+ end if;
- if Is_Interface (Etype (Expr_N))
- and then Nkind (Expr_N) = N_Type_Conversion
- and then Etype (Expr_N) = Typ
- then
- Expr_N := Expression (Expr_N);
- Set_Expression (N, Expr_N);
- end if;
+ -- Create extra formals for the primitive operations of the type.
+ -- This must be done before analyzing the body of the initialization
+ -- procedure, because a self-referential type might call one of these
+ -- primitives in the body of the init_proc itself.
- Obj_Id := Make_Temporary (Loc, 'D', Expr_N);
- Expr_Typ := Base_Type (Etype (Expr_N));
+ declare
+ Elmt : Elmt_Id;
+ Subp : Entity_Id;
- if Is_Class_Wide_Type (Expr_Typ) then
- Expr_Typ := Root_Type (Expr_Typ);
- end if;
+ begin
+ Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+ if not Has_Foreign_Convention (Subp)
+ and then not Is_Predefined_Dispatching_Operation (Subp)
+ then
+ Create_Extra_Formals (Subp);
+ end if;
- -- Replace
- -- CW : I'Class := Obj;
- -- by
- -- Tmp : T := Obj;
- -- type Ityp is not null access I'Class;
- -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all;
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
- if Comes_From_Source (Expr_N)
- and then Nkind (Expr_N) = N_Identifier
- and then not Is_Interface (Expr_Typ)
- and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
- and then (Expr_Typ = Etype (Expr_Typ)
- or else not
- Is_Variable_Size_Record (Etype (Expr_Typ)))
- then
- -- Copy the object
+ -- Create a heterogeneous finalization master to service the anonymous
+ -- access-to-controlled components of the record type.
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Obj_Id,
- Object_Definition =>
- New_Occurrence_Of (Expr_Typ, Loc),
- Expression => Relocate_Node (Expr_N)));
+ if Has_AACC then
+ declare
+ Encl_Scope : constant Entity_Id := Scope (Typ);
+ Ins_Node : constant Node_Id := Parent (Typ);
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Fin_Mas_Id : Entity_Id;
- -- Statically reference the tag associated with the
- -- interface
+ Attributes_Set : Boolean := False;
+ Master_Built : Boolean := False;
+ -- Two flags which control the creation and initialization of a
+ -- common heterogeneous master.
- Tag_Comp :=
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (Find_Interface_Tag (Expr_Typ, Iface), Loc));
+ begin
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ Comp_Typ := Etype (Comp);
- -- Replace
- -- IW : I'Class := Obj;
- -- by
- -- type Equiv_Record is record ... end record;
- -- implicit subtype CW is <Class_Wide_Subtype>;
- -- Tmp : CW := CW!(Obj);
- -- type Ityp is not null access I'Class;
- -- IW : I'Class renames
- -- Ityp!(Displace (Temp'Address, I'Tag)).all;
+ -- A non-self-referential anonymous access-to-controlled
+ -- component.
- else
- -- Generate the equivalent record type and update the
- -- subtype indication to reference it.
+ if Ekind (Comp_Typ) = E_Anonymous_Access_Type
+ and then Needs_Finalization (Designated_Type (Comp_Typ))
+ and then Designated_Type (Comp_Typ) /= Typ
+ then
+ -- Build a homogeneous master for the first anonymous
+ -- access-to-controlled component. This master may be
+ -- converted into a heterogeneous collection if more
+ -- components are to follow.
- Expand_Subtype_From_Expr
- (N => N,
- Unc_Type => Typ,
- Subtype_Indic => Obj_Def,
- Exp => Expr_N);
+ if not Master_Built then
+ Master_Built := True;
- if not Is_Interface (Etype (Expr_N)) then
- New_Expr := Relocate_Node (Expr_N);
+ -- All anonymous access-to-controlled types allocate
+ -- on the global pool. Note that the finalization
+ -- master and the associated storage pool must be set
+ -- on the root type (both are "root type only").
- -- For interface types we use 'Address which displaces
- -- the pointer to the base of the object (if required)
+ Set_Associated_Storage_Pool
+ (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
- else
- New_Expr :=
- Unchecked_Convert_To (Etype (Obj_Def),
- Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (Expr_N),
- Attribute_Name => Name_Address))));
- end if;
+ Build_Finalization_Master
+ (Typ => Root_Type (Comp_Typ),
+ For_Anonymous => True,
+ Context_Scope => Encl_Scope,
+ Insertion_Node => Ins_Node);
- -- Copy the object
+ Fin_Mas_Id := Finalization_Master (Comp_Typ);
- if not Is_Limited_Record (Expr_Typ) then
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Obj_Id,
- Object_Definition =>
- New_Occurrence_Of (Etype (Obj_Def), Loc),
- Expression => New_Expr));
+ -- Subsequent anonymous access-to-controlled components
+ -- reuse the available master.
- -- Rename limited type object since they cannot be copied
- -- This case occurs when the initialization expression
- -- has been previously expanded into a temporary object.
+ else
+ -- All anonymous access-to-controlled types allocate
+ -- on the global pool. Note that both the finalization
+ -- master and the associated storage pool must be set
+ -- on the root type (both are "root type only").
- else pragma Assert (not Comes_From_Source (Expr_Q));
- Insert_Action (N,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Obj_Id,
- Subtype_Mark =>
- New_Occurrence_Of (Etype (Obj_Def), Loc),
- Name =>
- Unchecked_Convert_To
- (Etype (Obj_Def), New_Expr)));
- end if;
+ Set_Associated_Storage_Pool
+ (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
- -- Dynamically reference the tag associated with the
- -- interface.
+ -- Shared the master among multiple components
- Tag_Comp :=
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc),
- Attribute_Name => Name_Address),
- New_Occurrence_Of
- (Node (First_Elmt (Access_Disp_Table (Iface))),
- Loc)));
- end if;
+ Set_Finalization_Master
+ (Root_Type (Comp_Typ), Fin_Mas_Id);
- Rewrite (N,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'D'),
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
- Name =>
- Convert_Tag_To_Interface (Typ, Tag_Comp)));
+ -- Convert the master into a heterogeneous collection.
+ -- Generate:
+ -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
- -- If the original entity comes from source, then mark the
- -- new entity as needing debug information, even though it's
- -- defined by a generated renaming that does not come from
- -- source, so that Materialize_Entity will be set on the
- -- entity when Debug_Renaming_Declaration is called during
- -- analysis.
+ if not Attributes_Set then
+ Attributes_Set := True;
- if Comes_From_Source (Def_Id) then
- Set_Debug_Info_Needed (Defining_Identifier (N));
+ Insert_Action (Ins_Node,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Set_Is_Heterogeneous), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Fin_Mas_Id, Loc))));
+ end if;
end if;
+ end if;
- Analyze (N, Suppress => All_Checks);
+ Next_Component (Comp);
+ end loop;
+ end;
+ end if;
- -- Replace internal identifier of rewritten node by the
- -- identifier found in the sources. We also have to exchange
- -- entities containing their defining identifiers to ensure
- -- the correct replacement of the object declaration by this
- -- object renaming declaration because these identifiers
- -- were previously added by Enter_Name to the current scope.
- -- We must preserve the homonym chain of the source entity
- -- as well. We must also preserve the kind of the entity,
- -- which may be a constant. Preserve entity chain because
- -- itypes may have been generated already, and the full
- -- chain must be preserved for final freezing. Finally,
- -- preserve Comes_From_Source setting, so that debugging
- -- and cross-referencing information is properly kept, and
- -- preserve source location, to prevent spurious errors when
- -- entities are declared (they must have their own Sloc).
+ -- Check whether individual components have a defined invariant, and add
+ -- the corresponding component invariant checks.
- declare
- New_Id : constant Entity_Id := Defining_Identifier (N);
- Next_Temp : constant Entity_Id := Next_Entity (New_Id);
- S_Flag : constant Boolean :=
- Comes_From_Source (Def_Id);
+ -- Do not create an invariant procedure for some internally generated
+ -- subtypes, in particular those created for objects of a class-wide
+ -- type. Such types may have components to which invariant apply, but
+ -- the corresponding checks will be applied when an object of the parent
+ -- type is constructed.
- begin
- Set_Next_Entity (New_Id, Next_Entity (Def_Id));
- Set_Next_Entity (Def_Id, Next_Temp);
+ -- Such objects will show up in a class-wide postcondition, and the
+ -- invariant will be checked, if necessary, upon return from the
+ -- enclosing subprogram.
- Set_Chars (Defining_Identifier (N), Chars (Def_Id));
- Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
- Set_Ekind (Defining_Identifier (N), Ekind (Def_Id));
- Set_Sloc (Defining_Identifier (N), Sloc (Def_Id));
+ if not Is_Class_Wide_Equivalent_Type (Typ) then
+ Insert_Component_Invariant_Checks
+ (N, Typ, Build_Record_Invariant_Proc (Typ, N));
+ end if;
- Set_Comes_From_Source (Def_Id, False);
- Exchange_Entities (Defining_Identifier (N), Def_Id);
- Set_Comes_From_Source (Def_Id, S_Flag);
- end;
- end;
- end if;
+ Ghost_Mode := Save_Ghost_Mode;
+ end Expand_Freeze_Record_Type;
- return;
+ ------------------------------------
+ -- Expand_N_Full_Type_Declaration --
+ ------------------------------------
- -- Common case of explicit object initialization
+ procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
+ procedure Build_Master (Ptr_Typ : Entity_Id);
+ -- Create the master associated with Ptr_Typ
- else
- -- In most cases, we must check that the initial value meets any
- -- constraint imposed by the declared type. However, there is one
- -- very important exception to this rule. If the entity has an
- -- unconstrained nominal subtype, then it acquired its constraints
- -- from the expression in the first place, and not only does this
- -- mean that the constraint check is not needed, but an attempt to
- -- perform the constraint check can cause order of elaboration
- -- problems.
+ ------------------
+ -- Build_Master --
+ ------------------
- if not Is_Constr_Subt_For_U_Nominal (Typ) then
+ procedure Build_Master (Ptr_Typ : Entity_Id) is
+ Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ);
- -- If this is an allocator for an aggregate that has been
- -- allocated in place, delay checks until assignments are
- -- made, because the discriminants are not initialized.
+ begin
+ -- If the designated type is an incomplete view coming from a
+ -- limited-with'ed package, we need to use the nonlimited view in
+ -- case it has tasks.
- if Nkind (Expr) = N_Allocator and then No_Initialization (Expr)
- then
- null;
+ if Ekind (Desig_Typ) in Incomplete_Kind
+ and then Present (Non_Limited_View (Desig_Typ))
+ then
+ Desig_Typ := Non_Limited_View (Desig_Typ);
+ end if;
- -- Otherwise apply a constraint check now if no prev error
+ -- Anonymous access types are created for the components of the
+ -- record parameter for an entry declaration. No master is created
+ -- for such a type.
- elsif Nkind (Expr) /= N_Error then
- Apply_Constraint_Check (Expr, Typ);
+ if Comes_From_Source (N) and then Has_Task (Desig_Typ) then
+ Build_Master_Entity (Ptr_Typ);
+ Build_Master_Renaming (Ptr_Typ);
- -- Deal with possible range check
+ -- Create a class-wide master because a Master_Id must be generated
+ -- for access-to-limited-class-wide types whose root may be extended
+ -- with task components.
- if Do_Range_Check (Expr) then
+ -- Note: This code covers access-to-limited-interfaces because they
+ -- can be used to reference tasks implementing them.
- -- If assignment checks are suppressed, turn off flag
+ elsif Is_Limited_Class_Wide_Type (Desig_Typ)
+ and then Tasking_Allowed
+ then
+ Build_Class_Wide_Master (Ptr_Typ);
+ end if;
+ end Build_Master;
- if Suppress_Assignment_Checks (N) then
- Set_Do_Range_Check (Expr, False);
+ -- Local declarations
- -- Otherwise generate the range check
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+ B_Id : constant Entity_Id := Base_Type (Def_Id);
+ FN : Node_Id;
+ Par_Id : Entity_Id;
- else
- Generate_Range_Check
- (Expr, Typ, CE_Range_Check_Failed);
- end if;
- end if;
- end if;
- end if;
-
- -- If the type is controlled and not inherently limited, then
- -- the target is adjusted after the copy and attached to the
- -- finalization list. However, no adjustment is done in the case
- -- where the object was initialized by a call to a function whose
- -- result is built in place, since no copy occurred. (Eventually
- -- we plan to support in-place function results for some cases
- -- of nonlimited types. ???) Similarly, no adjustment is required
- -- if we are going to rewrite the object declaration into a
- -- renaming declaration.
-
- if Needs_Finalization (Typ)
- and then not Is_Limited_View (Typ)
- and then not Rewrite_As_Renaming
- then
- Insert_Action_After (Init_After,
- Make_Adjust_Call (
- Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
- Typ => Base_Typ));
- end if;
+ -- Start of processing for Expand_N_Full_Type_Declaration
- -- For tagged types, when an init value is given, the tag has to
- -- be re-initialized separately in order to avoid the propagation
- -- of a wrong tag coming from a view conversion unless the type
- -- is class wide (in this case the tag comes from the init value).
- -- Suppress the tag assignment when not Tagged_Type_Expansion
- -- because tags are represented implicitly in objects. Ditto for
- -- types that are CPP_CLASS, and for initializations that are
- -- aggregates, because they have to have the right tag.
+ begin
+ if Is_Access_Type (Def_Id) then
+ Build_Master (Def_Id);
- -- The re-assignment of the tag has to be done even if the object
- -- is a constant. The assignment must be analyzed after the
- -- declaration. If an address clause follows, this is handled as
- -- part of the freeze actions for the object, otherwise insert
- -- tag assignment here.
+ if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then
+ Expand_Access_Protected_Subprogram_Type (N);
+ end if;
- Tag_Assign := Make_Tag_Assignment (N);
+ -- Array of anonymous access-to-task pointers
- if Present (Tag_Assign) then
- if Present (Following_Address_Clause (N)) then
- Ensure_Freeze_Node (Def_Id);
+ elsif Ada_Version >= Ada_2005
+ and then Is_Array_Type (Def_Id)
+ and then Is_Access_Type (Component_Type (Def_Id))
+ and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type
+ then
+ Build_Master (Component_Type (Def_Id));
- else
- Insert_Action_After (Init_After, Tag_Assign);
- end if;
+ elsif Has_Task (Def_Id) then
+ Expand_Previous_Access_Type (Def_Id);
- -- Handle C++ constructor calls. Note that we do not check that
- -- Typ is a tagged type since the equivalent Ada type of a C++
- -- class that has no virtual methods is an untagged limited
- -- record type.
+ -- Check the components of a record type or array of records for
+ -- anonymous access-to-task pointers.
- elsif Is_CPP_Constructor_Call (Expr) then
+ elsif Ada_Version >= Ada_2005
+ and then (Is_Record_Type (Def_Id)
+ or else
+ (Is_Array_Type (Def_Id)
+ and then Is_Record_Type (Component_Type (Def_Id))))
+ then
+ declare
+ Comp : Entity_Id;
+ First : Boolean;
+ M_Id : Entity_Id;
+ Typ : Entity_Id;
- -- The call to the initialization procedure does NOT freeze the
- -- object being initialized.
+ begin
+ if Is_Array_Type (Def_Id) then
+ Comp := First_Entity (Component_Type (Def_Id));
+ else
+ Comp := First_Entity (Def_Id);
+ end if;
- Id_Ref := New_Occurrence_Of (Def_Id, Loc);
- Set_Must_Not_Freeze (Id_Ref);
- Set_Assignment_OK (Id_Ref);
+ -- Examine all components looking for anonymous access-to-task
+ -- types.
- Insert_Actions_After (Init_After,
- Build_Initialization_Call (Loc, Id_Ref, Typ,
- Constructor_Ref => Expr));
+ First := True;
+ while Present (Comp) loop
+ Typ := Etype (Comp);
- -- We remove here the original call to the constructor
- -- to avoid its management in the backend
+ if Ekind (Typ) = E_Anonymous_Access_Type
+ and then Has_Task (Available_View (Designated_Type (Typ)))
+ and then No (Master_Id (Typ))
+ then
+ -- Ensure that the record or array type have a _master
- Set_Expression (N, Empty);
- return;
+ if First then
+ Build_Master_Entity (Def_Id);
+ Build_Master_Renaming (Typ);
+ M_Id := Master_Id (Typ);
- -- Handle initialization of limited tagged types
+ First := False;
- elsif Is_Tagged_Type (Typ)
- and then Is_Class_Wide_Type (Typ)
- and then Is_Limited_Record (Typ)
- then
- -- Given that the type is limited we cannot perform a copy. If
- -- Expr_Q is the reference to a variable we mark the variable
- -- as OK_To_Rename to expand this declaration into a renaming
- -- declaration (see bellow).
+ -- Reuse the same master to service any additional types
- if Is_Entity_Name (Expr_Q) then
- Set_OK_To_Rename (Entity (Expr_Q));
+ else
+ Set_Master_Id (Typ, M_Id);
+ end if;
+ end if;
- -- If we cannot convert the expression into a renaming we must
- -- consider it an internal error because the backend does not
- -- have support to handle it.
+ Next_Entity (Comp);
+ end loop;
+ end;
+ end if;
- else
- pragma Assert (False);
- raise Program_Error;
- end if;
+ Par_Id := Etype (B_Id);
- -- For discrete types, set the Is_Known_Valid flag if the
- -- initializing value is known to be valid. Only do this for
- -- source assignments, since otherwise we can end up turning
- -- on the known valid flag prematurely from inserted code.
+ -- The parent type is private then we need to inherit any TSS operations
+ -- from the full view.
- elsif Comes_From_Source (N)
- and then Is_Discrete_Type (Typ)
- and then Expr_Known_Valid (Expr)
- then
- Set_Is_Known_Valid (Def_Id);
+ if Ekind (Par_Id) in Private_Kind
+ and then Present (Full_View (Par_Id))
+ then
+ Par_Id := Base_Type (Full_View (Par_Id));
+ end if;
- elsif Is_Access_Type (Typ) then
+ if Nkind (Type_Definition (Original_Node (N))) =
+ N_Derived_Type_Definition
+ and then not Is_Tagged_Type (Def_Id)
+ and then Present (Freeze_Node (Par_Id))
+ and then Present (TSS_Elist (Freeze_Node (Par_Id)))
+ then
+ Ensure_Freeze_Node (B_Id);
+ FN := Freeze_Node (B_Id);
- -- For access types set the Is_Known_Non_Null flag if the
- -- initializing value is known to be non-null. We can also set
- -- Can_Never_Be_Null if this is a constant.
+ if No (TSS_Elist (FN)) then
+ Set_TSS_Elist (FN, New_Elmt_List);
+ end if;
- if Known_Non_Null (Expr) then
- Set_Is_Known_Non_Null (Def_Id, True);
+ declare
+ T_E : constant Elist_Id := TSS_Elist (FN);
+ Elmt : Elmt_Id;
- if Constant_Present (N) then
- Set_Can_Never_Be_Null (Def_Id);
- end if;
+ begin
+ Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id)));
+ while Present (Elmt) loop
+ if Chars (Node (Elmt)) /= Name_uInit then
+ Append_Elmt (Node (Elmt), T_E);
end if;
- end if;
- -- If validity checking on copies, validate initial expression.
- -- But skip this if declaration is for a generic type, since it
- -- makes no sense to validate generic types. Not clear if this
- -- can happen for legal programs, but it definitely can arise
- -- from previous instantiation errors.
+ Next_Elmt (Elmt);
+ end loop;
- if Validity_Checks_On
- and then Validity_Check_Copies
- and then not Is_Generic_Type (Etype (Def_Id))
+ -- If the derived type itself is private with a full view, then
+ -- associate the full view with the inherited TSS_Elist as well.
+
+ if Ekind (B_Id) in Private_Kind
+ and then Present (Full_View (B_Id))
then
- Ensure_Valid (Expr);
- Set_Is_Known_Valid (Def_Id);
+ Ensure_Freeze_Node (Base_Type (Full_View (B_Id)));
+ Set_TSS_Elist
+ (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN));
end if;
- end if;
-
- -- Cases where the back end cannot handle the initialization directly
- -- In such cases, we expand an assignment that will be appropriately
- -- handled by Expand_N_Assignment_Statement.
+ end;
+ end if;
+ end Expand_N_Full_Type_Declaration;
- -- The exclusion of the unconstrained case is wrong, but for now it
- -- is too much trouble ???
+ ---------------------------------
+ -- Expand_N_Object_Declaration --
+ ---------------------------------
- if (Is_Possibly_Unaligned_Slice (Expr)
- or else (Is_Possibly_Unaligned_Object (Expr)
- and then not Represented_As_Scalar (Etype (Expr))))
- and then not (Is_Array_Type (Etype (Expr))
- and then not Is_Constrained (Etype (Expr)))
- then
- declare
- Stat : constant Node_Id :=
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Def_Id, Loc),
- Expression => Relocate_Node (Expr));
- begin
- Set_Expression (N, Empty);
- Set_No_Initialization (N);
- Set_Assignment_OK (Name (Stat));
- Set_No_Ctrl_Actions (Stat);
- Insert_After_And_Analyze (Init_After, Stat);
- end;
- end if;
+ procedure Expand_N_Object_Declaration (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : constant Entity_Id := Defining_Identifier (N);
+ Expr : constant Node_Id := Expression (N);
+ Obj_Def : constant Node_Id := Object_Definition (N);
+ Typ : constant Entity_Id := Etype (Def_Id);
+ Base_Typ : constant Entity_Id := Base_Type (Typ);
+ Expr_Q : Node_Id;
- -- Final transformation, if the initializing expression is an entity
- -- for a variable with OK_To_Rename set, then we transform:
+ function Build_Equivalent_Aggregate return Boolean;
+ -- If the object has a constrained discriminated type and no initial
+ -- value, it may be possible to build an equivalent aggregate instead,
+ -- and prevent an actual call to the initialization procedure.
- -- X : typ := expr;
+ procedure Default_Initialize_Object (After : Node_Id);
+ -- Generate all default initialization actions for object Def_Id. Any
+ -- new code is inserted after node After.
- -- into
+ function Rewrite_As_Renaming return Boolean;
+ -- Indicate whether to rewrite a declaration with initialization into an
+ -- object renaming declaration (see below).
- -- X : typ renames expr
-
- -- provided that X is not aliased. The aliased case has to be
- -- excluded in general because Expr will not be aliased in general.
-
- if Rewrite_As_Renaming then
- Rewrite (N,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Defining_Identifier (N),
- Subtype_Mark => Obj_Def,
- Name => Expr_Q));
-
- -- We do not analyze this renaming declaration, because all its
- -- components have already been analyzed, and if we were to go
- -- ahead and analyze it, we would in effect be trying to generate
- -- another declaration of X, which won't do.
+ --------------------------------
+ -- Build_Equivalent_Aggregate --
+ --------------------------------
- Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
- Set_Analyzed (N);
+ function Build_Equivalent_Aggregate return Boolean is
+ Aggr : Node_Id;
+ Comp : Entity_Id;
+ Discr : Elmt_Id;
+ Full_Type : Entity_Id;
- -- We do need to deal with debug issues for this renaming
+ begin
+ Full_Type := Typ;
- -- First, if entity comes from source, then mark it as needing
- -- debug information, even though it is defined by a generated
- -- renaming that does not come from source.
+ if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+ Full_Type := Full_View (Typ);
+ end if;
- if Comes_From_Source (Defining_Identifier (N)) then
- Set_Debug_Info_Needed (Defining_Identifier (N));
- end if;
+ -- Only perform this transformation if Elaboration_Code is forbidden
+ -- or undesirable, and if this is a global entity of a constrained
+ -- record type.
- -- Now call the routine to generate debug info for the renaming
+ -- If Initialize_Scalars might be active this transformation cannot
+ -- be performed either, because it will lead to different semantics
+ -- or because elaboration code will in fact be created.
- declare
- Decl : constant Node_Id := Debug_Renaming_Declaration (N);
- begin
- if Present (Decl) then
- Insert_Action (N, Decl);
- end if;
- end;
+ if Ekind (Full_Type) /= E_Record_Subtype
+ or else not Has_Discriminants (Full_Type)
+ or else not Is_Constrained (Full_Type)
+ or else Is_Controlled (Full_Type)
+ or else Is_Limited_Type (Full_Type)
+ or else not Restriction_Active (No_Initialize_Scalars)
+ then
+ return False;
end if;
- end if;
-
- if Nkind (N) = N_Object_Declaration
- and then Nkind (Obj_Def) = N_Access_Definition
- and then not Is_Local_Anonymous_Access (Etype (Def_Id))
- then
- -- An Ada 2012 stand-alone object of an anonymous access type
- declare
- Loc : constant Source_Ptr := Sloc (N);
+ if Ekind (Current_Scope) = E_Package
+ and then
+ (Restriction_Active (No_Elaboration_Code)
+ or else Is_Preelaborated (Current_Scope))
+ then
+ -- Building a static aggregate is possible if the discriminants
+ -- have static values and the other components have static
+ -- defaults or none.
- Level : constant Entity_Id :=
- Make_Defining_Identifier (Sloc (N),
- Chars =>
- New_External_Name (Chars (Def_Id), Suffix => "L"));
+ Discr := First_Elmt (Discriminant_Constraint (Full_Type));
+ while Present (Discr) loop
+ if not Is_OK_Static_Expression (Node (Discr)) then
+ return False;
+ end if;
- Level_Expr : Node_Id;
- Level_Decl : Node_Id;
+ Next_Elmt (Discr);
+ end loop;
- begin
- Set_Ekind (Level, Ekind (Def_Id));
- Set_Etype (Level, Standard_Natural);
- Set_Scope (Level, Scope (Def_Id));
+ -- Check that initialized components are OK, and that non-
+ -- initialized components do not require a call to their own
+ -- initialization procedure.
- if No (Expr) then
+ Comp := First_Component (Full_Type);
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component
+ and then Present (Expression (Parent (Comp)))
+ and then
+ not Is_OK_Static_Expression (Expression (Parent (Comp)))
+ then
+ return False;
- -- Set accessibility level of null
+ elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
+ return False;
- Level_Expr :=
- Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
+ end if;
- else
- Level_Expr := Dynamic_Accessibility_Level (Expr);
- end if;
+ Next_Component (Comp);
+ end loop;
- Level_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Level,
- Object_Definition =>
- New_Occurrence_Of (Standard_Natural, Loc),
- Expression => Level_Expr,
- Constant_Present => Constant_Present (N),
- Has_Init_Expression => True);
+ -- Everything is static, assemble the aggregate, discriminant
+ -- values first.
- Insert_Action_After (Init_After, Level_Decl);
+ Aggr :=
+ Make_Aggregate (Loc,
+ Expressions => New_List,
+ Component_Associations => New_List);
- Set_Extra_Accessibility (Def_Id, Level);
- end;
- end if;
+ Discr := First_Elmt (Discriminant_Constraint (Full_Type));
+ while Present (Discr) loop
+ Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
+ Next_Elmt (Discr);
+ end loop;
- -- If the object is default initialized and its type is subject to
- -- pragma Default_Initial_Condition, add a runtime check to verify
- -- the assumption of the pragma (SPARK RM 7.3.3). Generate:
+ -- Now collect values of initialized components
- -- <Base_Typ>Default_Init_Cond (<Base_Typ> (Def_Id));
+ Comp := First_Component (Full_Type);
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component
+ and then Present (Expression (Parent (Comp)))
+ then
+ Append_To (Component_Associations (Aggr),
+ Make_Component_Association (Loc,
+ Choices => New_List (New_Occurrence_Of (Comp, Loc)),
+ Expression => New_Copy_Tree
+ (Expression (Parent (Comp)))));
+ end if;
- -- Note that the check is generated for source objects only
+ Next_Component (Comp);
+ end loop;
- if Comes_From_Source (Def_Id)
- and then (Has_Default_Init_Cond (Typ)
- or else
- Has_Inherited_Default_Init_Cond (Typ))
- and then not Has_Init_Expression (N)
- then
- declare
- DIC_Call : constant Node_Id :=
- Build_Default_Init_Cond_Call (Loc, Def_Id, Typ);
- begin
- if Present (Next_N) then
- Insert_Before_And_Analyze (Next_N, DIC_Call);
+ -- Finally, box-initialize remaining components
- -- The object declaration is the last node in a declarative or a
- -- statement list.
+ Append_To (Component_Associations (Aggr),
+ Make_Component_Association (Loc,
+ Choices => New_List (Make_Others_Choice (Loc)),
+ Expression => Empty));
+ Set_Box_Present (Last (Component_Associations (Aggr)));
+ Set_Expression (N, Aggr);
+ if Typ /= Full_Type then
+ Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type)));
+ Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
+ Analyze_And_Resolve (Aggr, Typ);
else
- Append_To (List_Containing (N), DIC_Call);
- Analyze (DIC_Call);
+ Analyze_And_Resolve (Aggr, Full_Type);
end if;
- end;
- end if;
- -- Exception on library entity not available
+ return True;
- exception
- when RE_Not_Available =>
- return;
- end Expand_N_Object_Declaration;
+ else
+ return False;
+ end if;
+ end Build_Equivalent_Aggregate;
- ---------------------------------
- -- Expand_N_Subtype_Indication --
- ---------------------------------
+ -------------------------------
+ -- Default_Initialize_Object --
+ -------------------------------
- -- Add a check on the range of the subtype. The static case is partially
- -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
- -- to check here for the static case in order to avoid generating
- -- extraneous expanded code. Also deal with validity checking.
+ procedure Default_Initialize_Object (After : Node_Id) is
+ function New_Object_Reference return Node_Id;
+ -- Return a new reference to Def_Id with attributes Assignment_OK and
+ -- Must_Not_Freeze already set.
- procedure Expand_N_Subtype_Indication (N : Node_Id) is
- Ran : constant Node_Id := Range_Expression (Constraint (N));
- Typ : constant Entity_Id := Entity (Subtype_Mark (N));
+ --------------------------
+ -- New_Object_Reference --
+ --------------------------
- begin
- if Nkind (Constraint (N)) = N_Range_Constraint then
- Validity_Check_Range (Range_Expression (Constraint (N)));
- end if;
+ function New_Object_Reference return Node_Id is
+ Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
- if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then
- Apply_Range_Check (Ran, Typ);
- end if;
- end Expand_N_Subtype_Indication;
+ begin
+ -- The call to the type init proc or [Deep_]Finalize must not
+ -- freeze the related object as the call is internally generated.
+ -- This way legal rep clauses that apply to the object will not be
+ -- flagged. Note that the initialization call may be removed if
+ -- pragma Import is encountered or moved to the freeze actions of
+ -- the object because of an address clause.
- ---------------------------
- -- Expand_N_Variant_Part --
- ---------------------------
+ Set_Assignment_OK (Obj_Ref);
+ Set_Must_Not_Freeze (Obj_Ref);
- -- Note: this procedure no longer has any effect. It used to be that we
- -- would replace the choices in the last variant by a when others, and
- -- also expanded static predicates in variant choices here, but both of
- -- those activities were being done too early, since we can't check the
- -- choices until the statically predicated subtypes are frozen, which can
- -- happen as late as the free point of the record, and we can't change the
- -- last choice to an others before checking the choices, which is now done
- -- at the freeze point of the record.
+ return Obj_Ref;
+ end New_Object_Reference;
- procedure Expand_N_Variant_Part (N : Node_Id) is
- begin
- null;
- end Expand_N_Variant_Part;
+ -- Local variables
- ---------------------------------
- -- Expand_Previous_Access_Type --
- ---------------------------------
+ Abrt_Blk : Node_Id;
+ Abrt_HSS : Node_Id;
+ Abrt_Id : Entity_Id;
+ Abrt_Stmts : List_Id;
+ Aggr_Init : Node_Id;
+ Comp_Init : List_Id := No_List;
+ Fin_Call : Node_Id;
+ Fin_Stmts : List_Id := No_List;
+ Obj_Init : Node_Id := Empty;
+ Obj_Ref : Node_Id;
- procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
- Ptr_Typ : Entity_Id;
+ Dummy : Entity_Id;
+ -- This variable captures a dummy internal entity, see the comment
+ -- associated with its use.
- begin
- -- Find all access types in the current scope whose designated type is
- -- Def_Id and build master renamings for them.
+ -- Start of processing for Default_Initialize_Object
- Ptr_Typ := First_Entity (Current_Scope);
- while Present (Ptr_Typ) loop
- if Is_Access_Type (Ptr_Typ)
- and then Designated_Type (Ptr_Typ) = Def_Id
- and then No (Master_Id (Ptr_Typ))
- then
- -- Ensure that the designated type has a master
+ begin
+ -- Default initialization is suppressed for objects that are already
+ -- known to be imported (i.e. whose declaration specifies the Import
+ -- aspect). Note that for objects with a pragma Import, we generate
+ -- initialization here, and then remove it downstream when processing
+ -- the pragma. It is also suppressed for variables for which a pragma
+ -- Suppress_Initialization has been explicitly given
- Build_Master_Entity (Def_Id);
+ if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then
+ return;
+ end if;
- -- Private and incomplete types complicate the insertion of master
- -- renamings because the access type may precede the full view of
- -- the designated type. For this reason, the master renamings are
- -- inserted relative to the designated type.
+ -- Step 1: Initialize the object
- Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id));
+ if Needs_Finalization (Typ) and then not No_Initialization (N) then
+ Obj_Init :=
+ Make_Init_Call
+ (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
+ Typ => Typ);
end if;
- Next_Entity (Ptr_Typ);
- end loop;
- end Expand_Previous_Access_Type;
+ -- Step 2: Initialize the components of the object
- ------------------------
- -- Expand_Tagged_Root --
- ------------------------
+ -- Do not initialize the components if their initialization is
+ -- prohibited.
- procedure Expand_Tagged_Root (T : Entity_Id) is
- Def : constant Node_Id := Type_Definition (Parent (T));
- Comp_List : Node_Id;
- Comp_Decl : Node_Id;
- Sloc_N : Source_Ptr;
+ if Has_Non_Null_Base_Init_Proc (Typ)
+ and then not No_Initialization (N)
+ and then not Initialization_Suppressed (Typ)
+ then
+ -- Do not initialize the components if No_Default_Initialization
+ -- applies as the actual restriction check will occur later
+ -- when the object is frozen as it is not known yet whether the
+ -- object is imported or not.
- begin
- if Null_Present (Def) then
- Set_Component_List (Def,
- Make_Component_List (Sloc (Def),
- Component_Items => Empty_List,
- Variant_Part => Empty,
- Null_Present => True));
- end if;
+ if not Restriction_Active (No_Default_Initialization) then
- Comp_List := Component_List (Def);
+ -- If the values of the components are compile-time known, use
+ -- their prebuilt aggregate form directly.
- if Null_Present (Comp_List)
- or else Is_Empty_List (Component_Items (Comp_List))
- then
- Sloc_N := Sloc (Comp_List);
- else
- Sloc_N := Sloc (First (Component_Items (Comp_List)));
- end if;
+ Aggr_Init := Static_Initialization (Base_Init_Proc (Typ));
- Comp_Decl :=
- Make_Component_Declaration (Sloc_N,
- Defining_Identifier => First_Tag_Component (T),
- Component_Definition =>
- Make_Component_Definition (Sloc_N,
- Aliased_Present => False,
- Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N)));
+ if Present (Aggr_Init) then
+ Set_Expression
+ (N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope));
- if Null_Present (Comp_List)
- or else Is_Empty_List (Component_Items (Comp_List))
- then
- Set_Component_Items (Comp_List, New_List (Comp_Decl));
- Set_Null_Present (Comp_List, False);
+ -- If type has discriminants, try to build an equivalent
+ -- aggregate using discriminant values from the declaration.
+ -- This is a useful optimization, in particular if restriction
+ -- No_Elaboration_Code is active.
- else
- Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
- end if;
+ elsif Build_Equivalent_Aggregate then
+ null;
- -- We don't Analyze the whole expansion because the tag component has
- -- already been analyzed previously. Here we just insure that the tree
- -- is coherent with the semantic decoration
+ -- Otherwise invoke the type init proc
- Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
+ else
+ Obj_Ref := New_Object_Reference;
- exception
- when RE_Not_Available =>
- return;
- end Expand_Tagged_Root;
+ if Comes_From_Source (Def_Id) then
+ Initialization_Warning (Obj_Ref);
+ end if;
- ----------------------
- -- Clean_Task_Names --
- ----------------------
+ Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ);
+ end if;
+ end if;
- procedure Clean_Task_Names
- (Typ : Entity_Id;
- Proc_Id : Entity_Id)
- is
- begin
- if Has_Task (Typ)
- and then not Restriction_Active (No_Implicit_Heap_Allocations)
- and then not Global_Discard_Names
- and then Tagged_Type_Expansion
- then
- Set_Uses_Sec_Stack (Proc_Id);
- end if;
- end Clean_Task_Names;
+ -- Provide a default value if the object needs simple initialization
+ -- and does not already have an initial value. A generated temporary
+ -- does not require initialization because it will be assigned later.
- ------------------------------
- -- Expand_Freeze_Array_Type --
- ------------------------------
+ elsif Needs_Simple_Initialization
+ (Typ, Initialize_Scalars
+ and then No (Following_Address_Clause (N)))
+ and then not Is_Internal (Def_Id)
+ and then not Has_Init_Expression (N)
+ then
+ Set_No_Initialization (N, False);
+ Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
+ Analyze_And_Resolve (Expression (N), Typ);
+ end if;
- procedure Expand_Freeze_Array_Type (N : Node_Id) is
- Typ : constant Entity_Id := Entity (N);
- Base : constant Entity_Id := Base_Type (Typ);
- Comp_Typ : constant Entity_Id := Component_Type (Typ);
- Ins_Node : Node_Id;
+ -- Step 3: Add partial finalization and abort actions, generate:
- begin
- if not Is_Bit_Packed_Array (Typ) then
+ -- Type_Init_Proc (Obj);
+ -- begin
+ -- Deep_Initialize (Obj);
+ -- exception
+ -- when others =>
+ -- Deep_Finalize (Obj, Self => False);
+ -- raise;
+ -- end;
- -- If the component contains tasks, so does the array type. This may
- -- not be indicated in the array type because the component may have
- -- been a private type at the point of definition. Same if component
- -- type is controlled or contains protected objects.
+ -- Step 3a: Build the finalization block (if applicable)
- Set_Has_Task (Base, Has_Task (Comp_Typ));
- Set_Has_Protected (Base, Has_Protected (Comp_Typ));
- Set_Has_Controlled_Component
- (Base, Has_Controlled_Component
- (Comp_Typ)
- or else
- Is_Controlled (Comp_Typ));
+ -- The finalization block is required when both the object and its
+ -- controlled components are to be initialized. The block finalizes
+ -- the components if the object initialization fails.
- if No (Init_Proc (Base)) then
+ if Has_Controlled_Component (Typ)
+ and then Present (Comp_Init)
+ and then Present (Obj_Init)
+ and then not Restriction_Active (No_Exception_Propagation)
+ then
+ -- Generate:
+ -- Type_Init_Proc (Obj);
- -- If this is an anonymous array created for a declaration with
- -- an initial value, its init_proc will never be called. The
- -- initial value itself may have been expanded into assignments,
- -- in which case the object declaration is carries the
- -- No_Initialization flag.
+ Fin_Stmts := Comp_Init;
- if Is_Itype (Base)
- and then Nkind (Associated_Node_For_Itype (Base)) =
- N_Object_Declaration
- and then
- (Present (Expression (Associated_Node_For_Itype (Base)))
- or else No_Initialization (Associated_Node_For_Itype (Base)))
- then
- null;
+ -- Generate:
+ -- begin
+ -- Deep_Initialize (Obj);
+ -- exception
+ -- when others =>
+ -- Deep_Finalize (Obj, Self => False);
+ -- raise;
+ -- end;
- -- We do not need an init proc for string or wide [wide] string,
- -- since the only time these need initialization in normalize or
- -- initialize scalars mode, and these types are treated specially
- -- and do not need initialization procedures.
+ Fin_Call :=
+ Make_Final_Call
+ (Obj_Ref => New_Object_Reference,
+ Typ => Typ,
+ Skip_Self => True);
- elsif Is_Standard_String_Type (Base) then
- null;
+ if Present (Fin_Call) then
- -- Otherwise we have to build an init proc for the subtype
+ -- Do not emit warnings related to the elaboration order when a
+ -- controlled object is declared before the body of Finalize is
+ -- seen.
- else
- Build_Array_Init_Proc (Base, N);
- end if;
- end if;
+ Set_No_Elaboration_Check (Fin_Call);
- if Typ = Base then
- if Has_Controlled_Component (Base) then
- Build_Controlling_Procs (Base);
+ Append_To (Fin_Stmts,
+ Make_Block_Statement (Loc,
+ Declarations => No_List,
- if not Is_Limited_Type (Comp_Typ)
- and then Number_Dimensions (Typ) = 1
- then
- Build_Slice_Assignment (Typ);
- end if;
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Obj_Init),
+
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+
+ Statements => New_List (
+ Fin_Call,
+ Make_Raise_Statement (Loc)))))));
end if;
- -- Create a finalization master to service the anonymous access
- -- components of the array.
+ -- Finalization is not required, the initialization calls are passed
+ -- to the abort block building circuitry, generate:
- if Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Needs_Finalization (Designated_Type (Comp_Typ))
- then
- -- The finalization master is inserted before the declaration
- -- of the array type. The only exception to this is when the
- -- array type is an itype, in which case the master appears
- -- before the related context.
+ -- Type_Init_Proc (Obj);
+ -- Deep_Initialize (Obj);
- if Is_Itype (Typ) then
- Ins_Node := Associated_Node_For_Itype (Typ);
- else
- Ins_Node := Parent (Typ);
+ else
+ if Present (Comp_Init) then
+ Fin_Stmts := Comp_Init;
+ end if;
+
+ if Present (Obj_Init) then
+ if No (Fin_Stmts) then
+ Fin_Stmts := New_List;
end if;
- Build_Finalization_Master
- (Typ => Comp_Typ,
- For_Anonymous => True,
- Context_Scope => Scope (Typ),
- Insertion_Node => Ins_Node);
+ Append_To (Fin_Stmts, Obj_Init);
end if;
end if;
- -- For packed case, default initialization, except if the component type
- -- is itself a packed structure with an initialization procedure, or
- -- initialize/normalize scalars active, and we have a base type, or the
- -- type is public, because in that case a client might specify
- -- Normalize_Scalars and there better be a public Init_Proc for it.
-
- elsif (Present (Init_Proc (Component_Type (Base)))
- and then No (Base_Init_Proc (Base)))
- or else (Init_Or_Norm_Scalars and then Base = Typ)
- or else Is_Public (Typ)
- then
- Build_Array_Init_Proc (Base, N);
- end if;
+ -- Step 3b: Build the abort block (if applicable)
- if Has_Invariants (Component_Type (Base))
- and then Typ = Base
- and then In_Open_Scopes (Scope (Component_Type (Base)))
- then
- -- Generate component invariant checking procedure. This is only
- -- relevant if the array type is within the scope of the component
- -- type. Otherwise an array object can only be built using the public
- -- subprograms for the component type, and calls to those will have
- -- invariant checks. The invariant procedure is only generated for
- -- a base type, not a subtype.
+ -- The abort block is required when aborts are allowed in order to
+ -- protect both initialization calls.
- Insert_Component_Invariant_Checks
- (N, Base, Build_Array_Invariant_Proc (Base, N));
- end if;
- end Expand_Freeze_Array_Type;
+ if Present (Comp_Init) and then Present (Obj_Init) then
+ if Abort_Allowed then
- -----------------------------------
- -- Expand_Freeze_Class_Wide_Type --
- -----------------------------------
+ -- Generate:
+ -- Abort_Defer;
- procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is
- Typ : constant Entity_Id := Entity (N);
- Root : constant Entity_Id := Root_Type (Typ);
+ Prepend_To
+ (Fin_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
- function Is_C_Derivation (Typ : Entity_Id) return Boolean;
- -- Given a type, determine whether it is derived from a C or C++ root
+ -- Generate:
+ -- begin
+ -- Abort_Defer;
+ -- <finalization statements>
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
- ---------------------
- -- Is_C_Derivation --
- ---------------------
+ declare
+ AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
- function Is_C_Derivation (Typ : Entity_Id) return Boolean is
- T : Entity_Id;
+ begin
+ Abrt_HSS :=
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Fin_Stmts,
+ At_End_Proc => New_Occurrence_Of (AUD, Loc));
- begin
- T := Typ;
- loop
- if Is_CPP_Class (T)
- or else Convention (T) = Convention_C
- or else Convention (T) = Convention_CPP
- then
- return True;
- end if;
+ -- Present the Abort_Undefer_Direct function to the backend
+ -- so that it can inline the call to the function.
- exit when T = Etype (T);
+ Add_Inlined_Body (AUD, N);
+ end;
- T := Etype (T);
- end loop;
+ Abrt_Blk :=
+ Make_Block_Statement (Loc,
+ Declarations => No_List,
+ Handled_Statement_Sequence => Abrt_HSS);
- return False;
- end Is_C_Derivation;
+ Add_Block_Identifier (Abrt_Blk, Abrt_Id);
+ Expand_At_End_Handler (Abrt_HSS, Abrt_Id);
- -- Start of processing for Expand_Freeze_Class_Wide_Type
+ Abrt_Stmts := New_List (Abrt_Blk);
- begin
- -- Certain run-time configurations and targets do not provide support
- -- for controlled types.
+ -- Abort is not required
- if Restriction_Active (No_Finalization) then
- return;
+ else
+ -- Generate a dummy entity to ensure that the internal symbols
+ -- are in sync when a unit is compiled with and without aborts.
+ -- The entity is a block with proper scope and type.
- -- Do not create TSS routine Finalize_Address when dispatching calls are
- -- disabled since the core of the routine is a dispatching call.
+ Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
+ Set_Etype (Dummy, Standard_Void_Type);
+ Abrt_Stmts := Fin_Stmts;
+ end if;
- elsif Restriction_Active (No_Dispatching_Calls) then
- return;
+ -- No initialization calls present
- -- Do not create TSS routine Finalize_Address for concurrent class-wide
- -- types. Ignore C, C++, CIL and Java types since it is assumed that the
- -- non-Ada side will handle their destruction.
+ else
+ Abrt_Stmts := Fin_Stmts;
+ end if;
- elsif Is_Concurrent_Type (Root)
- or else Is_C_Derivation (Root)
- or else Convention (Typ) = Convention_CPP
- then
- return;
+ -- Step 4: Insert the whole initialization sequence into the tree
+ -- If the object has a delayed freeze, as will be the case when
+ -- it has aspect specifications, the initialization sequence is
+ -- part of the freeze actions.
- -- Do not create TSS routine Finalize_Address when compiling in CodePeer
- -- mode since the routine contains an Unchecked_Conversion.
+ if Has_Delayed_Freeze (Def_Id) then
+ Append_Freeze_Actions (Def_Id, Abrt_Stmts);
+ else
+ Insert_Actions_After (After, Abrt_Stmts);
+ end if;
+ end Default_Initialize_Object;
- elsif CodePeer_Mode then
- return;
- end if;
+ -------------------------
+ -- Rewrite_As_Renaming --
+ -------------------------
- -- Create the body of TSS primitive Finalize_Address. This automatically
- -- sets the TSS entry for the class-wide type.
+ function Rewrite_As_Renaming return Boolean is
+ begin
+ return not Aliased_Present (N)
+ and then Is_Entity_Name (Expr_Q)
+ and then Ekind (Entity (Expr_Q)) = E_Variable
+ and then OK_To_Rename (Entity (Expr_Q))
+ and then Is_Entity_Name (Obj_Def);
+ end Rewrite_As_Renaming;
- Make_Finalize_Address_Body (Typ);
- end Expand_Freeze_Class_Wide_Type;
+ -- Local variables
- ------------------------------------
- -- Expand_Freeze_Enumeration_Type --
- ------------------------------------
+ Next_N : constant Node_Id := Next (N);
+ Id_Ref : Node_Id;
+ Tag_Assign : Node_Id;
- procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is
- Typ : constant Entity_Id := Entity (N);
- Loc : constant Source_Ptr := Sloc (Typ);
- Ent : Entity_Id;
- Lst : List_Id;
- Num : Nat;
- Arr : Entity_Id;
- Fent : Entity_Id;
- Ityp : Entity_Id;
- Is_Contiguous : Boolean;
- Pos_Expr : Node_Id;
- Last_Repval : Uint;
+ Init_After : Node_Id := N;
+ -- Node after which the initialization actions are to be inserted. This
+ -- is normally N, except for the case of a shared passive variable, in
+ -- which case the init proc call must be inserted only after the bodies
+ -- of the shared variable procedures have been seen.
- Func : Entity_Id;
- pragma Warnings (Off, Func);
+ -- Start of processing for Expand_N_Object_Declaration
begin
- -- Various optimizations possible if given representation is contiguous
+ -- Don't do anything for deferred constants. All proper actions will be
+ -- expanded during the full declaration.
- Is_Contiguous := True;
+ if No (Expr) and Constant_Present (N) then
+ return;
+ end if;
- Ent := First_Literal (Typ);
- Last_Repval := Enumeration_Rep (Ent);
+ -- The type of the object cannot be abstract. This is diagnosed at the
+ -- point the object is frozen, which happens after the declaration is
+ -- fully expanded, so simply return now.
- Next_Literal (Ent);
- while Present (Ent) loop
- if Enumeration_Rep (Ent) - Last_Repval /= 1 then
- Is_Contiguous := False;
- exit;
- else
- Last_Repval := Enumeration_Rep (Ent);
- end if;
+ if Is_Abstract_Type (Typ) then
+ return;
+ end if;
- Next_Literal (Ent);
- end loop;
+ -- First we do special processing for objects of a tagged type where
+ -- this is the point at which the type is frozen. The creation of the
+ -- dispatch table and the initialization procedure have to be deferred
+ -- to this point, since we reference previously declared primitive
+ -- subprograms.
- if Is_Contiguous then
- Set_Has_Contiguous_Rep (Typ);
- Ent := First_Literal (Typ);
- Num := 1;
- Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent)));
+ -- Force construction of dispatch tables of library level tagged types
- else
- -- Build list of literal references
+ if Tagged_Type_Expansion
+ and then Static_Dispatch_Tables
+ and then Is_Library_Level_Entity (Def_Id)
+ and then Is_Library_Level_Tagged_Type (Base_Typ)
+ and then Ekind_In (Base_Typ, E_Record_Type,
+ E_Protected_Type,
+ E_Task_Type)
+ and then not Has_Dispatch_Table (Base_Typ)
+ then
+ declare
+ New_Nodes : List_Id := No_List;
- Lst := New_List;
- Num := 0;
+ begin
+ if Is_Concurrent_Type (Base_Typ) then
+ New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N);
+ else
+ New_Nodes := Make_DT (Base_Typ, N);
+ end if;
- Ent := First_Literal (Typ);
- while Present (Ent) loop
- Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent)));
- Num := Num + 1;
- Next_Literal (Ent);
- end loop;
+ if not Is_Empty_List (New_Nodes) then
+ Insert_List_Before (N, New_Nodes);
+ end if;
+ end;
end if;
- -- Now build an array declaration
+ -- Make shared memory routines for shared passive variable
- -- typA : array (Natural range 0 .. num - 1) of ctype :=
- -- (v, v, v, v, v, ....)
+ if Is_Shared_Passive (Def_Id) then
+ Init_After := Make_Shared_Var_Procs (N);
+ end if;
- -- where ctype is the corresponding integer type. If the representation
- -- is contiguous, we only keep the first literal, which provides the
- -- offset for Pos_To_Rep computations.
+ -- If tasks being declared, make sure we have an activation chain
+ -- defined for the tasks (has no effect if we already have one), and
+ -- also that a Master variable is established and that the appropriate
+ -- enclosing construct is established as a task master.
- Arr :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), 'A'));
+ if Has_Task (Typ) then
+ Build_Activation_Chain_Entity (N);
+ Build_Master_Entity (Def_Id);
+ end if;
- Append_Freeze_Action (Typ,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Arr,
- Constant_Present => True,
+ -- Default initialization required, and no expression present
- Object_Definition =>
- Make_Constrained_Array_Definition (Loc,
- Discrete_Subtype_Definitions => New_List (
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
- Constraint =>
- Make_Range_Constraint (Loc,
- Range_Expression =>
- Make_Range (Loc,
- Low_Bound =>
- Make_Integer_Literal (Loc, 0),
- High_Bound =>
- Make_Integer_Literal (Loc, Num - 1))))),
+ if No (Expr) then
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication => New_Occurrence_Of (Typ, Loc))),
+ -- If we have a type with a variant part, the initialization proc
+ -- will contain implicit tests of the discriminant values, which
+ -- counts as a violation of the restriction No_Implicit_Conditionals.
- Expression =>
- Make_Aggregate (Loc,
- Expressions => Lst)));
+ if Has_Variant_Part (Typ) then
+ declare
+ Msg : Boolean;
- Set_Enum_Pos_To_Rep (Typ, Arr);
+ begin
+ Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def);
- -- Now we build the function that converts representation values to
- -- position values. This function has the form:
+ if Msg then
+ Error_Msg_N
+ ("\initialization of variant record tests discriminants",
+ Obj_Def);
+ return;
+ end if;
+ end;
+ end if;
- -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is
- -- begin
- -- case ityp!(A) is
- -- when enum-lit'Enum_Rep => return posval;
- -- when enum-lit'Enum_Rep => return posval;
- -- ...
- -- when others =>
- -- [raise Constraint_Error when F "invalid data"]
- -- return -1;
- -- end case;
- -- end;
+ -- For the default initialization case, if we have a private type
+ -- with invariants, and invariant checks are enabled, then insert an
+ -- invariant check after the object declaration. Note that it is OK
+ -- to clobber the object with an invalid value since if the exception
+ -- is raised, then the object will go out of scope. In the case where
+ -- an array object is initialized with an aggregate, the expression
+ -- is removed. Check flag Has_Init_Expression to avoid generating a
+ -- junk invariant check and flag No_Initialization to avoid checking
+ -- an uninitialized object such as a compiler temporary used for an
+ -- aggregate.
- -- Note: the F parameter determines whether the others case (no valid
- -- representation) raises Constraint_Error or returns a unique value
- -- of minus one. The latter case is used, e.g. in 'Valid code.
+ if Has_Invariants (Base_Typ)
+ and then Present (Invariant_Procedure (Base_Typ))
+ and then not Has_Init_Expression (N)
+ and then not No_Initialization (N)
+ then
+ -- If entity has an address clause or aspect, make invariant
+ -- call into a freeze action for the explicit freeze node for
+ -- object. Otherwise insert invariant check after declaration.
- -- Note: the reason we use Enum_Rep values in the case here is to avoid
- -- the code generator making inappropriate assumptions about the range
- -- of the values in the case where the value is invalid. ityp is a
- -- signed or unsigned integer type of appropriate width.
+ if Present (Following_Address_Clause (N))
+ or else Has_Aspect (Def_Id, Aspect_Address)
+ then
+ Ensure_Freeze_Node (Def_Id);
+ Set_Has_Delayed_Freeze (Def_Id);
+ Set_Is_Frozen (Def_Id, False);
- -- Note: if exceptions are not supported, then we suppress the raise
- -- and return -1 unconditionally (this is an erroneous program in any
- -- case and there is no obligation to raise Constraint_Error here). We
- -- also do this if pragma Restrictions (No_Exceptions) is active.
+ if not Partial_View_Has_Unknown_Discr (Typ) then
+ Append_Freeze_Action (Def_Id,
+ Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
+ end if;
- -- Is this right??? What about No_Exception_Propagation???
+ elsif not Partial_View_Has_Unknown_Discr (Typ) then
+ Insert_After (N,
+ Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
+ end if;
+ end if;
- -- Representations are signed
+ Default_Initialize_Object (Init_After);
- if Enumeration_Rep (First_Literal (Typ)) < 0 then
+ -- Generate attribute for Persistent_BSS if needed
- -- The underlying type is signed. Reset the Is_Unsigned_Type
- -- explicitly, because it might have been inherited from
- -- parent type.
+ if Persistent_BSS_Mode
+ and then Comes_From_Source (N)
+ and then Is_Potentially_Persistent_Type (Typ)
+ and then not Has_Init_Expression (N)
+ and then Is_Library_Level_Entity (Def_Id)
+ then
+ declare
+ Prag : Node_Id;
+ begin
+ Prag :=
+ Make_Linker_Section_Pragma
+ (Def_Id, Sloc (N), ".persistent.bss");
+ Insert_After (N, Prag);
+ Analyze (Prag);
+ end;
+ end if;
- Set_Is_Unsigned_Type (Typ, False);
+ -- If access type, then we know it is null if not initialized
- if Esize (Typ) <= Standard_Integer_Size then
- Ityp := Standard_Integer;
- else
- Ityp := Universal_Integer;
+ if Is_Access_Type (Typ) then
+ Set_Is_Known_Null (Def_Id);
end if;
- -- Representations are unsigned
+ -- Explicit initialization present
else
- if Esize (Typ) <= Standard_Integer_Size then
- Ityp := RTE (RE_Unsigned);
+ -- Obtain actual expression from qualified expression
+
+ if Nkind (Expr) = N_Qualified_Expression then
+ Expr_Q := Expression (Expr);
else
- Ityp := RTE (RE_Long_Long_Unsigned);
+ Expr_Q := Expr;
end if;
- end if;
- -- The body of the function is a case statement. First collect case
- -- alternatives, or optimize the contiguous case.
+ -- When we have the appropriate type of aggregate in the expression
+ -- (it has been determined during analysis of the aggregate by
+ -- setting the delay flag), let's perform in place assignment and
+ -- thus avoid creating a temporary.
- Lst := New_List;
+ if Is_Delayed_Aggregate (Expr_Q) then
+ Convert_Aggr_In_Object_Decl (N);
- -- If representation is contiguous, Pos is computed by subtracting
- -- the representation of the first literal.
+ -- Ada 2005 (AI-318-02): If the initialization expression is a call
+ -- to a build-in-place function, then access to the declared object
+ -- must be passed to the function. Currently we limit such functions
+ -- to those with constrained limited result subtypes, but eventually
+ -- plan to expand the allowed forms of functions that are treated as
+ -- build-in-place.
- if Is_Contiguous then
- Ent := First_Literal (Typ);
+ elsif Ada_Version >= Ada_2005
+ and then Is_Build_In_Place_Function_Call (Expr_Q)
+ then
+ Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
- if Enumeration_Rep (Ent) = Last_Repval then
+ -- The previous call expands the expression initializing the
+ -- built-in-place object into further code that will be analyzed
+ -- later. No further expansion needed here.
- -- Another special case: for a single literal, Pos is zero
+ return;
- Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
+ -- Ada 2005 (AI-251): Rewrite the expression that initializes a
+ -- class-wide interface object to ensure that we copy the full
+ -- object, unless we are targetting a VM where interfaces are handled
+ -- by VM itself. Note that if the root type of Typ is an ancestor of
+ -- Expr's type, both types share the same dispatch table and there is
+ -- no need to displace the pointer.
- else
- Pos_Expr :=
- Convert_To (Standard_Integer,
- Make_Op_Subtract (Loc,
- Left_Opnd =>
- Unchecked_Convert_To
- (Ityp, Make_Identifier (Loc, Name_uA)),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Intval => Enumeration_Rep (First_Literal (Typ)))));
- end if;
+ elsif Is_Interface (Typ)
- Append_To (Lst,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices => New_List (
- Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
- Low_Bound =>
- Make_Integer_Literal (Loc,
- Intval => Enumeration_Rep (Ent)),
- High_Bound =>
- Make_Integer_Literal (Loc, Intval => Last_Repval))),
+ -- Avoid never-ending recursion because if Equivalent_Type is set
+ -- then we've done it already and must not do it again.
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression => Pos_Expr))));
+ and then not
+ (Nkind (Obj_Def) = N_Identifier
+ and then Present (Equivalent_Type (Entity (Obj_Def))))
+ then
+ pragma Assert (Is_Class_Wide_Type (Typ));
- else
- Ent := First_Literal (Typ);
- while Present (Ent) loop
- Append_To (Lst,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices => New_List (
- Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
- Intval => Enumeration_Rep (Ent))),
+ -- If the object is a return object of an inherently limited type,
+ -- which implies build-in-place treatment, bypass the special
+ -- treatment of class-wide interface initialization below. In this
+ -- case, the expansion of the return statement will take care of
+ -- creating the object (via allocator) and initializing it.
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Integer_Literal (Loc,
- Intval => Enumeration_Pos (Ent))))));
+ if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then
+ null;
- Next_Literal (Ent);
- end loop;
- end if;
+ elsif Tagged_Type_Expansion then
+ declare
+ Iface : constant Entity_Id := Root_Type (Typ);
+ Expr_N : Node_Id := Expr;
+ Expr_Typ : Entity_Id;
+ New_Expr : Node_Id;
+ Obj_Id : Entity_Id;
+ Tag_Comp : Node_Id;
- -- In normal mode, add the others clause with the test
+ begin
+ -- If the original node of the expression was a conversion
+ -- to this specific class-wide interface type then restore
+ -- the original node because we must copy the object before
+ -- displacing the pointer to reference the secondary tag
+ -- component. This code must be kept synchronized with the
+ -- expansion done by routine Expand_Interface_Conversion
- if not No_Exception_Handlers_Set then
- Append_To (Lst,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices => New_List (Make_Others_Choice (Loc)),
- Statements => New_List (
- Make_Raise_Constraint_Error (Loc,
- Condition => Make_Identifier (Loc, Name_uF),
- Reason => CE_Invalid_Data),
- Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Integer_Literal (Loc, -1)))));
+ if not Comes_From_Source (Expr_N)
+ and then Nkind (Expr_N) = N_Explicit_Dereference
+ and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
+ and then Etype (Original_Node (Expr_N)) = Typ
+ then
+ Rewrite (Expr_N, Original_Node (Expression (N)));
+ end if;
- -- If either of the restrictions No_Exceptions_Handlers/Propagation is
- -- active then return -1 (we cannot usefully raise Constraint_Error in
- -- this case). See description above for further details.
+ -- Avoid expansion of redundant interface conversion
- else
- Append_To (Lst,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices => New_List (Make_Others_Choice (Loc)),
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Integer_Literal (Loc, -1)))));
- end if;
+ if Is_Interface (Etype (Expr_N))
+ and then Nkind (Expr_N) = N_Type_Conversion
+ and then Etype (Expr_N) = Typ
+ then
+ Expr_N := Expression (Expr_N);
+ Set_Expression (N, Expr_N);
+ end if;
- -- Now we can build the function body
+ Obj_Id := Make_Temporary (Loc, 'D', Expr_N);
+ Expr_Typ := Base_Type (Etype (Expr_N));
- Fent :=
- Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
+ if Is_Class_Wide_Type (Expr_Typ) then
+ Expr_Typ := Root_Type (Expr_Typ);
+ end if;
- Func :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Fent,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uA),
- Parameter_Type => New_Occurrence_Of (Typ, Loc)),
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uF),
- Parameter_Type =>
- New_Occurrence_Of (Standard_Boolean, Loc))),
+ -- Replace
+ -- CW : I'Class := Obj;
+ -- by
+ -- Tmp : T := Obj;
+ -- type Ityp is not null access I'Class;
+ -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all;
- Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)),
+ if Comes_From_Source (Expr_N)
+ and then Nkind (Expr_N) = N_Identifier
+ and then not Is_Interface (Expr_Typ)
+ and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
+ and then (Expr_Typ = Etype (Expr_Typ)
+ or else not
+ Is_Variable_Size_Record (Etype (Expr_Typ)))
+ then
+ -- Copy the object
- Declarations => Empty_List,
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Obj_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Expr_Typ, Loc),
+ Expression => Relocate_Node (Expr_N)));
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Case_Statement (Loc,
- Expression =>
- Unchecked_Convert_To
- (Ityp, Make_Identifier (Loc, Name_uA)),
- Alternatives => Lst))));
+ -- Statically reference the tag associated with the
+ -- interface
- Set_TSS (Typ, Fent);
+ Tag_Comp :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (Find_Interface_Tag (Expr_Typ, Iface), Loc));
- -- Set Pure flag (it will be reset if the current context is not Pure).
- -- We also pretend there was a pragma Pure_Function so that for purposes
- -- of optimization and constant-folding, we will consider the function
- -- Pure even if we are not in a Pure context).
+ -- Replace
+ -- IW : I'Class := Obj;
+ -- by
+ -- type Equiv_Record is record ... end record;
+ -- implicit subtype CW is <Class_Wide_Subtype>;
+ -- Tmp : CW := CW!(Obj);
+ -- type Ityp is not null access I'Class;
+ -- IW : I'Class renames
+ -- Ityp!(Displace (Temp'Address, I'Tag)).all;
- Set_Is_Pure (Fent);
- Set_Has_Pragma_Pure_Function (Fent);
+ else
+ -- Generate the equivalent record type and update the
+ -- subtype indication to reference it.
- -- Unless we are in -gnatD mode, where we are debugging generated code,
- -- this is an internal entity for which we don't need debug info.
+ Expand_Subtype_From_Expr
+ (N => N,
+ Unc_Type => Typ,
+ Subtype_Indic => Obj_Def,
+ Exp => Expr_N);
- if not Debug_Generated_Code then
- Set_Debug_Info_Off (Fent);
- end if;
+ if not Is_Interface (Etype (Expr_N)) then
+ New_Expr := Relocate_Node (Expr_N);
- exception
- when RE_Not_Available =>
- return;
- end Expand_Freeze_Enumeration_Type;
+ -- For interface types we use 'Address which displaces
+ -- the pointer to the base of the object (if required)
- -------------------------------
- -- Expand_Freeze_Record_Type --
- -------------------------------
+ else
+ New_Expr :=
+ Unchecked_Convert_To (Etype (Obj_Def),
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Expr_N),
+ Attribute_Name => Name_Address))));
+ end if;
- procedure Expand_Freeze_Record_Type (N : Node_Id) is
- Def_Id : constant Node_Id := Entity (N);
- Type_Decl : constant Node_Id := Parent (Def_Id);
- Comp : Entity_Id;
- Comp_Typ : Entity_Id;
- Has_AACC : Boolean;
- Predef_List : List_Id;
+ -- Copy the object
- Renamed_Eq : Node_Id := Empty;
- -- Defining unit name for the predefined equality function in the case
- -- where the type has a primitive operation that is a renaming of
- -- predefined equality (but only if there is also an overriding
- -- user-defined equality function). Used to pass this entity from
- -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
+ if not Is_Limited_Record (Expr_Typ) then
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Obj_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Obj_Def), Loc),
+ Expression => New_Expr));
+
+ -- Rename limited type object since they cannot be copied
+ -- This case occurs when the initialization expression
+ -- has been previously expanded into a temporary object.
+
+ else pragma Assert (not Comes_From_Source (Expr_Q));
+ Insert_Action (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Obj_Id,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Obj_Def), Loc),
+ Name =>
+ Unchecked_Convert_To
+ (Etype (Obj_Def), New_Expr)));
+ end if;
+
+ -- Dynamically reference the tag associated with the
+ -- interface.
+
+ Tag_Comp :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc),
+ Attribute_Name => Name_Address),
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Iface))),
+ Loc)));
+ end if;
+
+ Rewrite (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'D'),
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Name =>
+ Convert_Tag_To_Interface (Typ, Tag_Comp)));
+
+ -- If the original entity comes from source, then mark the
+ -- new entity as needing debug information, even though it's
+ -- defined by a generated renaming that does not come from
+ -- source, so that Materialize_Entity will be set on the
+ -- entity when Debug_Renaming_Declaration is called during
+ -- analysis.
+
+ if Comes_From_Source (Def_Id) then
+ Set_Debug_Info_Needed (Defining_Identifier (N));
+ end if;
+
+ Analyze (N, Suppress => All_Checks);
+
+ -- Replace internal identifier of rewritten node by the
+ -- identifier found in the sources. We also have to exchange
+ -- entities containing their defining identifiers to ensure
+ -- the correct replacement of the object declaration by this
+ -- object renaming declaration because these identifiers
+ -- were previously added by Enter_Name to the current scope.
+ -- We must preserve the homonym chain of the source entity
+ -- as well. We must also preserve the kind of the entity,
+ -- which may be a constant. Preserve entity chain because
+ -- itypes may have been generated already, and the full
+ -- chain must be preserved for final freezing. Finally,
+ -- preserve Comes_From_Source setting, so that debugging
+ -- and cross-referencing information is properly kept, and
+ -- preserve source location, to prevent spurious errors when
+ -- entities are declared (they must have their own Sloc).
+
+ declare
+ New_Id : constant Entity_Id := Defining_Identifier (N);
+ Next_Temp : constant Entity_Id := Next_Entity (New_Id);
+ S_Flag : constant Boolean :=
+ Comes_From_Source (Def_Id);
+
+ begin
+ Set_Next_Entity (New_Id, Next_Entity (Def_Id));
+ Set_Next_Entity (Def_Id, Next_Temp);
+
+ Set_Chars (Defining_Identifier (N), Chars (Def_Id));
+ Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
+ Set_Ekind (Defining_Identifier (N), Ekind (Def_Id));
+ Set_Sloc (Defining_Identifier (N), Sloc (Def_Id));
+
+ Set_Comes_From_Source (Def_Id, False);
+ Exchange_Entities (Defining_Identifier (N), Def_Id);
+ Set_Comes_From_Source (Def_Id, S_Flag);
+ end;
+ end;
+ end if;
+
+ return;
+
+ -- Common case of explicit object initialization
+
+ else
+ -- In most cases, we must check that the initial value meets any
+ -- constraint imposed by the declared type. However, there is one
+ -- very important exception to this rule. If the entity has an
+ -- unconstrained nominal subtype, then it acquired its constraints
+ -- from the expression in the first place, and not only does this
+ -- mean that the constraint check is not needed, but an attempt to
+ -- perform the constraint check can cause order of elaboration
+ -- problems.
+
+ if not Is_Constr_Subt_For_U_Nominal (Typ) then
+
+ -- If this is an allocator for an aggregate that has been
+ -- allocated in place, delay checks until assignments are
+ -- made, because the discriminants are not initialized.
+
+ if Nkind (Expr) = N_Allocator and then No_Initialization (Expr)
+ then
+ null;
+
+ -- Otherwise apply a constraint check now if no prev error
+
+ elsif Nkind (Expr) /= N_Error then
+ Apply_Constraint_Check (Expr, Typ);
+
+ -- Deal with possible range check
+
+ if Do_Range_Check (Expr) then
- Wrapper_Decl_List : List_Id := No_List;
- Wrapper_Body_List : List_Id := No_List;
+ -- If assignment checks are suppressed, turn off flag
- -- Start of processing for Expand_Freeze_Record_Type
+ if Suppress_Assignment_Checks (N) then
+ Set_Do_Range_Check (Expr, False);
- begin
- -- Build discriminant checking functions if not a derived type (for
- -- derived types that are not tagged types, always use the discriminant
- -- checking functions of the parent type). However, for untagged types
- -- the derivation may have taken place before the parent was frozen, so
- -- we copy explicitly the discriminant checking functions from the
- -- parent into the components of the derived type.
+ -- Otherwise generate the range check
- if not Is_Derived_Type (Def_Id)
- or else Has_New_Non_Standard_Rep (Def_Id)
- or else Is_Tagged_Type (Def_Id)
- then
- Build_Discr_Checking_Funcs (Type_Decl);
+ else
+ Generate_Range_Check
+ (Expr, Typ, CE_Range_Check_Failed);
+ end if;
+ end if;
+ end if;
+ end if;
- elsif Is_Derived_Type (Def_Id)
- and then not Is_Tagged_Type (Def_Id)
+ -- If the type is controlled and not inherently limited, then
+ -- the target is adjusted after the copy and attached to the
+ -- finalization list. However, no adjustment is done in the case
+ -- where the object was initialized by a call to a function whose
+ -- result is built in place, since no copy occurred. (Eventually
+ -- we plan to support in-place function results for some cases
+ -- of nonlimited types. ???) Similarly, no adjustment is required
+ -- if we are going to rewrite the object declaration into a
+ -- renaming declaration.
- -- If we have a derived Unchecked_Union, we do not inherit the
- -- discriminant checking functions from the parent type since the
- -- discriminants are non existent.
+ if Needs_Finalization (Typ)
+ and then not Is_Limited_View (Typ)
+ and then not Rewrite_As_Renaming
+ then
+ Insert_Action_After (Init_After,
+ Make_Adjust_Call (
+ Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
+ Typ => Base_Typ));
+ end if;
- and then not Is_Unchecked_Union (Def_Id)
- and then Has_Discriminants (Def_Id)
- then
- declare
- Old_Comp : Entity_Id;
+ -- For tagged types, when an init value is given, the tag has to
+ -- be re-initialized separately in order to avoid the propagation
+ -- of a wrong tag coming from a view conversion unless the type
+ -- is class wide (in this case the tag comes from the init value).
+ -- Suppress the tag assignment when not Tagged_Type_Expansion
+ -- because tags are represented implicitly in objects. Ditto for
+ -- types that are CPP_CLASS, and for initializations that are
+ -- aggregates, because they have to have the right tag.
- begin
- Old_Comp :=
- First_Component (Base_Type (Underlying_Type (Etype (Def_Id))));
- Comp := First_Component (Def_Id);
- while Present (Comp) loop
- if Ekind (Comp) = E_Component
- and then Chars (Comp) = Chars (Old_Comp)
- then
- Set_Discriminant_Checking_Func (Comp,
- Discriminant_Checking_Func (Old_Comp));
- end if;
+ -- The re-assignment of the tag has to be done even if the object
+ -- is a constant. The assignment must be analyzed after the
+ -- declaration. If an address clause follows, this is handled as
+ -- part of the freeze actions for the object, otherwise insert
+ -- tag assignment here.
- Next_Component (Old_Comp);
- Next_Component (Comp);
- end loop;
- end;
- end if;
+ Tag_Assign := Make_Tag_Assignment (N);
- if Is_Derived_Type (Def_Id)
- and then Is_Limited_Type (Def_Id)
- and then Is_Tagged_Type (Def_Id)
- then
- Check_Stream_Attributes (Def_Id);
- end if;
+ if Present (Tag_Assign) then
+ if Present (Following_Address_Clause (N)) then
+ Ensure_Freeze_Node (Def_Id);
- -- Update task, protected, and controlled component flags, because some
- -- of the component types may have been private at the point of the
- -- record declaration. Detect anonymous access-to-controlled components.
+ else
+ Insert_Action_After (Init_After, Tag_Assign);
+ end if;
- Has_AACC := False;
+ -- Handle C++ constructor calls. Note that we do not check that
+ -- Typ is a tagged type since the equivalent Ada type of a C++
+ -- class that has no virtual methods is an untagged limited
+ -- record type.
- Comp := First_Component (Def_Id);
- while Present (Comp) loop
- Comp_Typ := Etype (Comp);
+ elsif Is_CPP_Constructor_Call (Expr) then
- if Has_Task (Comp_Typ) then
- Set_Has_Task (Def_Id);
- end if;
+ -- The call to the initialization procedure does NOT freeze the
+ -- object being initialized.
- if Has_Protected (Comp_Typ) then
- Set_Has_Protected (Def_Id);
- end if;
+ Id_Ref := New_Occurrence_Of (Def_Id, Loc);
+ Set_Must_Not_Freeze (Id_Ref);
+ Set_Assignment_OK (Id_Ref);
- -- Do not set Has_Controlled_Component on a class-wide equivalent
- -- type. See Make_CW_Equivalent_Type.
+ Insert_Actions_After (Init_After,
+ Build_Initialization_Call (Loc, Id_Ref, Typ,
+ Constructor_Ref => Expr));
- if not Is_Class_Wide_Equivalent_Type (Def_Id)
- and then
- (Has_Controlled_Component (Comp_Typ)
- or else (Chars (Comp) /= Name_uParent
- and then (Is_Controlled_Active (Comp_Typ))))
- then
- Set_Has_Controlled_Component (Def_Id);
- end if;
+ -- We remove here the original call to the constructor
+ -- to avoid its management in the backend
- -- Non-self-referential anonymous access-to-controlled component
+ Set_Expression (N, Empty);
+ return;
- if Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Needs_Finalization (Designated_Type (Comp_Typ))
- and then Designated_Type (Comp_Typ) /= Def_Id
- then
- Has_AACC := True;
- end if;
+ -- Handle initialization of limited tagged types
- Next_Component (Comp);
- end loop;
+ elsif Is_Tagged_Type (Typ)
+ and then Is_Class_Wide_Type (Typ)
+ and then Is_Limited_Record (Typ)
+ then
+ -- Given that the type is limited we cannot perform a copy. If
+ -- Expr_Q is the reference to a variable we mark the variable
+ -- as OK_To_Rename to expand this declaration into a renaming
+ -- declaration (see bellow).
- -- Handle constructors of untagged CPP_Class types
+ if Is_Entity_Name (Expr_Q) then
+ Set_OK_To_Rename (Entity (Expr_Q));
- if not Is_Tagged_Type (Def_Id) and then Is_CPP_Class (Def_Id) then
- Set_CPP_Constructors (Def_Id);
- end if;
+ -- If we cannot convert the expression into a renaming we must
+ -- consider it an internal error because the backend does not
+ -- have support to handle it.
- -- Creation of the Dispatch Table. Note that a Dispatch Table is built
- -- for regular tagged types as well as for Ada types deriving from a C++
- -- Class, but not for tagged types directly corresponding to C++ classes
- -- In the later case we assume that it is created in the C++ side and we
- -- just use it.
+ else
+ pragma Assert (False);
+ raise Program_Error;
+ end if;
- if Is_Tagged_Type (Def_Id) then
+ -- For discrete types, set the Is_Known_Valid flag if the
+ -- initializing value is known to be valid. Only do this for
+ -- source assignments, since otherwise we can end up turning
+ -- on the known valid flag prematurely from inserted code.
- -- Add the _Tag component
+ elsif Comes_From_Source (N)
+ and then Is_Discrete_Type (Typ)
+ and then Expr_Known_Valid (Expr)
+ then
+ Set_Is_Known_Valid (Def_Id);
- if Underlying_Type (Etype (Def_Id)) = Def_Id then
- Expand_Tagged_Root (Def_Id);
- end if;
+ elsif Is_Access_Type (Typ) then
- if Is_CPP_Class (Def_Id) then
- Set_All_DT_Position (Def_Id);
+ -- For access types set the Is_Known_Non_Null flag if the
+ -- initializing value is known to be non-null. We can also set
+ -- Can_Never_Be_Null if this is a constant.
- -- Create the tag entities with a minimum decoration
+ if Known_Non_Null (Expr) then
+ Set_Is_Known_Non_Null (Def_Id, True);
- if Tagged_Type_Expansion then
- Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id));
+ if Constant_Present (N) then
+ Set_Can_Never_Be_Null (Def_Id);
+ end if;
+ end if;
end if;
- Set_CPP_Constructors (Def_Id);
-
- else
- if not Building_Static_DT (Def_Id) then
+ -- If validity checking on copies, validate initial expression.
+ -- But skip this if declaration is for a generic type, since it
+ -- makes no sense to validate generic types. Not clear if this
+ -- can happen for legal programs, but it definitely can arise
+ -- from previous instantiation errors.
- -- Usually inherited primitives are not delayed but the first
- -- Ada extension of a CPP_Class is an exception since the
- -- address of the inherited subprogram has to be inserted in
- -- the new Ada Dispatch Table and this is a freezing action.
+ if Validity_Checks_On
+ and then Validity_Check_Copies
+ and then not Is_Generic_Type (Etype (Def_Id))
+ then
+ Ensure_Valid (Expr);
+ Set_Is_Known_Valid (Def_Id);
+ end if;
+ end if;
- -- Similarly, if this is an inherited operation whose parent is
- -- not frozen yet, it is not in the DT of the parent, and we
- -- generate an explicit freeze node for the inherited operation
- -- so it is properly inserted in the DT of the current type.
+ -- Cases where the back end cannot handle the initialization directly
+ -- In such cases, we expand an assignment that will be appropriately
+ -- handled by Expand_N_Assignment_Statement.
- declare
- Elmt : Elmt_Id;
- Subp : Entity_Id;
+ -- The exclusion of the unconstrained case is wrong, but for now it
+ -- is too much trouble ???
- begin
- Elmt := First_Elmt (Primitive_Operations (Def_Id));
- while Present (Elmt) loop
- Subp := Node (Elmt);
+ if (Is_Possibly_Unaligned_Slice (Expr)
+ or else (Is_Possibly_Unaligned_Object (Expr)
+ and then not Represented_As_Scalar (Etype (Expr))))
+ and then not (Is_Array_Type (Etype (Expr))
+ and then not Is_Constrained (Etype (Expr)))
+ then
+ declare
+ Stat : constant Node_Id :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Def_Id, Loc),
+ Expression => Relocate_Node (Expr));
+ begin
+ Set_Expression (N, Empty);
+ Set_No_Initialization (N);
+ Set_Assignment_OK (Name (Stat));
+ Set_No_Ctrl_Actions (Stat);
+ Insert_After_And_Analyze (Init_After, Stat);
+ end;
+ end if;
- if Present (Alias (Subp)) then
- if Is_CPP_Class (Etype (Def_Id)) then
- Set_Has_Delayed_Freeze (Subp);
+ -- Final transformation, if the initializing expression is an entity
+ -- for a variable with OK_To_Rename set, then we transform:
- elsif Has_Delayed_Freeze (Alias (Subp))
- and then not Is_Frozen (Alias (Subp))
- then
- Set_Is_Frozen (Subp, False);
- Set_Has_Delayed_Freeze (Subp);
- end if;
- end if;
+ -- X : typ := expr;
- Next_Elmt (Elmt);
- end loop;
- end;
- end if;
+ -- into
- -- Unfreeze momentarily the type to add the predefined primitives
- -- operations. The reason we unfreeze is so that these predefined
- -- operations will indeed end up as primitive operations (which
- -- must be before the freeze point).
+ -- X : typ renames expr
- Set_Is_Frozen (Def_Id, False);
+ -- provided that X is not aliased. The aliased case has to be
+ -- excluded in general because Expr will not be aliased in general.
- -- Do not add the spec of predefined primitives in case of
- -- CPP tagged type derivations that have convention CPP.
+ if Rewrite_As_Renaming then
+ Rewrite (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Defining_Identifier (N),
+ Subtype_Mark => Obj_Def,
+ Name => Expr_Q));
- if Is_CPP_Class (Root_Type (Def_Id))
- and then Convention (Def_Id) = Convention_CPP
- then
- null;
+ -- We do not analyze this renaming declaration, because all its
+ -- components have already been analyzed, and if we were to go
+ -- ahead and analyze it, we would in effect be trying to generate
+ -- another declaration of X, which won't do.
- -- Do not add the spec of the predefined primitives if we are
- -- compiling under restriction No_Dispatching_Calls.
+ Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
+ Set_Analyzed (N);
- elsif not Restriction_Active (No_Dispatching_Calls) then
- Make_Predefined_Primitive_Specs
- (Def_Id, Predef_List, Renamed_Eq);
- Insert_List_Before_And_Analyze (N, Predef_List);
- end if;
+ -- We do need to deal with debug issues for this renaming
- -- Ada 2005 (AI-391): For a nonabstract null extension, create
- -- wrapper functions for each nonoverridden inherited function
- -- with a controlling result of the type. The wrapper for such
- -- a function returns an extension aggregate that invokes the
- -- parent function.
+ -- First, if entity comes from source, then mark it as needing
+ -- debug information, even though it is defined by a generated
+ -- renaming that does not come from source.
- if Ada_Version >= Ada_2005
- and then not Is_Abstract_Type (Def_Id)
- and then Is_Null_Extension (Def_Id)
- then
- Make_Controlling_Function_Wrappers
- (Def_Id, Wrapper_Decl_List, Wrapper_Body_List);
- Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
+ if Comes_From_Source (Defining_Identifier (N)) then
+ Set_Debug_Info_Needed (Defining_Identifier (N));
end if;
- -- Ada 2005 (AI-251): For a nonabstract type extension, build
- -- null procedure declarations for each set of homographic null
- -- procedures that are inherited from interface types but not
- -- overridden. This is done to ensure that the dispatch table
- -- entry associated with such null primitives are properly filled.
+ -- Now call the routine to generate debug info for the renaming
- if Ada_Version >= Ada_2005
- and then Etype (Def_Id) /= Def_Id
- and then not Is_Abstract_Type (Def_Id)
- and then Has_Interfaces (Def_Id)
- then
- Insert_Actions (N, Make_Null_Procedure_Specs (Def_Id));
- end if;
+ declare
+ Decl : constant Node_Id := Debug_Renaming_Declaration (N);
+ begin
+ if Present (Decl) then
+ Insert_Action (N, Decl);
+ end if;
+ end;
+ end if;
+ end if;
- Set_Is_Frozen (Def_Id);
- if not Is_Derived_Type (Def_Id)
- or else Is_Tagged_Type (Etype (Def_Id))
- then
- Set_All_DT_Position (Def_Id);
+ if Nkind (N) = N_Object_Declaration
+ and then Nkind (Obj_Def) = N_Access_Definition
+ and then not Is_Local_Anonymous_Access (Etype (Def_Id))
+ then
+ -- An Ada 2012 stand-alone object of an anonymous access type
- -- If this is a type derived from an untagged private type whose
- -- full view is tagged, the type is marked tagged for layout
- -- reasons, but it has no dispatch table.
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
- elsif Is_Derived_Type (Def_Id)
- and then Is_Private_Type (Etype (Def_Id))
- and then not Is_Tagged_Type (Etype (Def_Id))
- then
- return;
- end if;
+ Level : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc (N),
+ Chars =>
+ New_External_Name (Chars (Def_Id), Suffix => "L"));
- -- Create and decorate the tags. Suppress their creation when
- -- not Tagged_Type_Expansion because the dispatching mechanism is
- -- handled internally by the virtual target.
+ Level_Expr : Node_Id;
+ Level_Decl : Node_Id;
- if Tagged_Type_Expansion then
- Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id));
+ begin
+ Set_Ekind (Level, Ekind (Def_Id));
+ Set_Etype (Level, Standard_Natural);
+ Set_Scope (Level, Scope (Def_Id));
- -- Generate dispatch table of locally defined tagged type.
- -- Dispatch tables of library level tagged types are built
- -- later (see Analyze_Declarations).
+ if No (Expr) then
- if not Building_Static_DT (Def_Id) then
- Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
- end if;
- end if;
+ -- Set accessibility level of null
- -- If the type has unknown discriminants, propagate dispatching
- -- information to its underlying record view, which does not get
- -- its own dispatch table.
+ Level_Expr :=
+ Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
- if Is_Derived_Type (Def_Id)
- and then Has_Unknown_Discriminants (Def_Id)
- and then Present (Underlying_Record_View (Def_Id))
- then
- declare
- Rep : constant Entity_Id := Underlying_Record_View (Def_Id);
- begin
- Set_Access_Disp_Table
- (Rep, Access_Disp_Table (Def_Id));
- Set_Dispatch_Table_Wrappers
- (Rep, Dispatch_Table_Wrappers (Def_Id));
- Set_Direct_Primitive_Operations
- (Rep, Direct_Primitive_Operations (Def_Id));
- end;
+ else
+ Level_Expr := Dynamic_Accessibility_Level (Expr);
end if;
- -- Make sure that the primitives Initialize, Adjust and Finalize
- -- are Frozen before other TSS subprograms. We don't want them
- -- Frozen inside.
-
- if Is_Controlled (Def_Id) then
- if not Is_Limited_Type (Def_Id) then
- Append_Freeze_Actions (Def_Id,
- Freeze_Entity
- (Find_Prim_Op (Def_Id, Name_Adjust), Def_Id));
- end if;
+ Level_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Level,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Expression => Level_Expr,
+ Constant_Present => Constant_Present (N),
+ Has_Init_Expression => True);
- Append_Freeze_Actions (Def_Id,
- Freeze_Entity
- (Find_Prim_Op (Def_Id, Name_Initialize), Def_Id));
+ Insert_Action_After (Init_After, Level_Decl);
- Append_Freeze_Actions (Def_Id,
- Freeze_Entity
- (Find_Prim_Op (Def_Id, Name_Finalize), Def_Id));
- end if;
+ Set_Extra_Accessibility (Def_Id, Level);
+ end;
+ end if;
- -- Freeze rest of primitive operations. There is no need to handle
- -- the predefined primitives if we are compiling under restriction
- -- No_Dispatching_Calls.
+ -- If the object is default initialized and its type is subject to
+ -- pragma Default_Initial_Condition, add a runtime check to verify
+ -- the assumption of the pragma (SPARK RM 7.3.3). Generate:
- if not Restriction_Active (No_Dispatching_Calls) then
- Append_Freeze_Actions
- (Def_Id, Predefined_Primitive_Freeze (Def_Id));
- end if;
- end if;
+ -- <Base_Typ>Default_Init_Cond (<Base_Typ> (Def_Id));
- -- In the untagged case, ever since Ada 83 an equality function must
- -- be provided for variant records that are not unchecked unions.
- -- In Ada 2012 the equality function composes, and thus must be built
- -- explicitly just as for tagged records.
+ -- Note that the check is generated for source objects only
- elsif Has_Discriminants (Def_Id)
- and then not Is_Limited_Type (Def_Id)
+ if Comes_From_Source (Def_Id)
+ and then (Has_Default_Init_Cond (Typ)
+ or else
+ Has_Inherited_Default_Init_Cond (Typ))
+ and then not Has_Init_Expression (N)
then
declare
- Comps : constant Node_Id :=
- Component_List (Type_Definition (Type_Decl));
+ DIC_Call : constant Node_Id :=
+ Build_Default_Init_Cond_Call (Loc, Def_Id, Typ);
begin
- if Present (Comps)
- and then Present (Variant_Part (Comps))
- then
- Build_Variant_Record_Equality (Def_Id);
- end if;
- end;
-
- -- Otherwise create primitive equality operation (AI05-0123)
+ if Present (Next_N) then
+ Insert_Before_And_Analyze (Next_N, DIC_Call);
- -- This is done unconditionally to ensure that tools can be linked
- -- properly with user programs compiled with older language versions.
- -- In addition, this is needed because "=" composes for bounded strings
- -- in all language versions (see Exp_Ch4.Expand_Composite_Equality).
+ -- The object declaration is the last node in a declarative or a
+ -- statement list.
- elsif Comes_From_Source (Def_Id)
- and then Convention (Def_Id) = Convention_Ada
- and then not Is_Limited_Type (Def_Id)
- then
- Build_Untagged_Equality (Def_Id);
+ else
+ Append_To (List_Containing (N), DIC_Call);
+ Analyze (DIC_Call);
+ end if;
+ end;
end if;
- -- Before building the record initialization procedure, if we are
- -- dealing with a concurrent record value type, then we must go through
- -- the discriminants, exchanging discriminals between the concurrent
- -- type and the concurrent record value type. See the section "Handling
- -- of Discriminants" in the Einfo spec for details.
+ -- Exception on library entity not available
- if Is_Concurrent_Record_Type (Def_Id)
- and then Has_Discriminants (Def_Id)
- then
- declare
- Ctyp : constant Entity_Id :=
- Corresponding_Concurrent_Type (Def_Id);
- Conc_Discr : Entity_Id;
- Rec_Discr : Entity_Id;
- Temp : Entity_Id;
+ exception
+ when RE_Not_Available =>
+ return;
+ end Expand_N_Object_Declaration;
- begin
- Conc_Discr := First_Discriminant (Ctyp);
- Rec_Discr := First_Discriminant (Def_Id);
- while Present (Conc_Discr) loop
- Temp := Discriminal (Conc_Discr);
- Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr));
- Set_Discriminal (Rec_Discr, Temp);
+ ---------------------------------
+ -- Expand_N_Subtype_Indication --
+ ---------------------------------
- Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr);
- Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr);
+ -- Add a check on the range of the subtype. The static case is partially
+ -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need
+ -- to check here for the static case in order to avoid generating
+ -- extraneous expanded code. Also deal with validity checking.
- Next_Discriminant (Conc_Discr);
- Next_Discriminant (Rec_Discr);
- end loop;
- end;
- end if;
+ procedure Expand_N_Subtype_Indication (N : Node_Id) is
+ Ran : constant Node_Id := Range_Expression (Constraint (N));
+ Typ : constant Entity_Id := Entity (Subtype_Mark (N));
- if Has_Controlled_Component (Def_Id) then
- Build_Controlling_Procs (Def_Id);
+ begin
+ if Nkind (Constraint (N)) = N_Range_Constraint then
+ Validity_Check_Range (Range_Expression (Constraint (N)));
end if;
- Adjust_Discriminants (Def_Id);
+ if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then
+ Apply_Range_Check (Ran, Typ);
+ end if;
+ end Expand_N_Subtype_Indication;
- if Tagged_Type_Expansion or else not Is_Interface (Def_Id) then
+ ---------------------------
+ -- Expand_N_Variant_Part --
+ ---------------------------
- -- Do not need init for interfaces on virtual targets since they're
- -- abstract.
+ -- Note: this procedure no longer has any effect. It used to be that we
+ -- would replace the choices in the last variant by a when others, and
+ -- also expanded static predicates in variant choices here, but both of
+ -- those activities were being done too early, since we can't check the
+ -- choices until the statically predicated subtypes are frozen, which can
+ -- happen as late as the free point of the record, and we can't change the
+ -- last choice to an others before checking the choices, which is now done
+ -- at the freeze point of the record.
- Build_Record_Init_Proc (Type_Decl, Def_Id);
- end if;
+ procedure Expand_N_Variant_Part (N : Node_Id) is
+ begin
+ null;
+ end Expand_N_Variant_Part;
- -- For tagged type that are not interfaces, build bodies of primitive
- -- operations. Note: do this after building the record initialization
- -- procedure, since the primitive operations may need the initialization
- -- routine. There is no need to add predefined primitives of interfaces
- -- because all their predefined primitives are abstract.
+ ---------------------------------
+ -- Expand_Previous_Access_Type --
+ ---------------------------------
- if Is_Tagged_Type (Def_Id) and then not Is_Interface (Def_Id) then
+ procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is
+ Ptr_Typ : Entity_Id;
- -- Do not add the body of predefined primitives in case of CPP tagged
- -- type derivations that have convention CPP.
+ begin
+ -- Find all access types in the current scope whose designated type is
+ -- Def_Id and build master renamings for them.
- if Is_CPP_Class (Root_Type (Def_Id))
- and then Convention (Def_Id) = Convention_CPP
+ Ptr_Typ := First_Entity (Current_Scope);
+ while Present (Ptr_Typ) loop
+ if Is_Access_Type (Ptr_Typ)
+ and then Designated_Type (Ptr_Typ) = Def_Id
+ and then No (Master_Id (Ptr_Typ))
then
- null;
+ -- Ensure that the designated type has a master
- -- Do not add the body of the predefined primitives if we are
- -- compiling under restriction No_Dispatching_Calls or if we are
- -- compiling a CPP tagged type.
+ Build_Master_Entity (Def_Id);
+
+ -- Private and incomplete types complicate the insertion of master
+ -- renamings because the access type may precede the full view of
+ -- the designated type. For this reason, the master renamings are
+ -- inserted relative to the designated type.
+
+ Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id));
+ end if;
- elsif not Restriction_Active (No_Dispatching_Calls) then
+ Next_Entity (Ptr_Typ);
+ end loop;
+ end Expand_Previous_Access_Type;
- -- Create the body of TSS primitive Finalize_Address. This must
- -- be done before the bodies of all predefined primitives are
- -- created. If Def_Id is limited, Stream_Input and Stream_Read
- -- may produce build-in-place allocations and for those the
- -- expander needs Finalize_Address.
+ -----------------------------
+ -- Expand_Record_Extension --
+ -----------------------------
- Make_Finalize_Address_Body (Def_Id);
- Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
- Append_Freeze_Actions (Def_Id, Predef_List);
- end if;
+ -- Add a field _parent at the beginning of the record extension. This is
+ -- used to implement inheritance. Here are some examples of expansion:
- -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
- -- inherited functions, then add their bodies to the freeze actions.
+ -- 1. no discriminants
+ -- type T2 is new T1 with null record;
+ -- gives
+ -- type T2 is new T1 with record
+ -- _Parent : T1;
+ -- end record;
- if Present (Wrapper_Body_List) then
- Append_Freeze_Actions (Def_Id, Wrapper_Body_List);
- end if;
+ -- 2. renamed discriminants
+ -- type T2 (B, C : Int) is new T1 (A => B) with record
+ -- _Parent : T1 (A => B);
+ -- D : Int;
+ -- end;
- -- Create extra formals for the primitive operations of the type.
- -- This must be done before analyzing the body of the initialization
- -- procedure, because a self-referential type might call one of these
- -- primitives in the body of the init_proc itself.
+ -- 3. inherited discriminants
+ -- type T2 is new T1 with record -- discriminant A inherited
+ -- _Parent : T1 (A);
+ -- D : Int;
+ -- end;
- declare
- Elmt : Elmt_Id;
- Subp : Entity_Id;
+ procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is
+ Indic : constant Node_Id := Subtype_Indication (Def);
+ Loc : constant Source_Ptr := Sloc (Def);
+ Rec_Ext_Part : Node_Id := Record_Extension_Part (Def);
+ Par_Subtype : Entity_Id;
+ Comp_List : Node_Id;
+ Comp_Decl : Node_Id;
+ Parent_N : Node_Id;
+ D : Entity_Id;
+ List_Constr : constant List_Id := New_List;
- begin
- Elmt := First_Elmt (Primitive_Operations (Def_Id));
- while Present (Elmt) loop
- Subp := Node (Elmt);
- if not Has_Foreign_Convention (Subp)
- and then not Is_Predefined_Dispatching_Operation (Subp)
- then
- Create_Extra_Formals (Subp);
- end if;
+ begin
+ -- Expand_Record_Extension is called directly from the semantics, so
+ -- we must check to see whether expansion is active before proceeding,
+ -- because this affects the visibility of selected components in bodies
+ -- of instances.
- Next_Elmt (Elmt);
- end loop;
- end;
+ if not Expander_Active then
+ return;
end if;
- -- Create a heterogeneous finalization master to service the anonymous
- -- access-to-controlled components of the record type.
-
- if Has_AACC then
- declare
- Encl_Scope : constant Entity_Id := Scope (Def_Id);
- Ins_Node : constant Node_Id := Parent (Def_Id);
- Loc : constant Source_Ptr := Sloc (Def_Id);
- Fin_Mas_Id : Entity_Id;
+ -- This may be a derivation of an untagged private type whose full
+ -- view is tagged, in which case the Derived_Type_Definition has no
+ -- extension part. Build an empty one now.
- Attributes_Set : Boolean := False;
- Master_Built : Boolean := False;
- -- Two flags which control the creation and initialization of a
- -- common heterogeneous master.
+ if No (Rec_Ext_Part) then
+ Rec_Ext_Part :=
+ Make_Record_Definition (Loc,
+ End_Label => Empty,
+ Component_List => Empty,
+ Null_Present => True);
- begin
- Comp := First_Component (Def_Id);
- while Present (Comp) loop
- Comp_Typ := Etype (Comp);
+ Set_Record_Extension_Part (Def, Rec_Ext_Part);
+ Mark_Rewrite_Insertion (Rec_Ext_Part);
+ end if;
- -- A non-self-referential anonymous access-to-controlled
- -- component.
+ Comp_List := Component_List (Rec_Ext_Part);
- if Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Needs_Finalization (Designated_Type (Comp_Typ))
- and then Designated_Type (Comp_Typ) /= Def_Id
- then
- -- Build a homogeneous master for the first anonymous
- -- access-to-controlled component. This master may be
- -- converted into a heterogeneous collection if more
- -- components are to follow.
+ Parent_N := Make_Defining_Identifier (Loc, Name_uParent);
- if not Master_Built then
- Master_Built := True;
+ -- If the derived type inherits its discriminants the type of the
+ -- _parent field must be constrained by the inherited discriminants
- -- All anonymous access-to-controlled types allocate
- -- on the global pool. Note that the finalization
- -- master and the associated storage pool must be set
- -- on the root type (both are "root type only").
+ if Has_Discriminants (T)
+ and then Nkind (Indic) /= N_Subtype_Indication
+ and then not Is_Constrained (Entity (Indic))
+ then
+ D := First_Discriminant (T);
+ while Present (D) loop
+ Append_To (List_Constr, New_Occurrence_Of (D, Loc));
+ Next_Discriminant (D);
+ end loop;
- Set_Associated_Storage_Pool
- (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
+ Par_Subtype :=
+ Process_Subtype (
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => List_Constr)),
+ Def);
- Build_Finalization_Master
- (Typ => Root_Type (Comp_Typ),
- For_Anonymous => True,
- Context_Scope => Encl_Scope,
- Insertion_Node => Ins_Node);
+ -- Otherwise the original subtype_indication is just what is needed
- Fin_Mas_Id := Finalization_Master (Comp_Typ);
+ else
+ Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def);
+ end if;
- -- Subsequent anonymous access-to-controlled components
- -- reuse the available master.
+ Set_Parent_Subtype (T, Par_Subtype);
- else
- -- All anonymous access-to-controlled types allocate
- -- on the global pool. Note that both the finalization
- -- master and the associated storage pool must be set
- -- on the root type (both are "root type only").
+ Comp_Decl :=
+ Make_Component_Declaration (Loc,
+ Defining_Identifier => Parent_N,
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc)));
- Set_Associated_Storage_Pool
- (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
+ if Null_Present (Rec_Ext_Part) then
+ Set_Component_List (Rec_Ext_Part,
+ Make_Component_List (Loc,
+ Component_Items => New_List (Comp_Decl),
+ Variant_Part => Empty,
+ Null_Present => False));
+ Set_Null_Present (Rec_Ext_Part, False);
- -- Shared the master among multiple components
+ elsif Null_Present (Comp_List)
+ or else Is_Empty_List (Component_Items (Comp_List))
+ then
+ Set_Component_Items (Comp_List, New_List (Comp_Decl));
+ Set_Null_Present (Comp_List, False);
- Set_Finalization_Master
- (Root_Type (Comp_Typ), Fin_Mas_Id);
+ else
+ Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
+ end if;
- -- Convert the master into a heterogeneous collection.
- -- Generate:
- -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
+ Analyze (Comp_Decl);
+ end Expand_Record_Extension;
- if not Attributes_Set then
- Attributes_Set := True;
+ ------------------------
+ -- Expand_Tagged_Root --
+ ------------------------
- Insert_Action (Ins_Node,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_Set_Is_Heterogeneous), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Fin_Mas_Id, Loc))));
- end if;
- end if;
- end if;
+ procedure Expand_Tagged_Root (T : Entity_Id) is
+ Def : constant Node_Id := Type_Definition (Parent (T));
+ Comp_List : Node_Id;
+ Comp_Decl : Node_Id;
+ Sloc_N : Source_Ptr;
- Next_Component (Comp);
- end loop;
- end;
+ begin
+ if Null_Present (Def) then
+ Set_Component_List (Def,
+ Make_Component_List (Sloc (Def),
+ Component_Items => Empty_List,
+ Variant_Part => Empty,
+ Null_Present => True));
end if;
- -- Check whether individual components have a defined invariant, and add
- -- the corresponding component invariant checks.
+ Comp_List := Component_List (Def);
- -- Do not create an invariant procedure for some internally generated
- -- subtypes, in particular those created for objects of a class-wide
- -- type. Such types may have components to which invariant apply, but
- -- the corresponding checks will be applied when an object of the parent
- -- type is constructed.
+ if Null_Present (Comp_List)
+ or else Is_Empty_List (Component_Items (Comp_List))
+ then
+ Sloc_N := Sloc (Comp_List);
+ else
+ Sloc_N := Sloc (First (Component_Items (Comp_List)));
+ end if;
- -- Such objects will show up in a class-wide postcondition, and the
- -- invariant will be checked, if necessary, upon return from the
- -- enclosing subprogram.
+ Comp_Decl :=
+ Make_Component_Declaration (Sloc_N,
+ Defining_Identifier => First_Tag_Component (T),
+ Component_Definition =>
+ Make_Component_Definition (Sloc_N,
+ Aliased_Present => False,
+ Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N)));
- if not Is_Class_Wide_Equivalent_Type (Def_Id) then
- Insert_Component_Invariant_Checks
- (N, Def_Id, Build_Record_Invariant_Proc (Def_Id, N));
+ if Null_Present (Comp_List)
+ or else Is_Empty_List (Component_Items (Comp_List))
+ then
+ Set_Component_Items (Comp_List, New_List (Comp_Decl));
+ Set_Null_Present (Comp_List, False);
+
+ else
+ Insert_Before (First (Component_Items (Comp_List)), Comp_Decl);
end if;
- end Expand_Freeze_Record_Type;
+
+ -- We don't Analyze the whole expansion because the tag component has
+ -- already been analyzed previously. Here we just insure that the tree
+ -- is coherent with the semantic decoration
+
+ Find_Type (Subtype_Indication (Component_Definition (Comp_Decl)));
+
+ exception
+ when RE_Not_Available =>
+ return;
+ end Expand_Tagged_Root;
------------------------------
-- Freeze_Stream_Operations --
projects / platform / upstream / linaro-gcc.git / commitdiff