sem_util.adb (Explain_Limited_Type): Ignore internal components when searching for a limited component to flag.

2004-10-04  Ed Schonberg  <schonberg@gnat.com>

	* sem_util.adb (Explain_Limited_Type): Ignore internal components when
	searching for a limited component to flag.

	* exp_attr.adb (Freeze_Stream_Subprogram): Subsidiary procedure to
	expansion of Input, to account for the fact that the implicit call
	generated by the attribute reference must freeze the user-defined
	stream subprogram. This is only relevant to 'Input, because it can
	appear in an object declaration, prior to the body of the subprogram.

	* sem_ch13.adb (Rep_Item_Too_Late): Make the error non-serious, so that
	expansion can proceed and further errors uncovered.
	(Minor clean up): Fix cases of using | instead of \ for continuation
	messages.

From-SVN: r88494

4 files changed, 107 insertions, 14 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 0931a5c..fbd3a89 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,19 @@
+2004-10-04  Ed Schonberg  <schonberg@gnat.com>
+
+	* sem_util.adb (Explain_Limited_Type): Ignore internal components when
+	searching for a limited component to flag.
+
+	* exp_attr.adb (Freeze_Stream_Subprogram): Subsidiary procedure to
+	expansion of Input, to account for the fact that the implicit call
+	generated by the attribute reference must freeze the user-defined
+	stream subprogram. This is only relevant to 'Input, because it can
+	appear in an object declaration, prior to the body of the subprogram.
+
+	* sem_ch13.adb (Rep_Item_Too_Late): Make the error non-serious, so that
+	expansion can proceed and further errors uncovered.
+	(Minor clean up): Fix cases of using | instead of \ for continuation
+	messages.
+
 2004-10-04  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>
 
 	* cuintp.c, decl.c, utils2.c: Use gcc_assert and gcc_unreachable.
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index f87d503..1ba1e03 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -1737,6 +1737,44 @@ package body Exp_Attr is
          --  the dispatching (class-wide type) case, where it is a reference
          --  to the dummy object initialized to the right internal tag.
 
+         procedure Freeze_Stream_Subprogram (F : Entity_Id);
+         --  The expansion of the attribute reference may generate a call to
+         --  a user-defined stream subprogram that is frozen by the call. This
+         --  can lead to access-before-elaboration problem if the reference
+         --  appears in an object declaration and the subprogram body has not
+         --  been seen. The freezing of the subprogram requires special code
+         --  because it appears in an expanded context where expressions do
+         --  not freeze their constituents.
+
+         ------------------------------
+         -- Freeze_Stream_Subprogram --
+         ------------------------------
+
+         procedure Freeze_Stream_Subprogram (F : Entity_Id) is
+            Decl : constant Node_Id := Unit_Declaration_Node (F);
+            Bod  : Node_Id;
+
+         begin
+            --  If this is user-defined subprogram, the corresponding
+            --  stream function appears as a renaming-as-body, and the
+            --  user subprogram must be retrieved by tree traversal.
+
+            if Present (Decl)
+              and then Nkind (Decl) = N_Subprogram_Declaration
+              and then Present (Corresponding_Body (Decl))
+            then
+               Bod := Corresponding_Body (Decl);
+
+               if Nkind (Unit_Declaration_Node (Bod)) =
+                 N_Subprogram_Renaming_Declaration
+               then
+                  Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
+               end if;
+            end if;
+         end Freeze_Stream_Subprogram;
+
+      --  Start of processing for Input
+
       begin
          --  If no underlying type, we have an error that will be diagnosed
          --  elsewhere, so here we just completely ignore the expansion.
@@ -1902,6 +1940,32 @@ package body Exp_Attr is
                Build_Record_Or_Elementary_Input_Function
                  (Loc, Base_Type (U_Type), Decl, Fname);
                Insert_Action (N, Decl);
+
+               if Nkind (Parent (N)) = N_Object_Declaration
+                 and then Is_Record_Type (U_Type)
+               then
+                  --  The stream function may contain calls to user-defined
+                  --  Read procedures for individual components.
+
+                  declare
+                     Comp : Entity_Id;
+                     Func : Entity_Id;
+
+                  begin
+                     Comp := First_Component (U_Type);
+                     while Present (Comp) loop
+                        Func :=
+                          Find_Stream_Subprogram
+                            (Etype (Comp), TSS_Stream_Read);
+
+                        if Present (Func) then
+                           Freeze_Stream_Subprogram (Func);
+                        end if;
+
+                        Next_Component (Comp);
+                     end loop;
+                  end;
+               end if;
             end if;
          end if;
 
