re PR ada/20300 (ICE on undefined value of type derived from Character)

2005-03-29  Gary Dismukes  <dismukes@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* exp_intr.adb (Expand_Dispatching_Constructor_Call): New procedure to
	expand a call to an instance of
	Ada.Tags.Generic_Dispatching_Constructor into a dispatching call to the
	Constructor actual of the instance. A class-wide membership
	check is also generated, to ensure that the tag passed to the instance
	denotes a type in the class.
	(Expand_Intrinsic_Call): Call Expand_Dispatching_Constructor in the case
	of Name_Generic_Dispatching_Constructor.

	* Makefile.rtl: Add a-tgdico.ads to the list of library units (new Ada
	05 unit for AI-260-02).

	* a-tgdico.ads: New file.

	* impunit.adb (Non_Imp_File_Names_05): Add entry "a-tgdico" for new
	predefined Ada 05 generic unit Ada.Tags.Generic_Dispatching_Constructor.

	* snames.ads, snames.adb (Preset_Names): Add entry for
	Generic_Dispatching_Constructor.

	PR ada/20300

	* sem_ch8.adb (Find_Direct_Name): Go to root type for check of
	character type cases.
	(Analyze_Subprogram_Renaming): Add special handling for
	the case of renaming of stream attributes when the renaming denotes a
	generic formal subprogram association for an abstract formal subprogram.
	Check that the attribute is a primitive stream attribute (and not
	a class-wide stream attribute) and then rewrite the attribute name
	as the name of the appropriate compiler-generated stream primitive.

From-SVN: r97172

gcc/ada/Makefile.rtl

@@ -212,6 +212,7 @@ GNATRTL_NONTASKING_OBJS= \
   a-szunha$(objext) \
   a-szuzti$(objext) \
   a-tags$(objext) \
+  a-tgdico$(objext) \
   a-teioed$(objext) \
   a-textio$(objext) \
   a-ticoau$(objext) \

gcc/ada/a-tgdico.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                 ADA.TAGS.GENERIC_DISPATCHING_CONSTRUCTOR                 --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+-- This specification is adapted from the Ada Reference Manual for use with --
+-- GNAT.  In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification,  provided that if you redistribute a --
+-- modified version,  any changes that you have made are clearly indicated. --
+--                                                                          --
+------------------------------------------------------------------------------
+
+generic
+   type T (<>) is abstract tagged limited private;
+   type Parameters (<>) is limited private;
+   with function Constructor (Params : access Parameters) return T is abstract;
+
+function Ada.Tags.Generic_Dispatching_Constructor
+  (The_Tag : Tag; Params : access Parameters) return T'Class;
+
+--  pragma Preelaborate (Generic_Dispatching_Constructor);
+--  Commented out temporarily because various other predefined units do not
+--  yet have proper categorization as specified by AI-362 (such as Ada.Tags,
+--  Ada.Exceptions, etc.).
+
+pragma Import (Intrinsic, Generic_Dispatching_Constructor);

gcc/ada/exp_intr.adb

@@ -26,11 +26,13 @@
 
 with Atree;    use Atree;
 with Einfo;    use Einfo;
+with Elists;   use Elists;
 with Errout;   use Errout;
 with Exp_Ch4;  use Exp_Ch4;
 with Exp_Ch7;  use Exp_Ch7;
 with Exp_Ch11; use Exp_Ch11;
 with Exp_Code; use Exp_Code;
+with Exp_Disp; use Exp_Disp;
 with Exp_Fixd; use Exp_Fixd;
 with Exp_Util; use Exp_Util;
 with Itypes;   use Itypes;
@@ -61,6 +63,13 @@ package body Exp_Intr is
    procedure Expand_Is_Negative (N : Node_Id);
    --  Expand a call to the intrinsic Is_Negative function
 
+   procedure Expand_Dispatching_Constructor_Call (N : Node_Id);
+   --  Expand a call to an instantiation of Generic_Dispatching_Constructor
+   --  into a dispatching call to the actual subprogram associated with the
+   --  Constructor formal subprogram, passing it the Parameters actual of
+   --  the call to the instantiation and dispatching based on call's Tag
+   --  parameter.
+
    procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id);
    --  Expand a call to Exception_Information/Message/Name. The first
    --  parameter, N, is the node for the function call, and Ent is the
@@ -96,6 +105,77 @@ package body Exp_Intr is
    --    Name_Source_Location  - expand string of form file:line
    --    Name_Enclosing_Entity - expand string  with name of enclosing entity
 
