Patchwork [Ada] Cleanup analysis of concurrent types that implement interfaces

login
register
mail settings
Submitter Arnaud Charlet
Date June 22, 2010, 4:48 p.m.
Message ID <20100622164815.GA29191@adacore.com>
Download mbox | patch
Permalink /patch/56529/
State New
Headers show

Comments

Arnaud Charlet - June 22, 2010, 4:48 p.m.
The analysis of a generic unit containing a concurrent type that covers
interfaces previously required building the corresponding record type.
This patch avoids such requirement, which leaves the frontend more
clean because the corresponding record type is only required for
code generation.

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-06-22  Javier Miranda  <miranda@adacore.com>

	* sem_ch4.adb (Collect_Generic_Type_Ops): Protect code that handles
	generic subprogram declarations to ensure proper context. Add missing
	support for generic actuals.
	(Try_Primitive_Operation): Add missing support for concurrent types that
	have no Corresponding_Record_Type. Required to diagnose errors compiling
	generics or when compiling with no code generation (-gnatc).
	* sem_ch9.adb (Analyze_Protected_Type, Analyze_Task_Type): Do not build
	the corresponding record type.
	* sem_disp.ads, sem_disp.adb (Check_Dispatching_Operation): Complete
	documentation. Do minimum decoration when processing a primitive of a
	concurrent tagged type that covers interfaces. Required to diagnose
	errors in the Object.Operation notation compiling generics or under
	-gnatc.
	* exp_ch9.ads, exp_ch9.adb (Build_Corresponding_Record): Add missing
	propagation of attribute Interface_List to the corresponding record.
	(Expand_N_Task_Type_Declaration): Code cleanup.
	(Expand_N_Protected_Type_Declaration): Code cleanup.

Patch

Index: exp_ch9.ads
===================================================================
--- exp_ch9.ads	(revision 161073)
+++ exp_ch9.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -50,14 +50,6 @@  package Exp_Ch9 is
    --  Task_Id of the associated task as the parameter. The caller is
    --  responsible for analyzing and resolving the resulting tree.
 
-   function Build_Corresponding_Record
-     (N    : Node_Id;
-      Ctyp : Node_Id;
-      Loc  : Source_Ptr) return Node_Id;
-   --  Common to tasks and protected types. Copy discriminant specifications,
-   --  build record declaration. N is the type declaration, Ctyp is the
-   --  concurrent entity (task type or protected type).
-
    function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id;
    --  Create the statements which populate the entry names array of a task or
    --  protected type. The statements are wrapped inside a block due to a local
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb	(revision 161073)
+++ exp_ch9.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -128,6 +128,14 @@  package body Exp_Ch9 is
    --  Build a specification for a function implementing the protected entry
    --  barrier of the specified entry body.
 
+   function Build_Corresponding_Record
+     (N    : Node_Id;
+      Ctyp : Node_Id;
+      Loc  : Source_Ptr) return Node_Id;
+   --  Common to tasks and protected types. Copy discriminant specifications,
+   --  build record declaration. N is the type declaration, Ctyp is the
+   --  concurrent entity (task type or protected type).
+
    function Build_Entry_Count_Expression
      (Concurrent_Type : Node_Id;
       Component_List  : List_Id;
@@ -1037,8 +1045,9 @@  package body Exp_Ch9 is
       --  record is "limited tagged". It is "limited" to reflect the underlying
       --  limitedness of the task or protected object that it represents, and
       --  ensuring for example that it is properly passed by reference. It is
-      --  "tagged" to give support to dispatching calls through interfaces (Ada
-      --  2005: AI-345)
+      --  "tagged" to give support to dispatching calls through interfaces. We
+      --  propagate here the list of interfaces covered by the concurrent type
+      --  (Ada 2005: AI-345).
 
       return
         Make_Full_Type_Declaration (Loc,
@@ -1051,6 +1060,7 @@  package body Exp_Ch9 is
                   Component_Items => Cdecls),
               Tagged_Present  =>
                  Ada_Version >= Ada_05 and then Is_Tagged_Type (Ctyp),
+              Interface_List  => Interface_List (N),
               Limited_Present => True));
    end Build_Corresponding_Record;
 
