sem_ch13.adb: Storage pool cannot be given for access to subprogram type.

2006-10-31  Robert Dewar  <dewar@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>

	* sem_ch13.adb: Storage pool cannot be given for access to subprogram
	type.
	(New_Stream_Subprogram): When processing an attribute definition clause
	for a stream-oriented subprogram, record an entity node occurring at
	the point of clause to use for checking the visibility of the clause,
	as defined by 8.3(23) as amended by AI-195.
	(New_Stream_Subprogram): New procedure, factoring behaviour from both
	 New_Stream_Function and New_Stream_Procedure.
	(New_Stream_Function, New_Stream_Procedure): Removed.
	(Analyze_Attribute_Definition_Clause, case Address): Check new
	Alignment_Check check

From-SVN: r118301

gcc/ada/sem_ch13.adb

@@ -43,6 +43,7 @@ with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
 with Sem_Type; use Sem_Type;
 with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
 with Snames;   use Snames;
 with Stand;    use Stand;
 with Sinfo;    use Sinfo;
@@ -92,19 +93,19 @@ package body Sem_Ch13 is
    --  the expression N is of the form of K'Address, then the entity that
    --  is associated with K is marked as volatile.
 
-   procedure New_Stream_Function
+   procedure New_Stream_Subprogram
      (N    : Node_Id;
       Ent  : Entity_Id;
       Subp : Entity_Id;
       Nam  : TSS_Name_Type);
-   --  Create a function renaming of a given stream attribute to the
+   --  Create a subprogram renaming of a given stream attribute to the
-   --  designated subprogram and then in the tagged case, provide this as
+   --  designated subprogram and then in the tagged case, provide this as a
-   --  a primitive operation, or in the non-tagged case make an appropriate
+   --  primitive operation, or in the non-tagged case make an appropriate TSS
-   --  TSS entry. Used for Input. This is more properly an expansion activity
+   --  entry. This is more properly an expansion activity than just semantics,
-   --  than just semantics, but the presence of user-defined stream functions
+   --  but the presence of user-defined stream functions for limited types is a
-   --  for limited types is a legality check, which is why this takes place
+   --  legality check, which is why this takes place here rather than in
-   --  here rather than in exp_ch13, where it was previously. Nam indicates
+   --  exp_ch13, where it was previously. Nam indicates the name of the TSS
-   --  the name of the TSS function to be generated.
+   --  function to be generated.
    --
    --  To avoid elaboration anomalies with freeze nodes, for untagged types
    --  we generate both a subprogram declaration and a subprogram renaming
@@ -112,18 +113,6 @@ package body Sem_Ch13 is
    --  renaming_as_body. For tagged types, the specification is one of the
    --  primitive specs.
 
-   procedure New_Stream_Procedure
-     (N     : Node_Id;
-      Ent   : Entity_Id;
-      Subp  : Entity_Id;
-      Nam   : TSS_Name_Type;
-      Out_P : Boolean := False);
-   --  Create a procedure renaming of a given stream attribute to the
-   --  designated subprogram and then in the tagged case, provide this as
-   --  a primitive operation, or in the non-tagged case make an appropriate
-   --  TSS entry. Used for Read, Output, Write. Nam indicates the name of
-   --  the TSS procedure to be generated.
-
    ----------------------------------------------
    -- Table for Validate_Unchecked_Conversions --
    ----------------------------------------------
@@ -322,7 +311,21 @@ package body Sem_Ch13 is
 
          Pnam := TSS (Base_Type (U_Ent), TSS_Nam);
 
-         if Present (Pnam) and then Has_Good_Profile (Pnam) then
+         --  If Pnam is present, it can be either inherited from an ancestor
+         --  type (in which case it is legal to redefine it for this type), or
+         --  be a previous definition of the attribute for the same type (in
+         --  which case it is illegal).
+
+         --  In the first case, it will have been analyzed already, and we
+         --  can check that its profile does not match the expected profile
+         --  for a stream attribute of U_Ent. In the second case, either Pnam
+         --  has been analyzed (and has the expected profile), or it has not
+         --  been analyzed yet (case of a type that has not been frozen yet
+         --  and for which the stream attribute has been set using Set_TSS).
+
+         if Present (Pnam)
+           and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam))
+         then
             Error_Msg_Sloc := Sloc (Pnam);
             Error_Msg_Name_1 := Attr;
             Error_Msg_N ("% attribute already defined #", Nam);