+   -----------------------------------------
+   -- Expand_Dispatching_Constructor_Call --
+   -----------------------------------------
+
+   --  Transform a call to an instantiation of Generic_Dispatching_Constructor
+   --  of the form:
+
+   --     GDC_Instance (The_Tag, Parameters'Access)
+
+   --  to a class-wide conversion of a dispatching call to the actual
+   --  associated with the formal subprogram Construct, designating
+   --  The_Tag as the controlling tag of the call:
+
+   --     T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag
+
+   --  which will eventually be expanded to the following:
+
+   --     T'Class (The_Tag.all (Construct'Actual'Index).all (Params))
+
+   --  A class-wide membership test is also generated, preceding the call,
+   --  to ensure that the controlling tag denotes a type in T'Class.
+
+   procedure Expand_Dispatching_Constructor_Call (N : Node_Id) is
+      Loc        : constant Source_Ptr := Sloc (N);
+      Tag_Arg    : constant Node_Id    := First_Actual (N);
+      Param_Arg  : constant Node_Id    := Next_Actual (Tag_Arg);
+      Subp_Decl  : constant Node_Id    := Parent (Parent (Entity (Name (N))));
+      Inst_Pkg   : constant Node_Id    := Parent (Subp_Decl);
+      Act_Rename : constant Node_Id    :=
+                     Next (Next (First (Visible_Declarations (Inst_Pkg))));
+      Act_Constr : constant Entity_Id  := Entity (Name (Act_Rename));
+      Result_Typ : constant Entity_Id  := Class_Wide_Type (Etype (Act_Constr));
+      Cnstr_Call : Node_Id;
+
+   begin
+      --  Create the call to the actual Constructor function
+
+      Cnstr_Call :=
+        Make_Function_Call (Loc,
+          Name                   => New_Occurrence_Of (Act_Constr, Loc),
+          Parameter_Associations => New_List (Relocate_Node (Param_Arg)));
+
+      --  Establish its controlling tag from the tag passed to the instance
+
+      Set_Controlling_Argument (Cnstr_Call, Relocate_Node (Tag_Arg));
+
+      --  Rewrite and analyze the call to the instance as a class-wide
+      --  conversion of the call to the actual constructor.
+
+      Rewrite (N, Convert_To (Result_Typ, Cnstr_Call));
+      Analyze_And_Resolve (N, Etype (Act_Constr));
+
+      --  Generate a class-wide membership test to ensure that the call's tag
+      --  argument denotes a type within the class.
+
+      Insert_Action (N,
+        Make_Implicit_If_Statement (N,
+          Condition =>
+            Make_Op_Not (Loc,
+              Make_DT_Access_Action (Result_Typ,
+                 Action => CW_Membership,
+                 Args   => New_List (
+                   Duplicate_Subexpr (Tag_Arg),
+                   New_Reference_To (
+                     Node (First_Elmt (Access_Disp_Table (
+                                         Root_Type (Result_Typ)))), Loc)))),
+          Then_Statements =>
+            New_List (Make_Raise_Statement (Loc,
+                        New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
+   end Expand_Dispatching_Constructor_Call;
+
    ---------------------------
    -- Expand_Exception_Call --
    ---------------------------
@@ -236,6 +316,9 @@ package body Exp_Intr is
       elsif Nam = Name_Exception_Name then
          Expand_Exception_Call (N, RE_Exception_Name_Simple);
 
+      elsif Nam = Name_Generic_Dispatching_Constructor then
+         Expand_Dispatching_Constructor_Call (N);
+
       elsif Nam = Name_Import_Address
               or else
             Nam = Name_Import_Largest_Value

gcc/ada/impunit.adb

@@ -363,6 +363,7 @@ package body Impunit is
      "a-swunha",    -- Ada.Strings.Wide_Unbounded.Hash
      "a-szmzco",    -- Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants;
      "a-szunha",    -- Ada.Strings.Wide_Wide_Unbounded.Hash
+     "a-tgdico",    -- Ada.Tags.Generic_Dispatching_Constructor;
      "a-tiunio",    -- Ada.Text_IO.Unbounded_IO;
      "a-wwunio",    -- Ada.Wide_Text_IO.Wide_Unbounded_IO;
      "a-zttest",    -- Ada.Wide_Wide_Text_IO.Text_Streams

gcc/ada/sem_ch8.adb

@@ -29,6 +29,7 @@ with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
+with Exp_Tss;  use Exp_Tss;
 with Exp_Util; use Exp_Util;
 with Fname;    use Fname;
 with Freeze;   use Freeze;
@@ -1102,10 +1103,11 @@ package body Sem_Ch8 is
       Save_AV     : constant Ada_Version_Type := Ada_Version;
       Nam         : constant Node_Id          := Name (N);
       New_S       : Entity_Id;
-      Old_S       : Entity_Id  := Empty;
+      Old_S       : Entity_Id                 := Empty;
       Rename_Spec : Entity_Id;
-      Is_Actual   : Boolean    := False;
-      Inst_Node   : Node_Id    := Empty;
+      Formal_Spec : constant Node_Id          := Corresponding_Formal_Spec (N);
+      Is_Actual   : constant Boolean          := Present (Formal_Spec);
+      Inst_Node   : Node_Id                   := Empty;
 
       function Original_Subprogram (Subp : Entity_Id) return Entity_Id;
       --  Find renamed entity when the declaration is a renaming_as_body
@@ -1167,8 +1169,75 @@ package body Sem_Ch8 is
       --  is missing an argument when it is analyzed.
 
       if Nkind (Nam) = N_Attribute_Reference then
-         Attribute_Renaming (N);
-         return;
+
+         --  In the case of an abstract formal subprogram association,
+         --  rewrite an actual given by a stream attribute as the name
+         --  of the corresponding stream primitive of the type.
+
+         if Is_Actual and then Is_Abstract (Formal_Spec) then
+            declare
+               Stream_Prim : Entity_Id;
+               Prefix_Type : constant Entity_Id := Entity (Prefix (Nam));
+
+            begin
+               --  The class-wide forms of the stream attributes are not
+               --  primitive dispatching operations (even though they
+               --  internally dispatch to a stream attribute).
+
+               if Is_Class_Wide_Type (Prefix_Type) then
+                  Error_Msg_N
+                    ("attribute must be a primitive dispatching operation",
+                     Nam);
+                  return;
+               end if;
+
+               --  Retrieve the primitive subprogram associated with the
+               --  attribute. This can only be a stream attribute, since
+               --  those are the only ones that are dispatching (and the
+               --  actual for an abstract formal subprogram must be a
+               --  dispatching operation).
+
+               case Attribute_Name (Nam) is
+                  when Name_Input  =>
+                     Stream_Prim :=
+                       Find_Prim_Op (Prefix_Type, TSS_Stream_Input);
+                  when Name_Output =>
+                     Stream_Prim :=
+                       Find_Prim_Op (Prefix_Type, TSS_Stream_Output);
+                  when Name_Read   =>
+                     Stream_Prim :=
+                       Find_Prim_Op (Prefix_Type, TSS_Stream_Read);
+                  when Name_Write  =>
+                     Stream_Prim :=
+                       Find_Prim_Op (Prefix_Type, TSS_Stream_Write);
+                  when others      =>
+                     Error_Msg_N
+                       ("attribute must be a primitive dispatching operation",
+                        Nam);
+                     return;
+               end case;
+
+               --  Rewrite the attribute into the name of its corresponding
+               --  primitive dispatching subprogram. We can then proceed with
+               --  the usual processing for subprogram renamings.
+
+               declare
+                  Prim_Name : constant Node_Id :=
+                                Make_Identifier (Sloc (Nam),
+                                  Chars => Chars (Stream_Prim));
+               begin
+                  Set_Entity (Prim_Name, Stream_Prim);
+                  Rewrite (Nam, Prim_Name);
+                  Analyze (Nam);
+               end;
+            end;
+
+         --  Normal processing for a renaming of an attribute
+
+         else
+            Attribute_Renaming (N);
+            return;
+         end if;
       end if;
 
       --  Check whether this declaration corresponds to the instantiation
@@ -1183,9 +1252,8 @@ package body Sem_Ch8 is
       --  is determined in Find_Renamed_Entity. If the entity is an operator,
       --  Find_Renamed_Entity applies additional visibility checks.
 
-      if Present (Corresponding_Formal_Spec (N)) then
-         Is_Actual := True;
-         Inst_Node := Unit_Declaration_Node (Corresponding_Formal_Spec (N));
+      if Is_Actual then
+         Inst_Node := Unit_Declaration_Node (Formal_Spec);
 
          if Is_Entity_Name (Nam)
            and then Present (Entity (Nam))
@@ -1477,9 +1545,7 @@ package body Sem_Ch8 is
             --  indicate that the renaming is an abstract dispatching operation
             --  with a controlling type.
 
-            if Is_Actual
-              and then Is_Abstract (Corresponding_Formal_Spec (N))
-            then
+            if Is_Actual and then Is_Abstract (Formal_Spec) then
                --  Mark the renaming as abstract here, so Find_Dispatching_Type
                --  see it as corresponding to a generic association for a
                --  formal abstract subprogram
@@ -1547,7 +1613,7 @@ package body Sem_Ch8 is
 
             if (Ekind (Old_S) = E_Procedure or else Ekind (Old_S) = E_Function)
               and then Is_Abstract (Old_S)
-              and then not Is_Abstract (Corresponding_Formal_Spec (N))
+              and then not Is_Abstract (Formal_Spec)
             then
                Error_Msg_N
                  ("abstract subprogram not allowed as generic actual", Nam);
@@ -2801,14 +2867,15 @@ package body Sem_Ch8 is
                Case_Str : constant String    := Name_Buffer (1 .. Name_Len);
                Case_Stm : constant Node_Id   := Parent (Parent (N));
                Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm));
+               Case_Rtp : constant Entity_Id := Root_Type (Case_Typ);
 
                Lit : Node_Id;
 
             begin
                if Is_Enumeration_Type (Case_Typ)
-                 and then Case_Typ /= Standard_Character
-                 and then Case_Typ /= Standard_Wide_Character
-                 and then Case_Typ /= Standard_Wide_Wide_Character
+                 and then Case_Rtp /= Standard_Character
+                 and then Case_Rtp /= Standard_Wide_Character
+                 and then Case_Rtp /= Standard_Wide_Wide_Character
                then
                   Lit := First_Literal (Case_Typ);
                   Get_Name_String (Chars (Lit));

gcc/ada/snames.adb

@@ -607,6 +607,7 @@ package body Snames is
      "exception_message#" &
      "exception_name#" &
      "file#" &
+     "generic_dispatching_constructor#" &
      "import_address#" &
      "import_largest_value#" &
      "import_value#" &