@@ -7682,11 +7692,6 @@  package body Exp_Ch9 is
 
       Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl)));
 
-      --  Ada 2005 (AI-345): Propagate the attribute that contains the list
-      --  of implemented interfaces.
-
-      Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N));
-
       Qualify_Entity_Names (N);
 
       --  If the type has discriminants, their occurrences in the declaration
@@ -9946,11 +9951,6 @@  package body Exp_Ch9 is
 
       Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
 
-      --  Ada 2005 (AI-345): Propagate the attribute that contains the list
-      --  of implemented interfaces.
-
-      Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N));
-
       Rec_Ent  := Defining_Identifier (Rec_Decl);
       Cdecls   := Component_Items (Component_List
                                      (Type_Definition (Rec_Decl)));
Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb	(revision 161076)
+++ sem_ch9.adb	(working copy)
@@ -1176,16 +1176,6 @@  package body Sem_Ch9 is
 
       Set_Is_Constrained (T, not Has_Discriminants (T));
 
-      --  Perform minimal expansion of protected type while inside a generic.
-      --  The corresponding record is needed for various semantic checks.
-
-      if Ada_Version >= Ada_05
-        and then Inside_A_Generic
-      then
-         Insert_After_And_Analyze (N,
-           Build_Corresponding_Record (N, T, Sloc (T)));
-      end if;
-
       Analyze (Protected_Definition (N));
 
       --  Protected types with entries are controlled (because of the
@@ -1976,15 +1966,6 @@  package body Sem_Ch9 is
 
       Set_Is_Constrained (T, not Has_Discriminants (T));
 
-      --  Perform minimal expansion of the task type while inside a generic
-      --  context. The corresponding record is needed for various semantic
-      --  checks.
-
-      if Inside_A_Generic then
-         Insert_After_And_Analyze (N,
-           Build_Corresponding_Record (N, T, Sloc (T)));
-      end if;
-
       if Present (Task_Definition (N)) then
          Analyze_Task_Definition (Task_Definition (N));
       end if;
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 161148)
+++ sem_ch4.adb	(working copy)
@@ -6880,23 +6880,26 @@  package body Sem_Ch4 is
                --  Scan the list of generic formals to find subprograms
                --  that may have a first controlling formal of the type.
 
-               declare
-                  Decl : Node_Id;
-
-               begin
-                  Decl :=
-                    First (Generic_Formal_Declarations
-                            (Unit_Declaration_Node (Scope (T))));
-                  while Present (Decl) loop
-                     if Nkind (Decl) in N_Formal_Subprogram_Declaration then
-                        Subp := Defining_Entity (Decl);
-                        Check_Candidate;
-                     end if;
-
-                     Next (Decl);
-                  end loop;
-               end;
+               if Nkind (Unit_Declaration_Node (Scope (T)))
+                 = N_Generic_Subprogram_Declaration
+               then
+                  declare
+                     Decl : Node_Id;
 
+                  begin
+                     Decl :=
+                       First (Generic_Formal_Declarations
+                               (Unit_Declaration_Node (Scope (T))));
+                     while Present (Decl) loop
+                        if Nkind (Decl) in N_Formal_Subprogram_Declaration then
+                           Subp := Defining_Entity (Decl);
+                           Check_Candidate;
+                        end if;
+
+                        Next (Decl);
+                     end loop;
+                  end;
+               end if;
                return Candidates;
 
             else
@@ -6906,7 +6909,15 @@  package body Sem_Ch4 is
                --  declaration or body (either the one that declares T, or a
                --  child unit).
 