@@ -360,12 +363,7 @@ package body Sem_Ch13 is
             Set_Entity (Expr, Subp);
             Set_Etype (Expr, Etype (Subp));
 
-            if TSS_Nam = TSS_Stream_Input then
+            New_Stream_Subprogram (N, U_Ent, Subp, TSS_Nam);
-               New_Stream_Function (N, U_Ent, Subp, TSS_Nam);
-            else
-               New_Stream_Procedure (N, U_Ent, Subp, TSS_Nam,
-                                     Out_P => Is_Read);
-            end if;
 
          else
             Error_Msg_Name_1 := Attr;
@@ -623,11 +621,14 @@ package body Sem_Ch13 is
                         Nam);
                   end if;
 
-                  --  Entity has delayed freeze, so we will generate
+                  --  Entity has delayed freeze, so we will generate an
-                  --  an alignment check at the freeze point.
+                  --  alignment check at the freeze point unless suppressed.
 
-                  Set_Check_Address_Alignment
+                  if not Range_Checks_Suppressed (U_Ent)
-                    (N, not Range_Checks_Suppressed (U_Ent));
+                    and then not Alignment_Checks_Suppressed (U_Ent)
+                  then
+                     Set_Check_Address_Alignment (N);
+                  end if;
 
                   --  Kill the size check code, since we are not allocating
                   --  the variable, it is somewhere else.
@@ -1046,75 +1047,6 @@ package body Sem_Ch13 is
             end if;
          end Small;
 
-         ------------------
-         -- Storage_Size --
-         ------------------
-
-         --  Storage_Size attribute definition clause
-
-         when Attribute_Storage_Size => Storage_Size : declare
-            Btype : constant Entity_Id := Base_Type (U_Ent);
-            Sprag : Node_Id;
-
-         begin
-            if Is_Task_Type (U_Ent) then
-               Check_Restriction (No_Obsolescent_Features, N);
-
-               if Warn_On_Obsolescent_Feature then
-                  Error_Msg_N
-                    ("storage size clause for task is an " &
-                     "obsolescent feature ('R'M 'J.9)?", N);
-                  Error_Msg_N
-                    ("\use Storage_Size pragma instead?", N);
-               end if;
-
-               FOnly := True;
-            end if;
-
-            if not Is_Access_Type (U_Ent)
-              and then Ekind (U_Ent) /= E_Task_Type
-            then
-               Error_Msg_N ("storage size cannot be given for &", Nam);
-
-            elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then
-               Error_Msg_N
-                 ("storage size cannot be given for a derived access type",
-                  Nam);
-
-            elsif Has_Storage_Size_Clause (Btype) then
-               Error_Msg_N ("storage size already given for &", Nam);
-
-            else
-               Analyze_And_Resolve (Expr, Any_Integer);
-
-               if Is_Access_Type (U_Ent) then
-
-                  if Present (Associated_Storage_Pool (U_Ent)) then
-                     Error_Msg_N ("storage pool already given for &", Nam);
-                     return;
-                  end if;
-
-                  if Compile_Time_Known_Value (Expr)
-                    and then Expr_Value (Expr) = 0
-                  then
-                     Set_No_Pool_Assigned (Btype);
-                  end if;
-
-               else -- Is_Task_Type (U_Ent)
-                  Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size);
-
-                  if Present (Sprag) then
-                     Error_Msg_Sloc := Sloc (Sprag);
-                     Error_Msg_N
-                       ("Storage_Size already specified#", Nam);
-                     return;
-                  end if;
-               end if;
-
-               Set_Has_Storage_Size_Clause (Btype);
-            end if;
-         end Storage_Size;
-
          ------------------
          -- Storage_Pool --
          ------------------
