[Ada] Duplicated primitive operations and function wrappers for null extensions

[Arnaud Charlet]

Tested on i686-linux, committed on trunk.

PR ada/34149
In Ada2005, an inherited function of a null extension that dispatches on result
is not abstract. For such functions we generate a wrapper that returns an
extension aggregate. The wrapper function overrides the inherited operation and
therefore replaces it in the dispatch table. However, processing the body of
the wrapper led to an additional insertion of the function into the list of
primitive operations of the type. This duplication caused chaos on further
null extensions of the derived type.

This patch integrates and improves the one submitted by Sam Tardieu for this PR.

A few other clean ups are also done in handling of Ada 2005 constructs.

2007-12-19  Gary Dismukes  <dismukes@adacore.com>

	PR ada/34149
	* sem_disp.adb (Check_Dispatching_Call): Augment existing test for
	presence of a statically tagged operand (Present (Static_Tag)) with
	test for Indeterm_Ancestor_Call when determining whether to propagate
	the static tag to tag-indeterminate operands (which forces dispatching
	on such calls).
	(Check_Controlling_Formals): Ada2005, access parameters can have
	defaults.
	(Add_Dispatching_Operation, Check_Operation_From_Private_View): do
	not insert subprogram in list of primitive operations if already there.

-------------- next part --------------
Index: sem_disp.adb
===================================================================
--- sem_disp.adb	(revision 131064)
+++ sem_disp.adb	(working copy)
@@ -79,8 +79,14 @@ package body Sem_Disp is
       New_Op      : Entity_Id)
    is
       List : constant Elist_Id := Primitive_Operations (Tagged_Type);
+
    begin
-      Append_Elmt (New_Op, List);
+      --  The dispatching operation may already be on the list, if it the
+      --  wrapper for an inherited function of a null extension (see exp_ch3
+      --  for the construction of function wrappers). The list of primitive
+      --  operations must not contain duplicates.
+
+      Append_Unique_Elmt (New_Op, List);
    end Add_Dispatching_Operation;
 
    -------------------------------
@@ -143,7 +149,12 @@ package body Sem_Disp is
                end if;
 
                if Present (Default_Value (Formal)) then
-                  if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
+
+                  --  In Ada 2005, access parameters can have defaults
+
+                  if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+                    and then Ada_Version < Ada_05
+                  then
                      Error_Msg_N
                        ("default not allowed for controlling access parameter",
                         Default_Value (Formal));
@@ -471,10 +482,12 @@ package body Sem_Disp is
             Set_Controlling_Argument (N, Control);
             Check_Restriction (No_Dispatching_Calls, N);
 
-         --  If there is a statically tagged actual, check whether
-         --  some tag-indeterminate actual can use it.
+         --  If there is a statically tagged actual and a tag-indeterminate
+         --  call to a function of the ancestor (such as that provided by a
+         --  default), then treat this as a dispatching call and propagate
+         --  the tag to the tag-indeterminate call(s).
 
-         elsif Present (Static_Tag) then
+         elsif Present (Static_Tag) and then Indeterm_Ancestor_Call then
             Control :=
               Make_Attribute_Reference (Loc,
                 Prefix         =>
@@ -1091,8 +1104,10 @@ package body Sem_Disp is
          Set_Scope (Subp, Current_Scope);
          Tagged_Type := Find_Dispatching_Type (Subp);
 
+         --  Add Old_Subp to primitive operations if not already present.
+
          if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
-            Append_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
+            Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
 
             --  If Old_Subp isn't already marked as dispatching then
             --  this is the case of an operation of an untagged private