-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Needs a more complete spec--what are the parameters exactly, and what
-- exactly is the returned value, and how is Bound affected???
- procedure Build_Itype_Reference
- (Ityp : Entity_Id;
- Nod : Node_Id);
- -- Create a reference to an internal type, for use by Gigi. The back-end
- -- elaborates itypes on demand, i.e. when their first use is seen. This
- -- can lead to scope anomalies if the first use is within a scope that is
- -- nested within the scope that contains the point of definition of the
- -- itype. The Itype_Reference node forces the elaboration of the itype
- -- in the proper scope. The node is inserted after Nod, which is the
- -- enclosing declaration that generated Ityp.
- --
- -- A related mechanism is used during expansion, for itypes created in
- -- branches of conditionals. See Ensure_Defined in exp_util.
- -- Could both mechanisms be merged ???
-
procedure Build_Underlying_Full_View
(N : Node_Id;
Typ : Entity_Id;
function Is_Progenitor
(Iface : Entity_Id;
- Typ : Entity_Id) return Boolean;
- -- Determine whether type Typ implements interface Iface. This requires
+ Typ : Entity_Id) return Boolean;
+ -- Determine whether the interface Iface is implemented by Typ. It requires
-- traversing the list of abstract interfaces of the type, as well as that
-- of the ancestor types. The predicate is used to determine when a formal
-- in the signature of an inherited operation must carry the derived type.
-- is associated with one of the protected operations, and must
-- be available in the scope that encloses the protected declaration.
-- Otherwise the type is in the scope enclosing the subprogram.
+
-- If the function has formals, The return type of a subprogram
-- declaration is analyzed in the scope of the subprogram (see
-- Process_Formals) and thus the protected type, if present, is
Desig_Type := Entity (Subtype_Mark (N));
Set_Directly_Designated_Type
- (Anon_Type, Desig_Type);
- Set_Etype (Anon_Type, Anon_Type);
+ (Anon_Type, Desig_Type);
+ Set_Etype (Anon_Type, Anon_Type);
-- Make sure the anonymous access type has size and alignment fields
-- set, as required by gigi. This is necessary in the case of the
Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
- -- Ada 2005 (AI-50217): Propagate the attribute that indicates that the
- -- designated type comes from the limited view.
-
- Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
-
-- Ada 2005 (AI-231): Propagate the access-constant attribute
Set_Is_Access_Constant (Anon_Type, Constant_Present (N));
Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod)));
-- Similarly, if the access definition is the return result of a
- -- function, create an itype reference for it because it
- -- will be used within the function body. For a regular function that
- -- is not a compilation unit, insert reference after the declaration.
- -- For a protected operation, insert it after the enclosing protected
- -- type declaration. In either case, do not create a reference for a
- -- type obtained through a limited_with clause, because this would
- -- introduce semantic dependencies.
+ -- function, create an itype reference for it because it will be used
+ -- within the function body. For a regular function that is not a
+ -- compilation unit, insert reference after the declaration. For a
+ -- protected operation, insert it after the enclosing protected type
+ -- declaration. In either case, do not create a reference for a type
+ -- obtained through a limited_with clause, because this would introduce
+ -- semantic dependencies.
+
+ -- Similarly, do not create a reference if the designated type is a
+ -- generic formal, because no use of it will reach the backend.
elsif Nkind (Related_Nod) = N_Function_Specification
- and then not From_With_Type (Anon_Type)
+ and then not From_With_Type (Desig_Type)
+ and then not Is_Generic_Type (Desig_Type)
then
if Present (Enclosing_Prot_Type) then
Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type));
Build_Itype_Reference (Anon_Type, Parent (Related_Nod));
end if;
- -- Finally, create an itype reference for an object declaration of
- -- an anonymous access type. This is strictly necessary only for
- -- deferred constants, but in any case will avoid out-of-scope
- -- problems in the back-end.
+ -- Finally, create an itype reference for an object declaration of an
+ -- anonymous access type. This is strictly necessary only for deferred
+ -- constants, but in any case will avoid out-of-scope problems in the
+ -- back-end.
elsif Nkind (Related_Nod) = N_Object_Declaration then
Build_Itype_Reference (Anon_Type, Related_Nod);
is
procedure Check_For_Premature_Usage (Def : Node_Id);
- -- Check that type T_Name is not used, directly or recursively,
- -- as a parameter or a return type in Def. Def is either a subtype,
- -- an access_definition, or an access_to_subprogram_definition.
+ -- Check that type T_Name is not used, directly or recursively, as a
+ -- parameter or a return type in Def. Def is either a subtype, an
+ -- access_definition, or an access_to_subprogram_definition.
-------------------------------
-- Check_For_Premature_Usage --
(T => Typ,
Related_Nod => T_Def,
Scope_Id => Current_Scope));
+
else
+ if From_With_Type (Typ) then
+ Error_Msg_NE
+ ("illegal use of incomplete type&",
+ Result_Definition (T_Def), Typ);
+
+ elsif Ekind (Current_Scope) = E_Package
+ and then In_Private_Part (Current_Scope)
+ then
+ if Ekind (Typ) = E_Incomplete_Type then
+ Append_Elmt (Desig_Type, Private_Dependents (Typ));
+
+ elsif Is_Class_Wide_Type (Typ)
+ and then Ekind (Etype (Typ)) = E_Incomplete_Type
+ then
+ Append_Elmt
+ (Desig_Type, Private_Dependents (Etype (Typ)));
+ end if;
+ end if;
+
Set_Etype (Desig_Type, Typ);
end if;
end;
procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is
S : constant Node_Id := Subtype_Indication (Def);
P : constant Node_Id := Parent (Def);
-
- Desig : Entity_Id;
- -- Designated type
-
begin
-- Check for permissible use of incomplete type
Init_Size_Align (T);
end if;
- Desig := Designated_Type (T);
-
- -- If designated type is an imported tagged type, indicate that the
- -- access type is also imported, and therefore restricted in its use.
- -- The access type may already be imported, so keep setting otherwise.
-
- -- Ada 2005 (AI-50217): If the non-limited view of the designated type
- -- is available, use it as the designated type of the access type, so
- -- that the back-end gets a usable entity.
-
- if From_With_Type (Desig)
- and then Ekind (Desig) /= E_Access_Type
- then
- Set_From_With_Type (T);
- end if;
-
-- Note that Has_Task is always false, since the access type itself
-- is not a task type. See Einfo for more description on this point.
-- Exactly the same consideration applies to Has_Controlled_Component.
end if;
end Add_Interface_Tag_Components;
+ -------------------------------------
+ -- Add_Internal_Interface_Entities --
+ -------------------------------------
+
+ procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is
+ Elmt : Elmt_Id;
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface_Prim : Entity_Id;
+ Ifaces_List : Elist_Id;
+ New_Subp : Entity_Id := Empty;
+ Prim : Entity_Id;
+
+ begin
+ pragma Assert (Ada_Version >= Ada_05
+ and then Is_Record_Type (Tagged_Type)
+ and then Is_Tagged_Type (Tagged_Type)
+ and then Has_Interfaces (Tagged_Type)
+ and then not Is_Interface (Tagged_Type));
+
+ Collect_Interfaces (Tagged_Type, Ifaces_List);
+
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ -- Exclude from this processing interfaces that are parents of
+ -- Tagged_Type because their primitives are located in the primary
+ -- dispatch table (and hence no auxiliary internal entities are
+ -- required to handle secondary dispatch tables in such case).
+
+ if not Is_Ancestor (Iface, Tagged_Type) then
+ Elmt := First_Elmt (Primitive_Operations (Iface));
+ while Present (Elmt) loop
+ Iface_Prim := Node (Elmt);
+
+ if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
+ Prim :=
+ Find_Primitive_Covering_Interface
+ (Tagged_Type => Tagged_Type,
+ Iface_Prim => Iface_Prim);
+
+ pragma Assert (Present (Prim));
+
+ Derive_Subprogram
+ (New_Subp => New_Subp,
+ Parent_Subp => Iface_Prim,
+ Derived_Type => Tagged_Type,
+ Parent_Type => Iface);
+
+ -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp
+ -- associated with interface types. These entities are
+ -- only registered in the list of primitives of its
+ -- corresponding tagged type because they are only used
+ -- to fill the contents of the secondary dispatch tables.
+ -- Therefore they are removed from the homonym chains.
+
+ Set_Is_Hidden (New_Subp);
+ Set_Is_Internal (New_Subp);
+ Set_Alias (New_Subp, Prim);
+ Set_Is_Abstract_Subprogram (New_Subp,
+ Is_Abstract_Subprogram (Prim));
+ Set_Interface_Alias (New_Subp, Iface_Prim);
+
+ -- Internal entities associated with interface types are
+ -- only registered in the list of primitives of the tagged
+ -- type. They are only used to fill the contents of the
+ -- secondary dispatch tables. Therefore they are not needed
+ -- in the homonym chains.
+
+ Remove_Homonym (New_Subp);
+
+ -- Hidden entities associated with interfaces must have set
+ -- the Has_Delay_Freeze attribute to ensure that, in case of
+ -- locally defined tagged types (or compiling with static
+ -- dispatch tables generation disabled) the corresponding
+ -- entry of the secondary dispatch table is filled when
+ -- such an entity is frozen.
+
+ Set_Has_Delayed_Freeze (New_Subp);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end Add_Internal_Interface_Entities;
+
-----------------------------------
-- Analyze_Component_Declaration --
-----------------------------------
if Constant_Present (N) then
Prev_Entity := Current_Entity_In_Scope (Id);
- -- If the homograph is an implicit subprogram, it is overridden by
- -- the current declaration.
-
if Present (Prev_Entity)
and then
+ -- If the homograph is an implicit subprogram, it is overridden
+ -- by the current declaration.
+
((Is_Overloadable (Prev_Entity)
- and then Is_Inherited_Operation (Prev_Entity))
+ and then Is_Inherited_Operation (Prev_Entity))
-- The current object is a discriminal generated for an entry
-- family index. Even though the index is a constant, in this
or else
(Is_Discriminal (Id)
and then Ekind (Discriminal_Link (Id)) =
- E_Entry_Index_Parameter))
+ E_Entry_Index_Parameter)
+
+ -- The current object is the renaming for a generic declared
+ -- within the instance.
+
+ or else
+ (Ekind (Prev_Entity) = E_Package
+ and then Nkind (Parent (Prev_Entity)) =
+ N_Package_Renaming_Declaration
+ and then not Comes_From_Source (Prev_Entity)
+ and then Is_Generic_Instance (Renamed_Entity (Prev_Entity))))
then
Prev_Entity := Empty;
end if;
and then Is_Access_Constant (Etype (E))
then
Error_Msg_N
- ("access to variable cannot be initialized " &
- "with an access-to-constant expression", E);
+ ("access to variable cannot be initialized "
+ & "with an access-to-constant expression", E);
end if;
if not Assignment_OK (N) then
Check_Unset_Reference (E);
- -- If this is a variable, then set current value
+ -- If this is a variable, then set current value. If this is a
+ -- declared constant of a scalar type with a static expression,
+ -- indicate that it is always valid.
if not Constant_Present (N) then
if Compile_Time_Known_Value (E) then
Set_Current_Value (Id, E);
end if;
+
+ elsif Is_Scalar_Type (T)
+ and then Is_OK_Static_Expression (E)
+ then
+ Set_Is_Known_Valid (Id);
end if;
-- Deal with setting of null flags
end if;
end if;
- -- Check incorrect use of dynamically tagged expressions. Note
- -- the use of Is_Tagged_Type (T) which seems redundant but is in
- -- fact important to avoid spurious errors due to expanded code
- -- for dispatching functions over an anonymous access type
+ -- Check incorrect use of dynamically tagged expressions.
- if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E))
- and then Is_Tagged_Type (T)
- and then not Is_Class_Wide_Type (T)
- then
- Error_Msg_N ("dynamically tagged expression not allowed!", E);
+ if Is_Tagged_Type (T) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => E,
+ Typ => T,
+ Related_Nod => N);
end if;
Apply_Scalar_Range_Check (E, T);
end if;
end if;
- -- Abstract type is never permitted for a variable or constant.
- -- Note: we inhibit this check for objects that do not come from
- -- source because there is at least one case (the expansion of
- -- x'class'input where x is abstract) where we legitimately
- -- generate an abstract object.
-
- if Is_Abstract_Type (T) and then Comes_From_Source (N) then
- Error_Msg_N ("type of object cannot be abstract",
- Object_Definition (N));
-
- if Is_CPP_Class (T) then
- Error_Msg_NE ("\} may need a cpp_constructor",
- Object_Definition (N), T);
- end if;
-
-- Case of unconstrained type
- elsif Is_Indefinite_Subtype (T) then
+ if Is_Indefinite_Subtype (T) then
-- Nothing to do in deferred constant case
then
Act_T := Etype (E);
+ -- In case of class-wide interface object declarations we delay
+ -- the generation of the equivalent record type declarations until
+ -- its expansion because there are cases in they are not required.
+
+ elsif Is_Interface (T) then
+ null;
+
else
Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
Act_T := Find_Type_Of_Object (Object_Definition (N), N);
-- A Pure library_item must not contain the declaration of a
-- named access type, except within a subprogram, generic
- -- subprogram, task unit, or protected unit (RM 10.2.1(16)).
+ -- subprogram, task unit, or protected unit, or if it has
+ -- a specified Storage_Size of zero (RM05-10.2.1(15.4-15.5)).
if Comes_From_Source (Id)
and then In_Pure_Unit
and then not In_Subprogram_Task_Protected_Unit
+ and then not No_Pool_Assigned (Id)
then
Error_Msg_N
("named access types not allowed in pure unit", N);
-- subtype. Freeze_Entity will use this preallocated freeze node when
-- it freezes the entity.
- if B /= T then
+ -- This does not apply if the base type is a generic type, whose
+ -- declaration is independent of the current derived definition.
+
+ if B /= T and then not Is_Generic_Type (B) then
Ensure_Freeze_Node (B);
Set_First_Subtype_Link (Freeze_Node (B), T);
end if;
-- A type that is imported through a limited_with clause cannot
- -- generate any code, and thus need not be frozen. However, an
- -- access type with an imported designated type needs a finalization
- -- list, which may be referenced in some other package that has
- -- non-limited visibility on the designated type. Thus we must
- -- create the finalization list at the point the access type is
- -- frozen, to prevent unsatisfied references at link time.
-
- if not From_With_Type (T)
- or else Is_Access_Type (T)
- then
+ -- generate any code, and thus need not be frozen. However, an access
+ -- type with an imported designated type needs a finalization list,
+ -- which may be referenced in some other package that has non-limited
+ -- visibility on the designated type. Thus we must create the
+ -- finalization list at the point the access type is frozen, to
+ -- prevent unsatisfied references at link time.
+
+ if not From_With_Type (T) or else Is_Access_Type (T) then
Set_Has_Delayed_Freeze (T);
end if;
end;
- -- Case of T is the full declaration of some private type which has
+ -- Case where T is the full declaration of some private type which has
-- been swapped in Defining_Identifier (N).
if T /= Def_Id and then Is_Private_Type (Def_Id) then
Generate_Definition (Def_Id);
end if;
- if Chars (Scope (Def_Id)) = Name_System
+ if Chars (Scope (Def_Id)) = Name_System
and then Chars (Def_Id) = Name_Address
and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
then
Parent_Type : Entity_Id;
Derived_Type : Entity_Id)
is
- D_Constraint : Node_Id;
- Disc_Spec : Node_Id;
- Old_Disc : Entity_Id;
- New_Disc : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Corr_Record : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
+
+ Corr_Decl : Node_Id;
+ Corr_Decl_Needed : Boolean;
+ -- If the derived type has fewer discriminants than its parent, the
+ -- corresponding record is also a derived type, in order to account for
+ -- the bound discriminants. We create a full type declaration for it in
+ -- this case.
Constraint_Present : constant Boolean :=
- Nkind (Subtype_Indication (Type_Definition (N)))
- = N_Subtype_Indication;
+ Nkind (Subtype_Indication (Type_Definition (N))) =
+ N_Subtype_Indication;
+
+ D_Constraint : Node_Id;
+ New_Constraint : Elist_Id;
+ Old_Disc : Entity_Id;
+ New_Disc : Entity_Id;
+ New_N : Node_Id;
begin
Set_Stored_Constraint (Derived_Type, No_Elist);
+ Corr_Decl_Needed := False;
+ Old_Disc := Empty;
+
+ if Present (Discriminant_Specifications (N))
+ and then Constraint_Present
+ then
+ Old_Disc := First_Discriminant (Parent_Type);
+ New_Disc := First (Discriminant_Specifications (N));
+ while Present (New_Disc) and then Present (Old_Disc) loop
+ Next_Discriminant (Old_Disc);
+ Next (New_Disc);
+ end loop;
+ end if;
+
+ if Present (Old_Disc) then
+
+ -- The new type has fewer discriminants, so we need to create a new
+ -- corresponding record, which is derived from the corresponding
+ -- record of the parent, and has a stored constraint that captures
+ -- the values of the discriminant constraints.
+
+ -- The type declaration for the derived corresponding record has
+ -- the same discriminant part and constraints as the current
+ -- declaration. Copy the unanalyzed tree to build declaration.
+
+ Corr_Decl_Needed := True;
+ New_N := Copy_Separate_Tree (N);
+
+ Corr_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Corr_Record,
+ Discriminant_Specifications =>
+ Discriminant_Specifications (New_N),
+ Type_Definition =>
+ Make_Derived_Type_Definition (Loc,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (Corresponding_Record_Type (Parent_Type), Loc),
+ Constraint =>
+ Constraint
+ (Subtype_Indication (Type_Definition (New_N))))));
+ end if;
-- Copy Storage_Size and Relative_Deadline variables if task case
if Present (Discriminant_Specifications (N)) then
Push_Scope (Derived_Type);
Check_Or_Process_Discriminants (N, Derived_Type);
+
+ if Constraint_Present then
+ New_Constraint :=
+ Expand_To_Stored_Constraint
+ (Parent_Type,
+ Build_Discriminant_Constraints
+ (Parent_Type,
+ Subtype_Indication (Type_Definition (N)), True));
+ end if;
+
End_Scope;
elsif Constraint_Present then
end;
end if;
- -- All attributes are inherited from parent. In particular,
- -- entries and the corresponding record type are the same.
- -- Discriminants may be renamed, and must be treated separately.
+ -- By default, operations and private data are inherited from parent.
+ -- However, in the presence of bound discriminants, a new corresponding
+ -- record will be created, see below.
Set_Has_Discriminants
(Derived_Type, Has_Discriminants (Parent_Type));
(Constraints
(Constraint (Subtype_Indication (Type_Definition (N)))));
- Old_Disc := First_Discriminant (Parent_Type);
- New_Disc := First_Discriminant (Derived_Type);
- Disc_Spec := First (Discriminant_Specifications (N));
- while Present (Old_Disc) and then Present (Disc_Spec) loop
- if Nkind (Discriminant_Type (Disc_Spec)) /=
- N_Access_Definition
- then
- Analyze (Discriminant_Type (Disc_Spec));
+ Old_Disc := First_Discriminant (Parent_Type);
- if not Subtypes_Statically_Compatible (
- Etype (Discriminant_Type (Disc_Spec)),
- Etype (Old_Disc))
- then
- Error_Msg_N
- ("not statically compatible with parent discriminant",
- Discriminant_Type (Disc_Spec));
+ while Present (D_Constraint) loop
+ if Nkind (D_Constraint) /= N_Discriminant_Association then
+
+ -- Positional constraint. If it is a reference to a new
+ -- discriminant, it constrains the corresponding old one.
+
+ if Nkind (D_Constraint) = N_Identifier then
+ New_Disc := First_Discriminant (Derived_Type);
+ while Present (New_Disc) loop
+ exit when Chars (New_Disc) = Chars (D_Constraint);
+ Next_Discriminant (New_Disc);
+ end loop;
+
+ if Present (New_Disc) then
+ Set_Corresponding_Discriminant (New_Disc, Old_Disc);
+ end if;
+ end if;
+
+ Next_Discriminant (Old_Disc);
+
+ -- if this is a named constraint, search by name for the old
+ -- discriminants constrained by the new one.
+
+ elsif Nkind (Expression (D_Constraint)) = N_Identifier then
+
+ -- Find new discriminant with that name
+
+ New_Disc := First_Discriminant (Derived_Type);
+ while Present (New_Disc) loop
+ exit when
+ Chars (New_Disc) = Chars (Expression (D_Constraint));
+ Next_Discriminant (New_Disc);
+ end loop;
+
+ if Present (New_Disc) then
+
+ -- Verify that new discriminant renames some discriminant
+ -- of the parent type, and associate the new discriminant
+ -- with one or more old ones that it renames.
+
+ declare
+ Selector : Node_Id;
+
+ begin
+ Selector := First (Selector_Names (D_Constraint));
+ while Present (Selector) loop
+ Old_Disc := First_Discriminant (Parent_Type);
+ while Present (Old_Disc) loop
+ exit when Chars (Old_Disc) = Chars (Selector);
+ Next_Discriminant (Old_Disc);
+ end loop;
+
+ if Present (Old_Disc) then
+ Set_Corresponding_Discriminant
+ (New_Disc, Old_Disc);
+ end if;
+
+ Next (Selector);
+ end loop;
+ end;
end if;
end if;
- if Nkind (D_Constraint) = N_Identifier
- and then Chars (D_Constraint) /=
- Chars (Defining_Identifier (Disc_Spec))
+ Next (D_Constraint);
+ end loop;
+
+ New_Disc := First_Discriminant (Derived_Type);
+ while Present (New_Disc) loop
+ if No (Corresponding_Discriminant (New_Disc)) then
+ Error_Msg_NE
+ ("new discriminant& must constrain old one", N, New_Disc);
+
+ elsif not
+ Subtypes_Statically_Compatible
+ (Etype (New_Disc),
+ Etype (Corresponding_Discriminant (New_Disc)))
then
- Error_Msg_N ("new discriminants must constrain old ones",
- D_Constraint);
- else
- Set_Corresponding_Discriminant (New_Disc, Old_Disc);
+ Error_Msg_NE
+ ("& not statically compatible with parent discriminant",
+ N, New_Disc);
end if;
- Next_Discriminant (Old_Disc);
Next_Discriminant (New_Disc);
- Next (Disc_Spec);
end loop;
-
- if Present (Old_Disc) or else Present (Disc_Spec) then
- Error_Msg_N ("discriminant mismatch in derivation", N);
- end if;
-
end if;
elsif Present (Discriminant_Specifications (N)) then
Error_Msg_N
- ("missing discriminant constraint in untagged derivation",
- N);
+ ("missing discriminant constraint in untagged derivation", N);
end if;
+ -- The entity chain of the derived type includes the new discriminants
+ -- but shares operations with the parent.
+
if Present (Discriminant_Specifications (N)) then
Old_Disc := First_Discriminant (Parent_Type);
while Present (Old_Disc) loop
-
if No (Next_Entity (Old_Disc))
or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
then
- Set_Next_Entity (Last_Entity (Derived_Type),
- Next_Entity (Old_Disc));
+ Set_Next_Entity
+ (Last_Entity (Derived_Type), Next_Entity (Old_Disc));
exit;
end if;
Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type));
Set_Has_Completion (Derived_Type);
+
+ if Corr_Decl_Needed then
+ Set_Stored_Constraint (Derived_Type, New_Constraint);
+ Insert_After (N, Corr_Decl);
+ Analyze (Corr_Decl);
+ Set_Corresponding_Record_Type (Derived_Type, Corr_Record);
+ end if;
end Build_Derived_Concurrent_Type;
------------------------------------
Hi : Node_Id;
begin
- Lo :=
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_First,
- Prefix => New_Reference_To (Derived_Type, Loc));
- Set_Etype (Lo, Derived_Type);
+ if Nkind (Indic) /= N_Subtype_Indication then
+ Lo :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix => New_Reference_To (Derived_Type, Loc));
+ Set_Etype (Lo, Derived_Type);
+
+ Hi :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Last,
+ Prefix => New_Reference_To (Derived_Type, Loc));
+ Set_Etype (Hi, Derived_Type);
+
+ Set_Scalar_Range (Derived_Type,
+ Make_Range (Loc,
+ Low_Bound => Lo,
+ High_Bound => Hi));
+ else
- Hi :=
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Last,
- Prefix => New_Reference_To (Derived_Type, Loc));
- Set_Etype (Hi, Derived_Type);
-
- Set_Scalar_Range (Derived_Type,
- Make_Range (Loc,
- Low_Bound => Lo,
- High_Bound => Hi));
+ -- Analyze subtype indication and verify compatibility
+ -- with parent type.
+
+ if Base_Type (Process_Subtype (Indic, N)) /=
+ Base_Type (Parent_Type)
+ then
+ Error_Msg_N
+ ("illegal constraint for formal discrete type", N);
+ end if;
+ end if;
end;
else
Is_Completion : Boolean;
Derive_Subps : Boolean := True)
is
+ Loc : constant Source_Ptr := Sloc (N);
Der_Base : Entity_Id;
Discr : Entity_Id;
Full_Decl : Node_Id := Empty;
begin
if Is_Tagged_Type (Parent_Type) then
- Build_Derived_Record_Type
- (N, Parent_Type, Derived_Type, Derive_Subps);
+ Full_P := Full_View (Parent_Type);
+
+ -- A type extension of a type with unknown discriminants is an
+ -- indefinite type that the back-end cannot handle directly.
+ -- We treat it as a private type, and build a completion that is
+ -- derived from the full view of the parent, and hopefully has
+ -- known discriminants.
+
+ -- If the full view of the parent type has an underlying record view,
+ -- use it to generate the underlying record view of this derived type
+ -- (required for chains of derivations with unknown discriminants).
+
+ -- Minor optimization: we avoid the generation of useless underlying
+ -- record view entities if the private type declaration has unknown
+ -- discriminants but its corresponding full view has no
+ -- discriminants.
+
+ if Has_Unknown_Discriminants (Parent_Type)
+ and then Present (Full_P)
+ and then (Has_Discriminants (Full_P)
+ or else Present (Underlying_Record_View (Full_P)))
+ and then not In_Open_Scopes (Par_Scope)
+ and then Expander_Active
+ then
+ declare
+ Full_Der : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
+ New_Ext : constant Node_Id :=
+ Copy_Separate_Tree
+ (Record_Extension_Part (Type_Definition (N)));
+ Decl : Node_Id;
+
+ begin
+ Build_Derived_Record_Type
+ (N, Parent_Type, Derived_Type, Derive_Subps);
+
+ -- Build anonymous completion, as a derivation from the full
+ -- view of the parent. This is not a completion in the usual
+ -- sense, because the current type is not private.
+
+ Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Full_Der,
+ Type_Definition =>
+ Make_Derived_Type_Definition (Loc,
+ Subtype_Indication =>
+ New_Copy_Tree
+ (Subtype_Indication (Type_Definition (N))),
+ Record_Extension_Part => New_Ext));
+
+ -- If the parent type has an underlying record view, use it
+ -- here to build the new underlying record view.
+
+ if Present (Underlying_Record_View (Full_P)) then
+ pragma Assert
+ (Nkind (Subtype_Indication (Type_Definition (Decl)))
+ = N_Identifier);
+ Set_Entity (Subtype_Indication (Type_Definition (Decl)),
+ Underlying_Record_View (Full_P));
+ end if;
+
+ Install_Private_Declarations (Par_Scope);
+ Install_Visible_Declarations (Par_Scope);
+ Insert_Before (N, Decl);
+
+ -- Mark entity as an underlying record view before analysis,
+ -- to avoid generating the list of its primitive operations
+ -- (which is not really required for this entity) and thus
+ -- prevent spurious errors associated with missing overriding
+ -- of abstract primitives (overridden only for Derived_Type).
+
+ Set_Ekind (Full_Der, E_Record_Type);
+ Set_Is_Underlying_Record_View (Full_Der);
+
+ Analyze (Decl);
+
+ pragma Assert (Has_Discriminants (Full_Der)
+ and then not Has_Unknown_Discriminants (Full_Der));
+
+ Uninstall_Declarations (Par_Scope);
+
+ -- Freeze the underlying record view, to prevent generation of
+ -- useless dispatching information, which is simply shared with
+ -- the real derived type.
+
+ Set_Is_Frozen (Full_Der);
+
+ -- Set up links between real entity and underlying record view
+
+ Set_Underlying_Record_View (Derived_Type, Base_Type (Full_Der));
+ Set_Underlying_Record_View (Base_Type (Full_Der), Derived_Type);
+ end;
+
+ -- If discriminants are known, build derived record
+
+ else
+ Build_Derived_Record_Type
+ (N, Parent_Type, Derived_Type, Derive_Subps);
+ end if;
+
return;
elsif Has_Discriminants (Parent_Type) then
Insert_After (N, Full_Decl);
else
- -- If this is a completion, the full view being built is
- -- itself private. We build a subtype of the parent with
- -- the same constraints as this full view, to convey to the
- -- back end the constrained components and the size of this
- -- subtype. If the parent is constrained, its full view can
- -- serve as the underlying full view of the derived type.
+ -- If this is a completion, the full view being built is itself
+ -- private. We build a subtype of the parent with the same
+ -- constraints as this full view, to convey to the back end the
+ -- constrained components and the size of this subtype. If the
+ -- parent is constrained, its full view can serve as the
+ -- underlying full view of the derived type.
if No (Discriminant_Specifications (N)) then
if Nkind (Subtype_Indication (Type_Definition (N))) =
Build_Underlying_Full_View (N, Derived_Type, Parent_Type);
elsif Is_Constrained (Full_View (Parent_Type)) then
- Set_Underlying_Full_View (Derived_Type,
- Full_View (Parent_Type));
+ Set_Underlying_Full_View
+ (Derived_Type, Full_View (Parent_Type));
end if;
else
-- If there are new discriminants, the parent subtype is
-- constrained by them, but it is not clear how to build
- -- the underlying_full_view in this case ???
+ -- the Underlying_Full_View in this case???
null;
end if;
Build_Derived_Record_Type
(N, Parent_Type, Derived_Type, Derive_Subps);
- if Present (Full_View (Parent_Type))
- and then not Is_Completion
- then
+ if Present (Full_View (Parent_Type)) and then not Is_Completion then
if not In_Open_Scopes (Par_Scope)
or else not In_Same_Source_Unit (N, Parent_Type)
then
end if;
else
- -- If full view of parent is tagged, the completion
- -- inherits the proper primitive operations.
+ -- If full view of parent is tagged, the completion inherits
+ -- the proper primitive operations.
Set_Defining_Identifier (Full_Decl, Full_Der);
Build_Derived_Record_Type
Set_Full_View (Der_Base, Base_Type (Full_Der));
-- Copy the discriminant list from full view to the partial views
- -- (base type and its subtype). Gigi requires that the partial
- -- and full views have the same discriminants.
+ -- (base type and its subtype). Gigi requires that the partial and
+ -- full views have the same discriminants.
-- Note that since the partial view is pointing to discriminants
-- in the full view, their scope will be that of the full view.
- -- This might cause some front end problems and need
- -- adjustment???
+ -- This might cause some front end problems and need adjustment???
Discr := First_Discriminant (Base_Type (Full_Der));
Set_First_Entity (Der_Base, Discr);
Set_Stored_Constraint (Full_Der, Stored_Constraint (Derived_Type));
else
- -- If this is a completion, the derived type stays private
- -- and there is no need to create a further full view, except
- -- in the unusual case when the derivation is nested within a
- -- child unit, see below.
+ -- If this is a completion, the derived type stays private and
+ -- there is no need to create a further full view, except in the
+ -- unusual case when the derivation is nested within a child unit,
+ -- see below.
null;
end if;
return;
end if;
- -- If full view of parent is a record type, Build full view as
- -- a derivation from the parent's full view. Partial view remains
- -- private. For code generation and linking, the full view must
- -- have the same public status as the partial one. This full view
- -- is only needed if the parent type is in an enclosing scope, so
- -- that the full view may actually become visible, e.g. in a child
- -- unit. This is both more efficient, and avoids order of freezing
- -- problems with the added entities.
+ -- If full view of parent is a record type, build full view as a
+ -- derivation from the parent's full view. Partial view remains
+ -- private. For code generation and linking, the full view must have
+ -- the same public status as the partial one. This full view is only
+ -- needed if the parent type is in an enclosing scope, so that the
+ -- full view may actually become visible, e.g. in a child unit. This
+ -- is both more efficient, and avoids order of freezing problems with
+ -- the added entities.
if not Is_Private_Type (Full_View (Parent_Type))
and then (In_Open_Scopes (Scope (Parent_Type)))
Derive_Subps => False);
end if;
- -- In any case, the primitive operations are inherited from
- -- the parent type, not from the internal full view.
+ -- In any case, the primitive operations are inherited from the
+ -- parent type, not from the internal full view.
Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type));
and then Present (Full_View (Parent_Type))
and then not Is_Tagged_Type (Full_View (Parent_Type))
then
- Error_Msg_N
- ("cannot add discriminants to untagged type", N);
+ Error_Msg_N ("cannot add discriminants to untagged type", N);
end if;
Set_Stored_Constraint (Derived_Type, No_Elist);
(Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
end if;
- -- Construct the implicit full view by deriving from full view of
- -- the parent type. In order to get proper visibility, we install
- -- the parent scope and its declarations.
+ -- Construct the implicit full view by deriving from full view of the
+ -- parent type. In order to get proper visibility, we install the
+ -- parent scope and its declarations.
- -- ??? if the parent is untagged private and its completion is
- -- tagged, this mechanism will not work because we cannot derive
- -- from the tagged full view unless we have an extension
+ -- ??? If the parent is untagged private and its completion is
+ -- tagged, this mechanism will not work because we cannot derive from
+ -- the tagged full view unless we have an extension.
if Present (Full_View (Parent_Type))
and then not Is_Tagged_Type (Full_View (Parent_Type))
Set_Is_Frozen (Full_Der, False);
Set_Freeze_Node (Full_Der, Empty);
Set_Depends_On_Private (Full_Der,
- Has_Private_Component (Full_Der));
+ Has_Private_Component (Full_Der));
Set_Public_Status (Full_Der);
end if;
end if;
and then Scope (Parent_Type) /= Current_Scope
then
-- This is the unusual case where a type completed by a private
- -- derivation occurs within a package nested in a child unit,
- -- and the parent is declared in an ancestor. In this case, the
- -- full view of the parent type will become visible in the body
- -- of the enclosing child, and only then will the current type
- -- be possibly non-private. We build a underlying full view that
+ -- derivation occurs within a package nested in a child unit, and
+ -- the parent is declared in an ancestor. In this case, the full
+ -- view of the parent type will become visible in the body of
+ -- the enclosing child, and only then will the current type be
+ -- possibly non-private. We build a underlying full view that
-- will be installed when the enclosing child body is compiled.
Full_Der :=
-- Fields inherited from the Parent_Type
Set_Discard_Names
- (Derived_Type, Einfo.Discard_Names (Parent_Type));
+ (Derived_Type, Einfo.Discard_Names (Parent_Type));
Set_Has_Specified_Layout
- (Derived_Type, Has_Specified_Layout (Parent_Type));
+ (Derived_Type, Has_Specified_Layout (Parent_Type));
Set_Is_Limited_Composite
- (Derived_Type, Is_Limited_Composite (Parent_Type));
+ (Derived_Type, Is_Limited_Composite (Parent_Type));
Set_Is_Private_Composite
- (Derived_Type, Is_Private_Composite (Parent_Type));
+ (Derived_Type, Is_Private_Composite (Parent_Type));
-- Fields inherited from the Parent_Base
-- Fields inherited from the Parent_Base for record types
if Is_Record_Type (Derived_Type) then
- Set_OK_To_Reorder_Components
- (Derived_Type, OK_To_Reorder_Components (Parent_Base));
- Set_Reverse_Bit_Order
- (Derived_Type, Reverse_Bit_Order (Parent_Base));
+
+ -- Ekind (Parent_Base) is not necessarily E_Record_Type since
+ -- Parent_Base can be a private type or private extension.
+
+ if Present (Full_View (Parent_Base)) then
+ Set_OK_To_Reorder_Components
+ (Derived_Type,
+ OK_To_Reorder_Components (Full_View (Parent_Base)));
+ Set_Reverse_Bit_Order
+ (Derived_Type, Reverse_Bit_Order (Full_View (Parent_Base)));
+ else
+ Set_OK_To_Reorder_Components
+ (Derived_Type, OK_To_Reorder_Components (Parent_Base));
+ Set_Reverse_Bit_Order
+ (Derived_Type, Reverse_Bit_Order (Parent_Base));
+ end if;
end if;
-- Direct controlled types do not inherit Finalize_Storage_Only flag
else
Set_Component_Alignment
(Derived_Type, Component_Alignment (Parent_Base));
-
Set_C_Pass_By_Copy
(Derived_Type, C_Pass_By_Copy (Parent_Base));
end if;
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base));
end if;
- Make_Class_Wide_Type (Derived_Type);
+ -- Minor optimization: there is no need to generate the class-wide
+ -- entity associated with an underlying record view.
+
+ if not Is_Underlying_Record_View (Derived_Type) then
+ Make_Class_Wide_Type (Derived_Type);
+ end if;
+
Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def));
if Has_Discriminants (Derived_Type)
end if;
end if;
- -- Update the class_wide type, which shares the now-completed
- -- entity list with its specific type.
+ -- Update the class-wide type, which shares the now-completed entity
+ -- list with its specific type. In case of underlying record views,
+ -- we do not generate the corresponding class wide entity.
- if Is_Tagged then
+ if Is_Tagged
+ and then not Is_Underlying_Record_View (Derived_Type)
+ then
Set_First_Entity
(Class_Wide_Type (Derived_Type), First_Entity (Derived_Type));
Set_Last_Entity
-- declaration, all clauses are inherited.
if No (First_Rep_Item (Def_Id)) then
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
end if;
if Is_Tagged_Type (T) then
-- Error message below needs rewording (remember comma
-- in -gnatj mode) ???
- if Ekind (First_Formal (Subp)) = E_In_Parameter then
+ if Ekind (First_Formal (Subp)) = E_In_Parameter
+ and then Ekind (Subp) /= E_Function
+ then
if not Is_Predefined_Dispatching_Operation (Subp) then
Error_Msg_NE
("first formal of & must be of mode `OUT`, " &
Error_Msg_NE
("interface subprogram & must be overridden",
T, Subp);
+
+ -- Examine primitive operations of synchronized type,
+ -- to find homonyms that have the wrong profile.
+
+ declare
+ Prim : Entity_Id;
+
+ begin
+ Prim :=
+ First_Entity (Corresponding_Concurrent_Type (T));
+ while Present (Prim) loop
+ if Chars (Prim) = Chars (Subp) then
+ Error_Msg_NE
+ ("profile is not type conformant with "
+ & "prefixed view profile of "
+ & "inherited operation&", Prim, Subp);
+ end if;
+
+ Next_Entity (Prim);
+ end loop;
+ end;
end if;
end if;
-- source (including the _Call primitive operation of RAS types,
-- which has to have the flag Comes_From_Source for other purposes):
-- we assume that the expander will provide the missing completion.
+ -- In case of previous errors, other expansion actions that provide
+ -- bodies for null procedures with not be invoked, so inhibit message
+ -- in those cases.
+ -- Note that E_Operator is not in the list that follows, because
+ -- this kind is reserved for predefined operators, that are
+ -- intrinsic and do not need completion.
elsif Ekind (E) = E_Function
or else Ekind (E) = E_Procedure
or else Ekind (E) = E_Generic_Function
or else Ekind (E) = E_Generic_Procedure
then
- if not Has_Completion (E)
- and then not (Is_Subprogram (E)
- and then Is_Abstract_Subprogram (E))
- and then not (Is_Subprogram (E)
- and then
- (not Comes_From_Source (E)
- or else Chars (E) = Name_uCall))
- and then Nkind (Parent (Unit_Declaration_Node (E))) /=
- N_Compilation_Unit
- and then Chars (E) /= Name_uSize
+ if Has_Completion (E) then
+ null;
+
+ elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then
+ null;
+
+ elsif Is_Subprogram (E)
+ and then (not Comes_From_Source (E)
+ or else Chars (E) = Name_uCall)
+ then
+ null;
+
+ elsif
+ Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
+ then
+ null;
+
+ elsif Nkind (Parent (E)) = N_Procedure_Specification
+ and then Null_Present (Parent (E))
+ and then Serious_Errors_Detected > 0
then
+ null;
+
+ else
Post_Error;
end if;
and then not In_Instance
and then not In_Inlined_Body
then
- if not OK_For_Limited_Init (Exp) then
+ if not OK_For_Limited_Init (T, Exp) then
-- In GNAT mode, this is just a warning, to allow it to be evilly
-- turned off. Otherwise it is a real error.
Set_Convention (T1, Convention (T2));
Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2));
Set_Is_Private_Composite (T1, Is_Private_Composite (T2));
+ Set_Packed_Array_Type (T1, Packed_Array_Type (T2));
end Copy_Array_Subtype_Attributes;
-----------------------------------
and then Is_Completely_Hidden (Old_Compon)
then
-- This is a shadow discriminant created for a discriminant of
- -- the parent type that is one of several renamed by the same
- -- new discriminant. Give the shadow discriminant an internal
- -- name that cannot conflict with that of visible components.
+ -- the parent type, which needs to be present in the subtype.
+ -- Give the shadow discriminant an internal name that cannot
+ -- conflict with that of visible components.
Set_Chars (New_Compon, New_Internal_Name ('C'));
end if;
-- For an untagged derived subtype, the number of discriminants may
-- be smaller than the number of inherited discriminants, because
- -- several of them may be renamed by a single new discriminant.
- -- In this case, add the hidden discriminants back into the subtype,
- -- because otherwise the size of the subtype is computed incorrectly
- -- in GCC 4.1.
+ -- several of them may be renamed by a single new discriminant or
+ -- constrained. In this case, add the hidden discriminants back into
+ -- the subtype, because they need to be present if the optimizer of
+ -- the GCC 4.x back-end decides to break apart assignments between
+ -- objects using the parent view into member-wise assignments.
Num_Gird := 0;
-- component for the current old discriminant.
New_C := Create_Component (Old_Discr);
- Set_Original_Record_Component (New_C, Old_Discr);
+ Set_Original_Record_Component (New_C, Old_Discr);
end if;
+
+ else
+ -- The constraint has eliminated the old discriminant.
+ -- Introduce a shadow component.
+
+ New_C := Create_Component (Old_Discr);
+ Set_Original_Record_Component (New_C, Old_Discr);
end if;
Next_Elmt (Constr);
then
Set_Derived_Name;
+ -- An inherited dispatching equality will be overridden by an internally
+ -- generated one, or by an explicit one, so preserve its name and thus
+ -- its entry in the dispatch table. Otherwise, if Parent_Subp is a
+ -- private operation it may become invisible if the full view has
+ -- progenitors, and the dispatch table will be malformed.
+ -- We check that the type is limited to handle the anomalous declaration
+ -- of Limited_Controlled, which is derived from a non-limited type, and
+ -- which is handled specially elsewhere as well.
+
+ elsif Chars (Parent_Subp) = Name_Op_Eq
+ and then Is_Dispatching_Operation (Parent_Subp)
+ and then Etype (Parent_Subp) = Standard_Boolean
+ and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp)))
+ and then
+ Etype (First_Formal (Parent_Subp)) =
+ Etype (Next_Formal (First_Formal (Parent_Subp)))
+ then
+ Set_Derived_Name;
+
-- If parent is hidden, this can be a regular derivation if the
-- parent is immediately visible in a non-instantiating context,
-- or if we are in the private part of an instance. This test
elsif Parent_Overrides_Interface_Primitive then
Set_Derived_Name;
- -- The type is inheriting a private operation, so enter
+ -- Otherwise, the type is inheriting a private operation, so enter
-- it with a special name so it can't be overridden.
else
Error_Msg_N ("null exclusion can only apply to an access type", N);
end if;
- Build_Derived_Type (N, Parent_Type, T, Is_Completion);
+ -- Avoid deriving parent primitives of underlying record views
+
+ Build_Derived_Type (N, Parent_Type, T, Is_Completion,
+ Derive_Subps => not Is_Underlying_Record_View (T));
-- AI-419: The parent type of an explicitly limited derived type must
-- be a limited type or a limited interface.
Ev := Uint_0;
-- Loop through literals of enumeration type setting pos and rep values
- -- except that if the Ekind is already set, then it means that the
- -- literal was already constructed (case of a derived type declaration
- -- and we should not disturb the Pos and Rep values.
+ -- except that if the Ekind is already set, then it means the literal
+ -- was already constructed (case of a derived type declaration and we
+ -- should not disturb the Pos and Rep values.
while Present (L) loop
if Ekind (L) /= E_Enumeration_Literal then
elsif No (Interface_List (N)) then
Error_Msg_N
("completion of tagged private type must be tagged",
- N);
+ N);
end if;
+
+ elsif Nkind (N) = N_Full_Type_Declaration
+ and then
+ Nkind (Type_Definition (N)) = N_Record_Definition
+ and then Interface_Present (Type_Definition (N))
+ then
+ Error_Msg_N
+ ("completion of private type cannot be an interface", N);
end if;
-- Ada 2005 (AI-251): Private extension declaration of a task
"full declaration of } must be a record extension",
Prev, Id);
- -- Set some attributes to produce a usable full view.
+ -- Set some attributes to produce a usable full view
Set_Is_Tagged_Type (Id);
Set_Primitive_Operations (Id, New_Elmt_List);
-----------------------
function Is_Null_Extension (T : Entity_Id) return Boolean is
- Type_Decl : constant Node_Id := Parent (T);
+ Type_Decl : constant Node_Id := Parent (Base_Type (T));
Comp_List : Node_Id;
Comp : Node_Id;
-- ???Check all calls of this, and compare the conditions under which it's
-- called.
- function OK_For_Limited_Init (Exp : Node_Id) return Boolean is
+ function OK_For_Limited_Init
+ (Typ : Entity_Id;
+ Exp : Node_Id) return Boolean
+ is
begin
- return Ada_Version >= Ada_05
- and then not Debug_Flag_Dot_L
- and then OK_For_Limited_Init_In_05 (Exp);
+ return Is_CPP_Constructor_Call (Exp)
+ or else (Ada_Version >= Ada_05
+ and then not Debug_Flag_Dot_L
+ and then OK_For_Limited_Init_In_05 (Typ, Exp));
end OK_For_Limited_Init;
-------------------------------
-- OK_For_Limited_Init_In_05 --
-------------------------------
- function OK_For_Limited_Init_In_05 (Exp : Node_Id) return Boolean is
+ function OK_For_Limited_Init_In_05
+ (Typ : Entity_Id;
+ Exp : Node_Id) return Boolean
+ is
begin
+ -- An object of a limited interface type can be initialized with any
+ -- expression of a nonlimited descendant type.
+
+ if Is_Class_Wide_Type (Typ)
+ and then Is_Limited_Interface (Typ)
+ and then not Is_Limited_Type (Etype (Exp))
+ then
+ return True;
+ end if;
+
-- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in
-- case of limited aggregates (including extension aggregates), and
-- function calls. The function call may have been give in prefixed
when N_Qualified_Expression =>
return
- OK_For_Limited_Init_In_05 (Expression (Original_Node (Exp)));
+ OK_For_Limited_Init_In_05
+ (Typ, Expression (Original_Node (Exp)));
-- Ada 2005 (AI-251): If a class-wide interface object is initialized
-- with a function call, the expander has rewritten the call into an
-- N_Type_Conversion node to force displacement of the pointer to
-- reference the component containing the secondary dispatch table.
-- Otherwise a type conversion is not a legal context.
+ -- A return statement for a build-in-place function returning a
+ -- synchronized type also introduces an unchecked conversion.
- when N_Type_Conversion =>
+ when N_Type_Conversion | N_Unchecked_Type_Conversion =>
return not Comes_From_Source (Exp)
and then
- OK_For_Limited_Init_In_05 (Expression (Original_Node (Exp)));
+ OK_For_Limited_Init_In_05
+ (Typ, Expression (Original_Node (Exp)));
when N_Indexed_Component | N_Selected_Component =>
return Nkind (Exp) = N_Function_Call;
declare
Conc_Typ : constant Entity_Id :=
Corresponding_Record_Type (Full_T);
- Loc : constant Source_Ptr := Sloc (Conc_Typ);
Curr_Nod : Node_Id := Parent (Conc_Typ);
Wrap_Spec : Node_Id;
and then not Is_Abstract_Subprogram (Prim)
then
Wrap_Spec :=
- Make_Subprogram_Declaration (Loc,
+ Make_Subprogram_Declaration (Sloc (Prim),
Specification =>
- Build_Wrapper_Spec (Loc,
- Subp_Id => Prim,
- Obj_Typ => Conc_Typ,
- Formals =>
- Parameter_Specifications (
- Parent (Prim))));
+ Build_Wrapper_Spec
+ (Subp_Id => Prim,
+ Obj_Typ => Conc_Typ,
+ Formals =>
+ Parameter_Specifications (
+ Parent (Prim))));
Insert_After (Curr_Nod, Wrap_Spec);
Curr_Nod := Wrap_Spec;
Set_Is_CPP_Class (Full_T);
Set_Convention (Full_T, Convention_CPP);
end if;
+
+ -- If the private view has user specified stream attributes, then so has
+ -- the full view.
+
+ if Has_Specified_Stream_Read (Priv_T) then
+ Set_Has_Specified_Stream_Read (Full_T);
+ end if;
+ if Has_Specified_Stream_Write (Priv_T) then
+ Set_Has_Specified_Stream_Write (Full_T);
+ end if;
+ if Has_Specified_Stream_Input (Priv_T) then
+ Set_Has_Specified_Stream_Input (Full_T);
+ end if;
+ if Has_Specified_Stream_Output (Priv_T) then
+ Set_Has_Specified_Stream_Output (Full_T);
+ end if;
end Process_Full_View;
-----------------------------------
OSDN Git Service