@@ -1126,11 +1058,17 @@ package body Sem_Ch13 is
             T    : Entity_Id;
 
          begin
-            if Ekind (U_Ent) /= E_Access_Type
+            if Ekind (U_Ent) = E_Access_Subprogram_Type then
+               Error_Msg_N
+                 ("storage pool cannot be given for access-to-subprogram type",
+                  Nam);
+               return;
+
+            elsif Ekind (U_Ent) /= E_Access_Type
               and then Ekind (U_Ent) /= E_General_Access_Type
             then
-               Error_Msg_N (
+               Error_Msg_N
-                 "storage pool can only be given for access types", Nam);
+                 ("storage pool can only be given for access types", Nam);
                return;
 
             elsif Is_Derived_Type (U_Ent) then
@@ -1229,6 +1167,74 @@ package body Sem_Ch13 is
             end if;
          end Storage_Pool;
 
+         ------------------
+         -- Storage_Size --
+         ------------------
+
+         --  Storage_Size attribute definition clause
+
+         when Attribute_Storage_Size => Storage_Size : declare
+            Btype : constant Entity_Id := Base_Type (U_Ent);
+            Sprag : Node_Id;
+
+         begin
+            if Is_Task_Type (U_Ent) then
+               Check_Restriction (No_Obsolescent_Features, N);
+
+               if Warn_On_Obsolescent_Feature then
+                  Error_Msg_N
+                    ("storage size clause for task is an " &
+                     "obsolescent feature ('R'M 'J.9)?", N);
+                  Error_Msg_N
+                    ("\use Storage_Size pragma instead?", N);
+               end if;
+
+               FOnly := True;
+            end if;
+
+            if not Is_Access_Type (U_Ent)
+              and then Ekind (U_Ent) /= E_Task_Type
+            then
+               Error_Msg_N ("storage size cannot be given for &", Nam);
+
+            elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then
+               Error_Msg_N
+                 ("storage size cannot be given for a derived access type",
+                  Nam);
+
+            elsif Has_Storage_Size_Clause (Btype) then
+               Error_Msg_N ("storage size already given for &", Nam);
+
+            else
+               Analyze_And_Resolve (Expr, Any_Integer);
+
+               if Is_Access_Type (U_Ent) then
+                  if Present (Associated_Storage_Pool (U_Ent)) then
+                     Error_Msg_N ("storage pool already given for &", Nam);
+                     return;
+                  end if;
+
+                  if Compile_Time_Known_Value (Expr)
+                    and then Expr_Value (Expr) = 0
+                  then
+                     Set_No_Pool_Assigned (Btype);
+                  end if;
+
+               else -- Is_Task_Type (U_Ent)
+                  Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size);
+
+                  if Present (Sprag) then
+                     Error_Msg_Sloc := Sloc (Sprag);
+                     Error_Msg_N
+                       ("Storage_Size already specified#", Nam);
+                     return;
+                  end if;
+               end if;
+
+               Set_Has_Storage_Size_Clause (Btype);
+            end if;
+         end Storage_Size;
+
          -----------------
          -- Stream_Size --
          -----------------
@@ -1349,6 +1355,8 @@ package body Sem_Ch13 is
          return;
       end if;
 
+      Check_Code_Statement (N);
+
       --  Make sure we appear in the handled statement sequence of a
       --  subprogram (RM 13.8(3)).
 
@@ -2630,7 +2638,7 @@ package body Sem_Ch13 is
             when N_Null =>
                return;
 
-            when N_Binary_Op | N_And_Then | N_Or_Else | N_In | N_Not_In =>
+            when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test =>
                Check_Expr_Constants (Left_Opnd (Nod));
                Check_Expr_Constants (Right_Opnd (Nod));
 
@@ -3116,11 +3124,11 @@ package body Sem_Ch13 is
       return S;
    end Minimum_Size;
 
