sem_util.adb (Is_Aliased_View): Defend against the case where this subprogram is...

2004-10-26  Thomas Quinot  <quinot@act-europe.fr>
	    Ed Schonberg   <schonberg@gnat.com>

	* sem_util.adb (Is_Aliased_View): Defend against the case where this
	subprogram is called with a parameter that is not an object name. This
	situation arises for some cases of illegal code, which is diagnosed
	later, and in this case it is wrong to call Is_Aliased, as that might
	cause a compiler crash.
	(Explain_Limited_Type): Refine previous fix to include
	inherited components of derived types, to provide complete information.

	* exp_ch9.adb (Set_Privals): Set the Ekind of the actual object that
	is the prival for a protected object.
	It is necessary to mark this entity as a variable, in addition to
	flagging it as Aliased, because Sem_Util.Is_Aliased_View has been
	modified to avoid checking the Aliased flag on entities that are not
	objects. (Checking that flag for non-objects is erroneous and could
	lead to a compiler crash).

From-SVN: r89674

diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 133bf55..fc8e730 100644 (file)
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -8745,6 +8745,7 @@ package body Exp_Ch9 is
       end loop;
 
       P_Subtype  := Etype (Defining_Identifier (Obj_Decl));
+      Set_Ekind (Priv, E_Variable);
       Set_Etype (Priv, P_Subtype);
       Set_Is_Aliased (Priv);
       Set_Object_Ref (Body_Ent, Priv);

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index af36937..0fcad3e 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -448,7 +448,7 @@ package body Sem_Util is
          end loop;
       end if;
 
-      --  If none of the above, the actual and nominal subtypes are the same.
+      --  If none of the above, the actual and nominal subtypes are the same
 
       return Empty;
    end Build_Actual_Subtype_Of_Component;
@@ -609,7 +609,7 @@ package body Sem_Util is
          end loop;
       end if;
 
-      --  If none of the above, the actual and nominal subtypes are the same.
+      --  If none of the above, the actual and nominal subtypes are the same
 
       return Empty;
    end Build_Discriminal_Subtype_Of_Component;
@@ -1929,12 +1929,19 @@ package body Sem_Util is
             return;
          end if;
 
-         --  Otherwise find a limited component
+         --  Otherwise find a limited component. Check only components that
+         --  come from source, or inherited components that appear in the
+         --  source of the ancestor.
 
          C := First_Component (T);
          while Present (C) loop
             if Is_Limited_Type (Etype (C))
-              and then Comes_From_Source (C)
+              and then
+                (Comes_From_Source (C)
+                   or else
+                     (Present (Original_Record_Component (C))
+                       and then
+                         Comes_From_Source (Original_Record_Component (C))))
             then
                Error_Msg_Node_2 := T;
                Error_Msg_NE ("\component& of type& has limited type", N, C);
@@ -2106,7 +2113,7 @@ package body Sem_Util is
       pragma Warnings (Off, Res);
 
       function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id;
-      --  Compute recursively the qualified name without NUL at the end.
+      --  Compute recursively the qualified name without NUL at the end
 
       ----------------------------------
       -- Internal_Full_Qualified_Name --
@@ -2606,7 +2613,7 @@ package body Sem_Util is
          end if;
 
       else
-         --  N is an expression, indicating a range with one value.
+         --  N is an expression, indicating a range with one value
 
          L := N;
          H := N;
@@ -3153,22 +3160,22 @@ package body Sem_Util is
    begin
       if Is_Entity_Name (Obj) then
 
-         --  Shouldn't we check that we really have an object here?
-         --  If we do, then a-caldel.adb blows up mysteriously ???
-
          E := Entity (Obj);
 