@@ -1918,6 +1982,10 @@ package body Exp_Attr is
          Set_Controlling_Argument (Call, Cntrl);
          Rewrite (N, Unchecked_Convert_To (P_Type, Call));
          Analyze_And_Resolve (N, P_Type);
+
+         if Nkind (Parent (N)) = N_Object_Declaration then
+            Freeze_Stream_Subprogram (Fname);
+         end if;
       end Input;
 
       -------------------
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 9b8518d..a3fadf2 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -207,7 +207,7 @@ package body Sem_Ch13 is
          Error_Msg_N
            ("at clause is an obsolescent feature ('R'M 'J.7(2))?", N);
          Error_Msg_N
-           ("|use address attribute definition clause instead?", N);
+           ("\use address attribute definition clause instead?", N);
       end if;
 
       Rewrite (N,
@@ -360,7 +360,7 @@ package body Sem_Ch13 is
                     ("attaching interrupt to task entry is an " &
                      "obsolescent feature ('R'M 'J.7.1)?", N);
                   Error_Msg_N
-                    ("|use interrupt procedure instead?", N);
+                    ("\use interrupt procedure instead?", N);
                end if;
 
             --  Case of an address clause for a controlled object:
@@ -1192,7 +1192,7 @@ package body Sem_Ch13 is
                     ("storage size clause for task is an " &
                      "obsolescent feature ('R'M 'J.9)?", N);
                   Error_Msg_N
-                    ("|use Storage_Size pragma instead?", N);
+                    ("\use Storage_Size pragma instead?", N);
                end if;
 
                FOnly := True;
@@ -1957,7 +1957,7 @@ package body Sem_Ch13 is
                Error_Msg_N
                  ("mod clause is an obsolescent feature ('R'M 'J.8)?", N);
                Error_Msg_N
-                 ("|use alignment attribute definition clause instead?", N);
+                 ("\use alignment attribute definition clause instead?", N);
             end if;
 
             if Present (P) then
@@ -3478,11 +3478,17 @@ package body Sem_Ch13 is
       Parent_Type : Entity_Id;
 
       procedure Too_Late;
-      --  Output the too late message
+      --  Output the too late message. Note that this is not considered a
+      --  serious error, since the effect is simply that we ignore the
+      --  representation clause in this case.
+
+      --------------
+      -- Too_Late --
+      --------------
 
       procedure Too_Late is
       begin
-         Error_Msg_N ("representation item appears too late!", N);
+         Error_Msg_N ("|representation item appears too late!", N);
       end Too_Late;
 
    --  Start of processing for Rep_Item_Too_Late
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 762be69..af36937 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -1933,7 +1933,9 @@ package body Sem_Util is
 
          C := First_Component (T);
          while Present (C) loop
-            if Is_Limited_Type (Etype (C)) then
+            if Is_Limited_Type (Etype (C))
+              and then Comes_From_Source (C)
+            then
                Error_Msg_Node_2 := T;
                Error_Msg_NE ("\component& of type& has limited type", N, C);
                Explain_Limited_Type (Etype (C), N);
@@ -1943,9 +1945,8 @@ package body Sem_Util is
             Next_Component (C);
          end loop;
 
-         --  It's odd if the loop falls through, but this is only an extra
-         --  error message, so we just let it go and ignore the situation.
-
+         --  The type may be declared explicitly limited, even if no component
+         --  of it is limited, in which case we fall out of the loop.
          return;
       end if;
    end Explain_Limited_Type;
@@ -3772,14 +3773,16 @@ package body Sem_Util is
          while Present (Discr) loop
             if Nkind (Parent (Discr)) = N_Discriminant_Specification then
                Discr_Val := Expression (Parent (Discr));
-               if not Is_OK_Static_Expression (Discr_Val) then
-                  return False;
-               else
+
+               if Present (Discr_Val)
+                 and then Is_OK_Static_Expression (Discr_Val)
+               then
                   Append_To (Constraints,
                     Make_Component_Association (Loc,
                       Choices    => New_List (New_Occurrence_Of (Discr, Loc)),
                       Expression => New_Copy (Discr_Val)));
-
+               else
+                  return False;
                end if;
             else
                return False;