-   -------------------------
+   ---------------------------
-   -- New_Stream_Function --
+   -- New_Stream_Subprogram --
-   -------------------------
+   ---------------------------
 
-   procedure New_Stream_Function
+   procedure New_Stream_Subprogram
      (N     : Node_Id;
       Ent   : Entity_Id;
       Subp  : Entity_Id;
@@ -3133,6 +3141,14 @@ package body Sem_Ch13 is
       F         : Entity_Id;
       Etyp      : Entity_Id;
 
+      Defer_Declaration : constant Boolean :=
+                            Is_Tagged_Type (Ent) or else Is_Private_Type (Ent);
+      --  For a tagged type, there is a declaration for each stream attribute
+      --  at the freeze point, and we must generate only a completion of this
+      --  declaration. We do the same for private types, because the full view
+      --  might be tagged. Otherwise we generate a declaration at the point of
+      --  the attribute definition clause.
+
       function Build_Spec return Node_Id;
       --  Used for declaration and renaming declaration, so that this is
       --  treated as a renaming_as_body.
@@ -3142,14 +3158,17 @@ package body Sem_Ch13 is
       ----------------
 
       function Build_Spec return Node_Id is
+         Out_P   : constant Boolean := (Nam = TSS_Stream_Read);
+         Formals : List_Id;
+         Spec    : Node_Id;
+         T_Ref   : constant Node_Id := New_Reference_To (Etyp, Loc);
+
       begin
          Subp_Id := Make_Defining_Identifier (Loc, Sname);
 
-         return
+         --  S : access Root_Stream_Type'Class
-           Make_Function_Specification (Loc,
+
-             Defining_Unit_Name => Subp_Id,
+         Formals := New_List (
-             Parameter_Specifications =>
-               New_List (
                       Make_Parameter_Specification (Loc,
                         Defining_Identifier =>
                           Make_Defining_Identifier (Loc, Name_S),
@@ -3157,115 +3176,83 @@ package body Sem_Ch13 is
                           Make_Access_Definition (Loc,
                             Subtype_Mark =>
                               New_Reference_To (
-                           Designated_Type (Etype (F)), Loc)))),
+                                Designated_Type (Etype (F)), Loc))));
 
-             Result_Definition =>
+         if Nam = TSS_Stream_Input then
-               New_Reference_To (Etyp, Loc));
+            Spec := Make_Function_Specification (Loc,
-      end Build_Spec;
+                      Defining_Unit_Name       => Subp_Id,
-
+                      Parameter_Specifications => Formals,
-   --  Start of processing for New_Stream_Function
+                      Result_Definition        => T_Ref);
-
-   begin
-      F    := First_Formal (Subp);
-      Etyp := Etype (Subp);
-
-      if not Is_Tagged_Type (Ent) then
-         Subp_Decl :=
-           Make_Subprogram_Declaration (Loc,
-             Specification => Build_Spec);
-         Insert_Action (N, Subp_Decl);
-      end if;
-
-      Subp_Decl :=
-        Make_Subprogram_Renaming_Declaration (Loc,
-          Specification => Build_Spec,
-          Name => New_Reference_To (Subp, Loc));
-
-      if Is_Tagged_Type (Ent) then
-         Set_TSS (Base_Type (Ent), Subp_Id);
          else
-         Insert_Action (N, Subp_Decl);
+            --  V : [out] T
-         Copy_TSS (Subp_Id, Base_Type (Ent));
-      end if;
-   end New_Stream_Function;
 
