[Ada] fix in handling of tagged types

[Arnaud Charlet <charlet at adacore dot com>]

Tested on i686-linux, committed on trunk

If type T2 is a null extension of T1,and there exists a primitive function
of T1 with a controlling result, then the operation inherited by T2 is not
abstract, but must be implemented by means of wrapper that constructs an
extension aggregate of T1. This patch fixes a bug in the predicate that
determines when such a wrapper must be  generated. Previously there were
cases where the operation was inherited directly, and constructing objects
with.an inconsistent tag.

execution of Lo_Tomo must yield:

TOMALO.DERIV
TOMALO.DERIV
TOMALO.DERIV

with Ada.Tags;    use Ada.Tags;
with Ada.Text_IO; use Ada.Text_IO;
with Tomalo;      use Tomalo;

procedure Lo_Tomo is
    procedure Show_Me (D : Deriv) is
    begin
       Put_Line (External_Tag (Root'Class (D)'Tag));
    end Show_Me;

    CWD : Deriv'Class := Build;

begin
    Put_Line (External_Tag (CWD'Tag));
    Put_Line (Expanded_Name (CWD'Tag));
    Show_Me (Build);
end;

package Tomalo is
    type Root is tagged record
       thing : Integer;
    end record;
    function Build return Root;

    type Deriv is new Root with null record;
end Tomalo;

package body Tomalo is
    function Build return Root is
    begin
       return (thing => 15);
    end Build;
end Tomalo;

---
Also, if a record type uses a discriminant (that is an access type) to
initialize one of its components, then the frontend did not generate
the code that initializes the hidden components associated with the
interface types. After this patch gnat.dg/discr4.adb compiles and
executes well.

--
Finally, the following program:

function f (x : integer) return integer;

with Text_IO; use Text_IO;
function f (x : integer) return integer is
begin
   Put_Line ("f called with argument" & x'Img);
   return x;
end;

with f;
package q is
   type r1 is record
      x : integer := f (1);
   end record;

   type r2 is record
      x : integer := f (2);
   end record;
   pragma Suppress_Initialization (r2);

   type r3 is new r1;
   pragma Suppress_Initialization (r3);

   type r4 is new r2;

   v1 : r1;
   v2 : r2;
   v3 : r3;
   v4 : r4;
end q;

with q;
procedure m is begin null; end;

Should yield the output for main program m:

f called with argument 1
f called with argument 2

Before this patch, v4 was generating output, so the output was
three lines instead of 2.

2007-08-14  Thomas Quinot  <quinot@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* exp_ch3.ads, exp_ch3.adb (Add_Final_Chain): New subprogram.
	(Freeze_Array_Type, Freeze_Record_Type): For the case of a component
	type that is an anonymous access to controlled object, establish
	an associated finalization chain to avoid corrupting the global
	finalization list when a dynamically allocated object designated
	by such a component is deallocated.
	(Make_Controlling_Function_Wrappers): Create wrappers for constructor
	functions that need it, even when not marked Requires_Overriding.
	(Initialize_Tag): Replace call to has_discriminants by call to
	Is_Variable_Size_Record in the circuitry that handles the
	initialization of secondary tags.
	(Is_Variable_Size_Record): New implementation.
	(Expand_N_Object_Declaration): Suppress call to init proc if there is a
	Suppress_Initialization pragma for a derived type.
	(Is_Variable_Size_Record): New subprogram.
	(Build_Offset_To_Top_Functions): New implementation that simplifies the
	initial version of this routine and also fixes problems causing
	incomplete initialization of the table of interfaces.
	(Build_Init_Procedure): Improve the generation of code to initialize the
	the tag components of secondary dispatch tables.
	(Init_Secondary_Tags): New implementation that simplifies the previous
	version of this routine.
	(Make_DT): Add parameter to indicate when type has been frozen by an
	object declaration, for diagnostic purposes.
	(Check_Premature_Freezing): New subsidiary procedure of Make_DT, to
	diagnose attemps to freeze a subprogram when some untagged type of its
	profile is a private type whose full view has not been analyzed yet.
	(Freeze_Array_Type): Generate init proc for packed array if either
	Initialize or Normalize_Scalars is set.
	(Make_Controlling_Function_Wrappers, Make_Null_Procedure_Specs): when
	constructing the new profile, copy the null_exclusion indicator for each
	parameter, to ensure full conformance of the new body with the spec.

	* sem_type.ads, sem_type.adb (Make_Controlling_Function_Wrappers):
	Create wrappers for constructor functions that need it, even when not
	marked Requires_Overriding.
	(Covers): Handle properly designated types of anonymous access types,
	whose non-limited views are themselves incomplete types.
	(Add_Entry): Use an entity to store the abstract operation which hides
	an interpretation.
	(Binary_Op_May_Be_Hidden): Rename to Binary_Op_Interp_Has_Abstract_Op.
	(Collect_Interps): Use Empty as an actual for Abstract_Op in the
	initialization aggregate.
	(Function_Interp_May_Be_Hidden): Rename to
	Function_Interp_Has_Abstract_Op.
	(Has_Compatible_Type): Remove machinery that skips interpretations if
	they are labeled as potentially hidden by an abstract operator.
	(Has_Hidden_Interp): Rename to Has_Abstract_Op.
	(Set_May_Be_Hidden): Rename to Set_Abstract_Op.
	(Write_Overloads): Output the abstract operator if present.
	(Add_Entry): Before inserting a new entry into the interpretation table
	for a node, determine whether the entry will be disabled by an abstract
	operator.
	(Binary_Op_Interp_May_Be_Hidden): New routine.
	(Collect_Interps): Add value for flag May_Be_Hidden in initialization
	aggregate.
	(Function_Interp_May_Be_Hidden): New routine.
	(Has_Compatible_Type): Do not consider interpretations hidden by
	abstract operators when trying to determine whether two types are
	compatible.
	(Has_Hidden_Interp): New routine.
	(Set_May_Be_Hidden_Interp): New routine.
	(Write_Overloads): Write the status of flag May_Be_Hidden.

Attachment: difs
Description: Text document