2010-10-05 Robert Dewar <dewar@adacore.com>
+ * sem_ch4.adb: Minor reformatting.
+ * a-direct.ads: Minor comment update.
+
+2010-10-05 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Add_Internal_Interface_Entities): Removing code that is
+ no longer required after change in New_Overloaded_Entity.
+ * sem_ch6.adb (New_Overloaded_Entity): Code reorganization to isolate
+ the fragment of code that handles derivations of interface primitives.
+ Add missing dependence on global variable Inside_Freezing_Actions to
+ ensure the correct management of internal interface entities.
+ * sem_ch13.adb (Analyze_Freeze_Entity): Add missing increase/decrease
+ of the global variable Inside_Freezing_Actions to ensure that internal
+ interface entities are well handled by New_Overloaded_Entity.
+ * sem_disp.adb (Find_Primitive_Covering_Interface): Add documentation
+ and complete the algorithm to catch hidden primitives derived of
+ private type that covers the interface.
+ * sem_disp.ads (Find_Primitive_Covering_Interface): Add missing
+ documentation.
+
+2010-10-05 Robert Dewar <dewar@adacore.com>
+
* prj-util.adb, prj-util.ads, prj.ads, s-vxwext-rtp.adb, sem_ch4.adb,
sem_ch7.adb, sem_res.adb, sem_type.adb: Minor reformatting.
Minor code reorganization (use Nkind_In).
-- timestamps: Preserve the timestamp of the copied file, but not
-- the other file attributes.
--
- --
-- The allowed values for mode= are:
--
-- copy: Only copy if the destination file does not already
-- exist. If it already exists, Copy_File will fail.
--
-- overwrite: Copy the file in all cases. Overwite an already
- -- existing destination file.
+ -- existing destination file. This is the default if
+ -- no mode= is found in Form.
--
-- append: Append the original file to the destination file.
-- If the destination file does not exist, the
-- When mode=append, the field preserve=, if it
-- exists, is not taken into account.
--
- -- What is the default value for mode=???
- --
-- If the Form parameter includes one or both of the fields and the value
- -- or values are incorrect, Copy_file fails with Use_Error.
+ -- or values are incorrect, Copy_File fails with Use_Error.
--
-- Examples of correct Forms:
-- Form => "preserve=no_attributes,mode=overwrite" (the default)
-- Form => "mode=append"
- -- Form => "mode=copy, preserve=all_attributes"
+ -- Form => "mode=copy,preserve=all_attributes"
--
-- Examples of incorrect Forms:
-- Form => "preserve=junk"
- -- Form => "mode=internal, preserve=timestamps"
+ -- Form => "mode=internal,preserve=timestamps"
----------------------------------------
-- File and directory name operations --
E : constant Entity_Id := Entity (N);
begin
+ -- Remember that we are processing a freezing entity. Required to
+ -- ensure correct decoration of internal entities associated with
+ -- interfaces (see New_Overloaded_Entity).
+
+ Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
+
-- For tagged types covering interfaces add internal entities that link
-- the primitives of the interfaces with the primitives that cover them.
-
-- Note: These entities were originally generated only when generating
-- code because their main purpose was to provide support to initialize
-- the secondary dispatch tables. They are now generated also when
end loop;
end;
end if;
+
+ Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
end Analyze_Freeze_Entity;
------------------------------------------
(Tagged_Type => Tagged_Type,
Iface_Prim => Iface_Prim);
- -- Handle cases where the type has no primitive covering this
- -- interface primitive.
-
- if No (Prim) then
-
- -- Skip non-overridden null interface primitives because
- -- their wrappers will be generated later.
-
- if Is_Null_Interface_Primitive (Iface_Prim) then
- goto Continue;
-
- else
- pragma Assert (False);
- raise Program_Error;
- end if;
- end if;
+ pragma Assert (Present (Prim));
Derive_Subprogram
(New_Subp => New_Subp,
Set_Has_Delayed_Freeze (New_Subp);
end if;
- <<Continue>>
Next_Elmt (Elmt);
end loop;
-- If this is an indirect call, the return type of the access_to
-- subprogram may be an incomplete type. At the point of the call,
- -- use the full type if available, and at the same time update
- -- the return type of the access_to_subprogram.
+ -- use the full type if available, and at the same time update the
+ -- return type of the access_to_subprogram.
if Success
and then Nkind (Nam) = N_Explicit_Dereference
-- Name may be call that returns an access to subprogram, or more
-- generally an overloaded expression one of whose interpretations
- -- yields an access to subprogram. If the name is an entity, we
- -- do not dereference, because the node is a call that returns
- -- the access type: note difference between f(x), where the call
- -- may return an access subprogram type, and f(x)(y), where the
- -- type returned by the call to f is implicitly dereferenced to
- -- analyze the outer call.
+ -- yields an access to subprogram. If the name is an entity, we do
+ -- not dereference, because the node is a call that returns the
+ -- access type: note difference between f(x), where the call may
+ -- return an access subprogram type, and f(x)(y), where the type
+ -- returned by the call to f is implicitly dereferenced to analyze
+ -- the outer call.
if Is_Access_Type (Nam_Ent) then
Nam_Ent := Designated_Type (Nam_Ent);
E := Current_Entity_In_Scope (S);
+ -- Ada 2005 (AI-251): Derivation of abstract interface primitives.
+ -- They are directly added to the list of primitive operations of
+ -- Derived_Type, unless this is a rederivation in the private part
+ -- of an operation that was already derived in the visible part of
+ -- the current package.
+
+ if Ada_Version >= Ada_05
+ and then Present (Derived_Type)
+ and then Present (Alias (S))
+ and then Is_Dispatching_Operation (Alias (S))
+ and then Present (Find_Dispatching_Type (Alias (S)))
+ and then Is_Interface (Find_Dispatching_Type (Alias (S)))
+ then
+ -- For private types, when the full-view is processed we propagate to
+ -- the full view the non-overridden entities whose attribute "alias"
+ -- references an interface primitive. These entities were added by
+ -- Derive_Subprograms to ensure that interface primitives are
+ -- covered.
+
+ -- Inside_Freeze_Actions is non zero when S corresponds with an
+ -- internal entity that links an interface primitive with its
+ -- covering primitive through attribute Interface_Alias (see
+ -- Add_Internal_Interface_Entities)
+
+ if Inside_Freezing_Actions = 0
+ and then Is_Package_Or_Generic_Package (Current_Scope)
+ and then In_Private_Part (Current_Scope)
+ and then Nkind (Parent (E)) = N_Private_Extension_Declaration
+ and then Nkind (Parent (S)) = N_Full_Type_Declaration
+ and then Full_View (Defining_Identifier (Parent (E)))
+ = Defining_Identifier (Parent (S))
+ and then Alias (E) = Alias (S)
+ then
+ Check_Operation_From_Private_View (S, E);
+ Set_Is_Dispatching_Operation (S);
+
+ -- Common case
+
+ else
+ Enter_Overloaded_Entity (S);
+ Check_Dispatching_Operation (S, Empty);
+ Check_For_Primitive_Subprogram (Is_Primitive_Subp);
+ end if;
+
+ return;
+ end if;
+
-- If there is no homonym then this is definitely not overriding
if No (E) then
-- E exists and is overloadable
else
- -- Ada 2005 (AI-251): Derivation of abstract interface primitives.
- -- They are directly added to the list of primitive operations of
- -- Derived_Type, unless this is a rederivation in the private part
- -- of an operation that was already derived in the visible part of
- -- the current package.
-
- if Ada_Version >= Ada_05
- and then Present (Derived_Type)
- and then Present (Alias (S))
- and then Is_Dispatching_Operation (Alias (S))
- and then Present (Find_Dispatching_Type (Alias (S)))
- and then Is_Interface (Find_Dispatching_Type (Alias (S)))
- then
- if Type_Conformant (E, S)
- and then Is_Package_Or_Generic_Package (Current_Scope)
- and then In_Private_Part (Current_Scope)
- and then Parent (E) /= Parent (S)
- and then Alias (E) = Alias (S)
- then
- Check_Operation_From_Private_View (S, E);
- else
- goto Add_New_Entity;
- end if;
- end if;
-
Check_Synchronized_Overriding (S, Overridden_Subp);
-- Loop through E and its homonyms to determine if any of them is
E := Homonym (E);
end loop;
- <<Add_New_Entity>>
-
-- On exit, we know that S is a new entity
Enter_Overloaded_Entity (S);
Is_Interface
(Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
- -- Search in the homonym chain
+ -- Search in the homonym chain. Done to speed up locating visible
+ -- entities and required to catch primitives associated with the partial
+ -- view of private types when processing the corresponding full view.
E := Current_Entity (Iface_Prim);
while Present (E) loop
E := Homonym (E);
end loop;
- -- Search in the list of primitives of the type
+ -- Search in the list of primitives of the type. Required to locate the
+ -- covering primitive if the covering primitive is not visible (for
+ -- example, non-visible inherited primitive of private type).
El := First_Elmt (Primitive_Operations (Tagged_Type));
while Present (El) loop
E := Node (El);
- if No (Interface_Alias (E))
- and then Alias (E) = Iface_Prim
- then
- return Node (El);
+ -- Keep separate the management of internal entities that link
+ -- primitives with interface primitives from tagged type primitives.
+
+ if No (Interface_Alias (E)) then
+ if Present (Alias (E)) then
+
+ -- This interface primitive has not been covered yet
+
+ if Alias (E) = Iface_Prim then
+ return E;
+
+ -- The covering primitive was inherited
+
+ elsif Overridden_Operation (Ultimate_Alias (E))
+ = Iface_Prim
+ then
+ return E;
+ end if;
+ end if;
+
+ -- Use the internal entity that links the interface primitive with
+ -- the covering primitive to locate the entity
+
+ elsif Interface_Alias (E) = Iface_Prim then
+ return Alias (E);
end if;
Next_Elmt (El);
-- associated with the partial view of private types when processing the
-- corresponding full view. If the entity is not found then search for it
-- in the list of primitives of Tagged_Type. This latter search is needed
- -- when the interface primitive is covered by a private subprogram.
+ -- when the interface primitive is covered by a private subprogram. If the
+ -- primitive has not been covered yet then return the entity that will be
+ -- overriden when the primitive is covered (that is, return the entity
+ -- whose alias attribute references the interface primitive). If none of
+ -- these entities is found then return Empty.
function Is_Dynamically_Tagged (N : Node_Id) return Boolean;
-- Used to determine whether a call is dispatching, i.e. if is an
projects / platform / upstream / linaro-gcc.git / commitdiff