-   --------------------------
+            Append_To (Formals,
-   -- New_Stream_Procedure --
-   --------------------------
-
-   procedure New_Stream_Procedure
-     (N     : Node_Id;
-      Ent   : Entity_Id;
-      Subp  : Entity_Id;
-      Nam   : TSS_Name_Type;
-      Out_P : Boolean := False)
-   is
-      Loc       : constant Source_Ptr := Sloc (N);
-      Sname     : constant Name_Id    := Make_TSS_Name (Base_Type (Ent), Nam);
-      Subp_Id   : Entity_Id;
-      Subp_Decl : Node_Id;
-      F         : Entity_Id;
-      Etyp      : Entity_Id;
-
-      function Build_Spec return Node_Id;
-      --  Used for declaration and renaming declaration, so that this is
-      --  treated as a renaming_as_body.
-
-      ----------------
-      -- Build_Spec --
-      ----------------
-
-      function Build_Spec return Node_Id is
-      begin
-         Subp_Id := Make_Defining_Identifier (Loc, Sname);
-
-         return
-           Make_Procedure_Specification (Loc,
-             Defining_Unit_Name => Subp_Id,
-             Parameter_Specifications =>
-               New_List (
               Make_Parameter_Specification (Loc,
-                   Defining_Identifier =>
+                Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
-                     Make_Defining_Identifier (Loc, Name_S),
-                   Parameter_Type =>
-                     Make_Access_Definition (Loc,
-                       Subtype_Mark =>
-                         New_Reference_To (
-                           Designated_Type (Etype (F)), Loc))),
-
-                 Make_Parameter_Specification (Loc,
-                   Defining_Identifier =>
-                     Make_Defining_Identifier (Loc, Name_V),
                 Out_Present         => Out_P,
-                   Parameter_Type =>
+                Parameter_Type      => T_Ref));
-                     New_Reference_To (Etyp, Loc))));
+
+            Spec := Make_Procedure_Specification (Loc,
+                      Defining_Unit_Name       => Subp_Id,
+                      Parameter_Specifications => Formals);
+         end if;
+
+         return Spec;
       end Build_Spec;
 
-      --  Start of processing for New_Stream_Procedure
+   --  Start of processing for New_Stream_Subprogram
 
    begin
       F := First_Formal (Subp);
-      Etyp     := Etype (Next_Formal (F));
 
-      if not Is_Tagged_Type (Ent) then
+      if Ekind (Subp) = E_Procedure then
+         Etyp := Etype (Next_Formal (F));
+      else
+         Etyp := Etype (Subp);
+      end if;
+
+      --  Prepare subprogram declaration and insert it as an action on the
+      --  clause node. The visibility for this entity is used to test for
+      --  visibility of the attribute definition clause (in the sense of
+      --  8.3(23) as amended by AI-195).
+
+      if not Defer_Declaration then
          Subp_Decl :=
            Make_Subprogram_Declaration (Loc,
              Specification => Build_Spec);
-         Insert_Action (N, Subp_Decl);
+
+      --  For a tagged type, there is always a visible declaration for each
+      --  stream TSS (it is a predefined primitive operation), and the for the
+      --  completion of this declaration occurs at the freeze point, which is
+      --  not always visible at places where the attribute definition clause is
+      --  visible. So, we create a dummy entity here for the purpose of
+      --  tracking the visibility of the attribute definition clause itself.
+
+      else
+         Subp_Id :=
+           Make_Defining_Identifier (Loc,
+             Chars => New_External_Name (Sname, 'V'));
+         Subp_Decl :=
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Subp_Id,
+             Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc));
       end if;
 
+      Insert_Action (N, Subp_Decl);
+      Set_Entity (N, Subp_Id);
+
       Subp_Decl :=
         Make_Subprogram_Renaming_Declaration (Loc,
           Specification => Build_Spec,
           Name => New_Reference_To (Subp, Loc));
 
-      if Is_Tagged_Type (Ent) then
+      if Defer_Declaration then
          Set_TSS (Base_Type (Ent), Subp_Id);
       else
          Insert_Action (N, Subp_Decl);
          Copy_TSS (Subp_Id, Base_Type (Ent));
       end if;
-   end New_Stream_Procedure;
+   end New_Stream_Subprogram;
 
    ------------------------
    -- Rep_Item_Too_Early --
@@ -3273,8 +3260,7 @@ package body Sem_Ch13 is
 
    function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is
    begin
-      --  Cannot apply rep items that are not operational items
+      --  Cannot apply non-operational rep items to generic types
-      --  to generic types
 
       if Is_Operational_Item (N) then
          return False;