Patchwork [Ada] Component of protected object cannot be denoted by a selected component

login
register
mail settings
Submitter Arnaud Charlet
Date June 17, 2010, 2:27 p.m.
Message ID <20100617142729.GA7786@adacore.com>
Download mbox | patch
Permalink /patch/56054/
State New
Headers show

Comments

Arnaud Charlet - June 17, 2010, 2:27 p.m.
This change adds a missing diagnostic for illegal code attempting to denote
a component of an object of a protected type using a selected component.
Such illegal usage might previously cause a crash of the compiler.

The following compilation must be rejected with the two error messages:
selected_protected_component.adb:6:20: invisible selector "IntC" for type "Parent" defined at selected_protected_component.ads:5
selected_protected_component.adb:7:16: invisible selector "IntC" for type "Parent" defined at selected_protected_component.ads:5

package Selected_Protected_Component is
   type Parent;
   type Ptr is access Parent;

   protected type Parent is
      procedure Delete (O : in out Ptr);
   private
      IntC : Integer;
   end Parent;
end Selected_Protected_Component;

package body Selected_Protected_Component is
   protected body Parent is
      procedure Delete (O : in out Ptr) is
         I : Integer;
      begin
         I := O.all.IntC;
         I := O.IntC;
      end delete;
   end Parent;
end Selected_Protected_Component;

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

2010-06-17  Thomas Quinot  <quinot@adacore.com>

	* sem_ch4.adb (Analyze_Selected_Component): A selected component may
	not denote a (private) component of a protected object.

Patch

Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 160897)
+++ sem_ch4.adb	(working copy)
@@ -3105,8 +3105,8 @@  package body Sem_Ch4 is
    -- Analyze_Selected_Component --
    --------------------------------
 
-   --  Prefix is a record type or a task or protected type. In the
-   --  later case, the selector must denote a visible entry.
+   --  Prefix is a record type or a task or protected type. In the latter case,
+   --  the selector must denote a visible entry.
 
    procedure Analyze_Selected_Component (N : Node_Id) is
       Name          : constant Node_Id := Prefix (N);
@@ -3124,6 +3124,9 @@  package body Sem_Ch4 is
       --  a class-wide type, we use its root type, whose components are
       --  present in the class-wide type.
 
+      Is_Single_Concurrent_Object : Boolean;
+      --  Set True if the prefix is a single task or a single protected object
+
       function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean;
       --  It is known that the parent of N denotes a subprogram call. Comp
       --  is an overloadable component of the concurrent type of the prefix.
@@ -3294,6 +3297,15 @@  package body Sem_Ch4 is
          Type_To_Use := Root_Type (Prefix_Type);
       end if;
 
+      --  If the prefix is a single concurrent object, use its name in error
+      --  messages, rather than that of its anonymous type.
+
+      Is_Single_Concurrent_Object :=
+        Is_Concurrent_Type (Prefix_Type)
+          and then Is_Internal_Name (Chars (Prefix_Type))
+          and then not Is_Derived_Type (Prefix_Type)
+          and then Is_Entity_Name (Name);
+
       Comp := First_Entity (Type_To_Use);
 
       --  If the selector has an original discriminant, the node appears in
@@ -3532,9 +3544,8 @@  package body Sem_Ch4 is
                   return;
 
                else
-                  Error_Msg_NE
-                    ("invisible selector for }",
-                     N, First_Subtype (Prefix_Type));
+                  Error_Msg_Node_2 := First_Subtype (Prefix_Type);
+                  Error_Msg_NE ("invisible selector& for }", N, Sel);
                   Set_Entity (Sel, Any_Id);
                   Set_Etype (N, Any_Type);
                end if;
@@ -3579,8 +3590,13 @@  package body Sem_Ch4 is
                      Has_Candidate := True;
                   end if;
 
+               --  Note: a selected component may not denote a component of a
+               --  protected type (4.1.3(7)).
+
                elsif Ekind_In (Comp, E_Discriminant, E_Entry_Family)
-                 or else (In_Scope and then Is_Entity_Name (Name))
+                 or else (In_Scope
+                            and then not Is_Protected_Type (Prefix_Type)
+                            and then Is_Entity_Name (Name))
                then
                   Set_Entity_With_Style_Check (Sel, Comp);
                   Generate_Reference (Comp, Sel);
@@ -3644,6 +3660,28 @@  package body Sem_Ch4 is
             end if;
          end if;
 
+         if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then
+            --  Case of a prefix of a protected type: selector might denote
+            --  an invisible private component.
+
+            Comp := First_Private_Entity (Base_Type (Prefix_Type));
+            while Present (Comp) and then Chars (Comp) /= Chars (Sel) loop
+               Next_Entity (Comp);
+            end loop;
+
+            if Present (Comp) then
+               if Is_Single_Concurrent_Object then
+                  Error_Msg_Node_2 := Entity (Name);
+                  Error_Msg_NE ("invisible selector& for &", N, Sel);
+
+               else
+                  Error_Msg_Node_2 := First_Subtype (Prefix_Type);
+                  Error_Msg_NE ("invisible selector& for }", N, Sel);
+               end if;
+               return;
+            end if;
+         end if;
+
          Set_Is_Overloaded (N, Is_Overloaded (Sel));
 
       else
@@ -3656,15 +3694,7 @@  package body Sem_Ch4 is
 
       if Etype (N) = Any_Type then
 
-         --  If the prefix is a single concurrent object, use its name in the
-         --  error message, rather than that of its anonymous type.
-
-         if Is_Concurrent_Type (Prefix_Type)
-           and then Is_Internal_Name (Chars (Prefix_Type))
-           and then not Is_Derived_Type (Prefix_Type)
-           and then Is_Entity_Name (Name)
-         then
-
+         if Is_Single_Concurrent_Object then
             Error_Msg_Node_2 := Entity (Name);
             Error_Msg_NE ("no selector& for&", N, Sel);