-               Subp := First_Entity (Scope (T));
+               --  For a subtype representing a generic actual type, go to the
+               --  base type.
+
+               if Is_Generic_Actual_Type (T) then
+                  Subp := First_Entity (Scope (Base_Type (T)));
+               else
+                  Subp := First_Entity (Scope (T));
+               end if;
+
                while Present (Subp) loop
                   if Is_Overloadable (Subp) then
                      Check_Candidate;
@@ -6979,13 +6990,14 @@  package body Sem_Ch4 is
          --  corresponding record (base) type.
 
          if Is_Concurrent_Type (Obj_Type) then
-            if not Present (Corresponding_Record_Type (Obj_Type)) then
-               return False;
+            if Present (Corresponding_Record_Type (Obj_Type)) then
+               Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
+               Elmt := First_Elmt (Primitive_Operations (Corr_Type));
+            else
+               Corr_Type := Obj_Type;
+               Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type));
             end if;
 
-            Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
-            Elmt := First_Elmt (Primitive_Operations (Corr_Type));
-
          elsif not Is_Generic_Type (Obj_Type) then
             Corr_Type := Obj_Type;
             Elmt := First_Elmt (Primitive_Operations (Obj_Type));
Index: sem_disp.adb
===================================================================
--- sem_disp.adb	(revision 161141)
+++ sem_disp.adb	(working copy)
@@ -677,18 +677,15 @@  package body Sem_Disp is
       Set_Is_Dispatching_Operation (Subp, False);
       Tagged_Type := Find_Dispatching_Type (Subp);
 
-      --  Ada 2005 (AI-345)
+      --  Ada 2005 (AI-345): Use the corresponding record (if available).
+      --  Required because primitives of concurrent types are be attached
+      --  to the corresponding record (not to the concurrent type).
 
       if Ada_Version >= Ada_05
         and then Present (Tagged_Type)
         and then Is_Concurrent_Type (Tagged_Type)
+        and then Present (Corresponding_Record_Type (Tagged_Type))
       then
-         --  Protect the frontend against previously detected errors
-
-         if No (Corresponding_Record_Type (Tagged_Type)) then
-            return;
-         end if;
-
          Tagged_Type := Corresponding_Record_Type (Tagged_Type);
       end if;
 
@@ -1068,6 +1065,18 @@  package body Sem_Disp is
             end if;
          end if;
 
+      --  If the tagged type is a concurrent type then we must be compiling
+      --  with no code generation (we are either compiling a generic unit or
+      --  compiling under -gnatc mode) because we have previously tested that
+      --  no serious errors has been reported. In this case we do not add the
+      --  primitive to the list of primitives of Tagged_Type but we leave the
+      --  primitive decorated as a dispatching operation to be able to analyze
+      --  and report errors associated with the Object.Operation notation.
+
+      elsif Is_Concurrent_Type (Tagged_Type) then
+         pragma Assert (not Expander_Active);
+         null;
+
       --  If no old subprogram, then we add this as a dispatching operation,
       --  but we avoid doing this if an error was posted, to prevent annoying
       --  cascaded errors.
Index: sem_disp.ads
===================================================================
--- sem_disp.ads	(revision 161073)
+++ sem_disp.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -46,7 +46,12 @@  package Sem_Disp is
    --  if it has a parameter of this type and is defined at a proper place for
    --  primitive operations (new primitives are only defined in package spec,
    --  overridden operation can be defined in any scope). If Old_Subp is not
-   --  Empty we are in the overriding case.
+   --  Empty we are in the overriding case. If the tagged type associated with
+   --  Subp is a concurrent type (case that occurs when the type is declared in
+   --  a generic because the analysis of generics disables generation of the
+   --  corresponding record) then this routine does does not add "Subp" to the
+   --  list of primitive operations but leaves Subp decorated as dispatching
+   --  operation to enable checks associated with the Object.Operation notation
 
    procedure Check_Operation_From_Incomplete_Type
      (Subp : Entity_Id;