-         return Is_Aliased (E)
-           or else (Present (Renamed_Object (E))
-                     and then Is_Aliased_View (Renamed_Object (E)))
+         return
+           (Is_Object (E)
+             and then
+               (Is_Aliased (E)
+                  or else (Present (Renamed_Object (E))
+                             and then Is_Aliased_View (Renamed_Object (E)))))
 
            or else ((Is_Formal (E)
                       or else Ekind (E) = E_Generic_In_Out_Parameter
                       or else Ekind (E) = E_Generic_In_Parameter)
                     and then Is_Tagged_Type (Etype (E)))
 
-           or else ((Ekind (E) = E_Task_Type or else
-                     Ekind (E) = E_Protected_Type)
+           or else ((Ekind (E) = E_Task_Type
+                      or else Ekind (E) = E_Protected_Type)
                     and then In_Open_Scopes (E))
 
             --  Current instance of type
@@ -3237,7 +3244,7 @@ package body Sem_Util is
       --  Determines if given object has atomic components
 
       function Is_Atomic_Prefix (N : Node_Id) return Boolean;
-      --  If prefix is an implicit dereference, examine designated type.
+      --  If prefix is an implicit dereference, examine designated type
 
       function Is_Atomic_Prefix (N : Node_Id) return Boolean is
       begin
@@ -3307,7 +3314,7 @@ package body Sem_Util is
       --  that depends on a discriminant.
 
       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
-      --  Returns True if and only if Comp is declared within a variant part.
+      --  Returns True if and only if Comp is declared within a variant part
 
       ------------------------------
       -- Has_Dependent_Constraint --
@@ -3608,7 +3615,7 @@ package body Sem_Util is
                   if Etype (Indx) = Any_Type then
                      return False;
 
-                  --  If index is a range, use directly.
+                  --  If index is a range, use directly
 
                   elsif Nkind (Indx) = N_Range then
                      Lbd := Low_Bound  (Indx);
@@ -3798,7 +3805,7 @@ package body Sem_Util is
             Into          => Components,
             Report_Errors => Report_Errors);
 
-         --  Check that each component present is fully initialized.
+         --  Check that each component present is fully initialized
 
          Comp_Elmt := First_Elmt (Components);
 
@@ -3984,7 +3991,7 @@ package body Sem_Util is
             when N_Explicit_Dereference =>
                return True;
 
-            --  A view conversion of a tagged object is an object reference.
+            --  A view conversion of a tagged object is an object reference
 
             when N_Type_Conversion =>
                return Is_Tagged_Type (Etype (Subtype_Mark (N)))
@@ -4628,7 +4635,7 @@ package body Sem_Util is
       --  Determines if given object has volatile components
 
       function Is_Volatile_Prefix (N : Node_Id) return Boolean;
-      --  If prefix is an implicit dereference, examine designated type.
+      --  If prefix is an implicit dereference, examine designated type
 
       ------------------------
       -- Is_Volatile_Prefix --
@@ -4939,7 +4946,7 @@ package body Sem_Util is
       begin
          if No (Last) then
 
-            --  Call node points to first actual in list.
+            --  Call node points to first actual in list
 
             Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
 
@@ -5012,7 +5019,7 @@ package body Sem_Util is
 
       elsif Actuals_To_Match > Formals_To_Match then
 
-         --  Too many actuals: will not work.
+         --  Too many actuals: will not work
 
          if Reporting then
             if Is_Entity_Name (Name (N)) then
@@ -5442,7 +5449,7 @@ package body Sem_Util is
             Component := First_Entity (Btype);
             while Present (Component) loop
 
-               --  skip anonymous types generated by constrained components.
+               --  Skip anonymous types generated by constrained components
 
                if not Is_Type (Component) then
                   P := Trace_Components (Etype (Component), True);
@@ -6374,7 +6381,7 @@ package body Sem_Util is
       N : Node_Id := Parent (Unit_Id);
 
    begin
-      --  Predefined operators do not have a full function declaration.
+      --  Predefined operators do not have a full function declaration
 
       if Ekind (Unit_Id) = E_Operator then
          return N;