+2010-06-23 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Mark_Coextensions): If the expression in the allocator
+ for a coextension in an object declaration is a concatenation, treat
+ coextension as dynamic.
+
+2010-06-23 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Add_Internal_Interface_Entities): Ensure that the
+ internal entities are added to the scope of the tagged type.
+ (Derive_Subprograms): Do not stop derivation when we find the first
+ internal entity that has attribute Interface_Alias. After the change
+ done to Override_Dispatching_Operations it is no longer true that
+ these primirives are always located at the end of the list of
+ primitives.
+ * einfo.ads (Primitive_Operations): Add documentation.
+ * exp_disp.adb (Write_DT): Improve output adding to the name of the
+ primitive a prefix indicating its corresponding tagged type.
+ * sem_disp.adb (Override_Dispatching_Operations): If the overridden
+ entity covers the primitive of an interface that is not an ancestor of
+ this tagged type then the new primitive is added at the end of the list
+ of primitives. Required to fulfill the C++ ABI.
+
2010-06-23 Javier Miranda <miranda@adacore.com>
* atree.ads (Set_Reporting_Proc): New subprogram.
-- types. Points to an element list of entities for primitive operations
-- for the tagged type. Not present (and not set) in untagged types (it
-- is an error to reference the primitive operations field of a type
--- that is not tagged).
+-- that is not tagged). In order to fulfill the C++ ABI, entities of
+-- primitives that come from source must be stored in this list following
+-- their order of occurrence in the sources.
-- Prival (Node17)
-- Present in private components of protected types. Refers to the entity
Next_Elmt (Prim_Elmt);
end loop;
- -- Third stage: Fix the position of all the new primitives
+ -- Third stage: Fix the position of all the new primitives.
-- Entries associated with primitives covering interfaces
-- are handled in a latter round.
Write_Str ("(predefined) ");
end if;
+ -- Prefix the name of the primitive with its corresponding tagged
+ -- type to facilitate seeing inherited primitives.
+
+ if Present (Alias (Prim)) then
+ Write_Name
+ (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
+ else
+ Write_Name (Chars (Typ));
+ end if;
+
+ Write_Str (".");
Write_Name (Chars (Prim));
-- Indicate if this primitive has an aliased primitive
-------------------------------------
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;
+ 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;
+ Restore_Scope : Boolean := False;
begin
pragma Assert (Ada_Version >= Ada_05
and then Has_Interfaces (Tagged_Type)
and then not Is_Interface (Tagged_Type));
+ -- Ensure that the internal entities are added to the scope of the type
+
+ if Scope (Tagged_Type) /= Current_Scope then
+ Push_Scope (Scope (Tagged_Type));
+ Restore_Scope := True;
+ end if;
+
Collect_Interfaces (Tagged_Type, Ifaces_List);
Iface_Elmt := First_Elmt (Ifaces_List);
(Tagged_Type => Tagged_Type,
Iface_Prim => Iface_Prim);
+ -- Handle cases where the type has no primitive covering this
+ -- interface primitive.
+
if No (Prim) then
- -- In some rare cases, a name conflict may have kept the
- -- operation completely hidden. Look for it in the list
- -- of primitive operations of the type.
+ -- if the tagged type is defined at library level then we
+ -- invoke Check_Abstract_Overriding to report the error
+ -- and thus avoid generating the dispatch tables.
- declare
- El : Elmt_Id;
+ if Is_Library_Level_Tagged_Type (Tagged_Type) then
+ Check_Abstract_Overriding (Tagged_Type);
+ pragma Assert (Serious_Errors_Detected > 0);
+ return;
- begin
- El := First_Elmt (Primitive_Operations (Tagged_Type));
- while Present (El) loop
- Prim := Node (El);
- exit when Is_Subprogram (Prim)
- and then Alias (Prim) = Iface_Prim;
- Next_Elmt (El);
- end loop;
+ -- For tagged types defined in nested scopes it is still
+ -- possible to cover this interface primitive by means of
+ -- late overriding (see Override_Dispatching_Operation).
- -- If the operation was not explicitly overridden, it
- -- should have been inherited as an abstract operation
- -- so Prim can not be Empty at this stage.
+ -- Search in the list of primitives of the type for the
+ -- entity that will be overridden in such case to reference
+ -- it in the internal entity that we build here. If the
+ -- primitive is not overridden then the error will be
+ -- reported later as part of the analysis of entities
+ -- defined in the enclosing scope.
- if No (El) then
- raise Program_Error;
- end if;
- end;
+ else
+ declare
+ El : Elmt_Id;
+
+ begin
+ El := First_Elmt (Primitive_Operations (Tagged_Type));
+ while Present (El)
+ and then Alias (Node (El)) /= Iface_Prim
+ loop
+ Next_Elmt (El);
+ end loop;
+
+ pragma Assert (Present (El));
+ Prim := Node (El);
+ end;
+ end if;
end if;
Derive_Subprogram
Next_Elmt (Iface_Elmt);
end loop;
+
+ if Restore_Scope then
+ Pop_Scope;
+ end if;
end Add_Internal_Interface_Entities;
-----------------------------------
Subp := Node (Elmt);
Alias_Subp := Ultimate_Alias (Subp);
- -- At this early stage Derived_Type has no entities with attribute
- -- Interface_Alias. In addition, such primitives are always
- -- located at the end of the list of primitives of Parent_Type.
- -- Therefore, if found we can safely stop processing pending
- -- entities.
+ -- Do not derive internal entities of the parent that link
+ -- interface primitives and its covering primitive. These
+ -- entities will be added to this type when frozen.
- exit when Present (Interface_Alias (Subp));
+ if Present (Interface_Alias (Subp)) then
+ goto Continue;
+ end if;
-- If the generic actual is present find the corresponding
-- operation in the generic actual. If the parent type is a
Act_Subp := Node (Act_Elmt);
end if;
+ <<Continue>>
Next_Elmt (Elmt);
end loop;
and then not Comes_From_Source (Subp)
and then not Has_Dispatching_Parent
then
- -- Complete decoration if internally built subprograms that override
+ -- Complete decoration of internally built subprograms that override
-- a dispatching primitive. These entities correspond with the
-- following cases:
return;
end if;
- Replace_Elmt (Elmt, New_Op);
+ -- The location of entities that come from source in the list of
+ -- primitives of the tagged type must follow their order of occurrence
+ -- in the sources to fulfill the C++ ABI. If the overriden entity is a
+ -- primitive of an interface that is not an ancestor of this tagged
+ -- type (that is, it is an entity added to the list of primitives by
+ -- Derive_Interface_Progenitors), then we must append the new entity
+ -- at the end of the list of primitives.
+
+ if Present (Alias (Prev_Op))
+ and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op)))
+ and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)),
+ Tagged_Type)
+ then
+ Remove_Elmt (Primitive_Operations (Tagged_Type), Elmt);
+ Append_Elmt (New_Op, Primitive_Operations (Tagged_Type));
+
+ -- The new primitive replaces the overriden entity. Required to ensure
+ -- that overriding primitive is assigned the same dispatch table slot.
+
+ else
+ Replace_Elmt (Elmt, New_Op);
+ end if;
if Ada_Version >= Ada_05
and then Has_Interfaces (Tagged_Type)
if Is_Dynamic then
Set_Is_Dynamic_Coextension (N);
+ -- If the allocator expression is potentially dynamic, it may
+ -- be expanded out of order and require dynamic allocation
+ -- anyway, so we treat the coextension itself as dynamic.
+ -- Potential optimization ???
+
+ elsif Nkind (Expression (N)) = N_Qualified_Expression
+ and then Nkind (Expression (Expression (N))) = N_Op_Concat
+ then
+ Set_Is_Dynamic_Coextension (N);
+
else
Set_Is_Static_Coextension (N);
end if;
projects / gcc.git / commitdiff