sem_ch6.adb (Check_Conformance): The null-exclusion feature can be omitted in case of stream attribute subprograms.

2005-11-14  Javier Miranda  <miranda@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Check_Conformance): The null-exclusion feature can be
	omitted in case of stream attribute subprograms.
	(Check_Inline_Pragma): Handle Inline and Inline_Always pragmas that
	appear immediately after a subprogram body, when there is no previous
	subprogram declaration.
	Change name Is_Package to Is_Package_Or_Generic_Package
	(Process_Formals): A non null qualifier on a non null named access
	type is not an error, and is a warning only if Redundant_Constructs
	are flagged.

From-SVN: r107001

1 files changed, 149 insertions, 52 deletions

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 47056d5..dae0621 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005, 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- --
@@ -32,6 +32,7 @@ with Elists;   use Elists;
 with Errout;   use Errout;
 with Expander; use Expander;
 with Exp_Ch7;  use Exp_Ch7;
+with Exp_Tss;  use Exp_Tss;
 with Fname;    use Fname;
 with Freeze;   use Freeze;
 with Itypes;   use Itypes;
@@ -236,7 +237,7 @@ package body Sem_Ch6 is
       Analyze (P);
 
       --  A call of the form A.B (X) may be an Ada05 call, which is rewritten
-      --  as B(A, X). If the rewriting is successful, the call has been
+      --  as B (A, X). If the rewriting is successful, the call has been
       --  analyzed and we just return.
 
       if Nkind (P) = N_Selected_Component
@@ -890,9 +891,16 @@ package body Sem_Ch6 is
       Missing_Ret  : Boolean;
       P_Ent        : Entity_Id;
 
-      procedure Check_Following_Pragma;
-      --  If front-end inlining is enabled, look ahead to recognize a pragma
-      --  that may appear after the body.
+      procedure Check_Inline_Pragma (Spec : in out Node_Id);
+      --  Look ahead to recognize a pragma that may appear after the body.
+      --  If there is a previous spec, check that it appears in the same
+      --  declarative part. If the pragma is Inline_Always, perform inlining
+      --  unconditionally, otherwise only if Front_End_Inlining is requested.
+      --  If the body acts as a spec, and inlining is required, we create a
+      --  subprogram declaration for it, in order to attach the body to inline.
+
+      procedure Copy_Parameter_List (Plist : List_Id);
+      --  Comment required ???
 
       procedure Verify_Overriding_Indicator;
       --  If there was a previous spec, the entity has been entered in the
@@ -900,33 +908,115 @@ package body Sem_Ch6 is
       --  indicator, check that it is consistent with the known status of the
       --  entity.
 
-      ----------------------------
-      -- Check_Following_Pragma --
-      ----------------------------
+      -------------------------
+      -- Check_Inline_Pragma --
+      -------------------------
 
-      procedure Check_Following_Pragma is
-         Prag : Node_Id;
+      procedure Check_Inline_Pragma (Spec : in out Node_Id) is
+         Prag  : Node_Id;
+         Plist : List_Id;
 
       begin
-         if Front_End_Inlining
-           and then Is_List_Member (N)
-           and then Present (Spec_Decl)
-           and then List_Containing (N) = List_Containing (Spec_Decl)
+         if not Expander_Active then
+            return;
+         end if;
+
+         if Is_List_Member (N)
+           and then Present (Next (N))
+           and then Nkind (Next (N)) = N_Pragma
          then
             Prag := Next (N);
 
-            if Present (Prag)
-              and then Nkind (Prag) = N_Pragma
-              and then Get_Pragma_Id (Chars (Prag)) = Pragma_Inline
+            if Nkind (Prag) = N_Pragma
+              and then
+                 (Get_Pragma_Id (Chars (Prag)) = Pragma_Inline_Always
+                  or else
+                    (Front_End_Inlining
+                     and then Get_Pragma_Id (Chars (Prag)) = Pragma_Inline))
               and then
-              Chars
-                (Expression (First (Pragma_Argument_Associations (Prag))))
-                   = Chars (Body_Id)
+                 Chars
+                   (Expression (First (Pragma_Argument_Associations (Prag))))
+                      = Chars (Body_Id)
             then
-               Analyze (Prag);
+               Prag := Next (N);
+            else
+               Prag := Empty;
             end if;
+         else
+            Prag := Empty;
          end if;
-      end Check_Following_Pragma;
+
+         if Present (Prag) then
+            if Present (Spec_Id) then
+               if List_Containing (N) =
+                 List_Containing (Unit_Declaration_Node (Spec_Id))
+               then
+                  Analyze (Prag);
+               end if;
+
+            else
+               --  Create a subprogram declaration, to make treatment uniform.
+
+               declare
+                  Subp : constant Entity_Id :=
+                    Make_Defining_Identifier (Loc, Chars (Body_Id));
+                  Decl : constant Node_Id :=
+                    Make_Subprogram_Declaration (Loc,
+                      Specification =>  New_Copy_Tree (Specification (N)));
+               begin
+                  Set_Defining_Unit_Name (Specification (Decl), Subp);
+
+                  if Present (First_Formal (Body_Id)) then
+                     Plist := New_List;
+                     Copy_Parameter_List (Plist);
+                     Set_Parameter_Specifications
+                       (Specification (Decl), Plist);
+                  end if;
+
+                  Insert_Before (N, Decl);
+                  Analyze (Decl);
+                  Analyze (Prag);
+                  Set_Has_Pragma_Inline (Subp);
+
+                  if Get_Pragma_Id (Chars (Prag)) = Pragma_Inline_Always then
+                     Set_Is_Inlined (Subp);
+                     Set_Next_Rep_Item (Prag, First_Rep_Item (Subp));
+                     Set_First_Rep_Item (Subp, Prag);
+                  end if;
+
+                  Spec := Subp;
+               end;
+            end if;
+         end if;
+      end Check_Inline_Pragma;
+
+      -------------------------
+      -- Copy_Parameter_List --
+      -------------------------
+
+      procedure Copy_Parameter_List (Plist : List_Id) is
+         Formal : Entity_Id;
+
+      begin
+         Formal := First_Formal (Body_Id);
+
+         while Present (Formal) loop
+            Append
+              (Make_Parameter_Specification (Loc,
+                Defining_Identifier =>
+                  Make_Defining_Identifier (Sloc (Formal),
+                    Chars => Chars (Formal)),
+                In_Present  => In_Present (Parent (Formal)),
+                Out_Present => Out_Present (Parent (Formal)),
+             Parameter_Type =>
+                  New_Reference_To (Etype (Formal), Loc),
+                Expression =>
+                  New_Copy_Tree (Expression (Parent (Formal)))),
+              Plist);
+
+            Next_Formal (Formal);
+         end loop;
+      end Copy_Parameter_List;
 
       ---------------------------------
       -- Verify_Overriding_Indicator --
@@ -1071,6 +1161,8 @@ package body Sem_Ch6 is
          end loop;
       end if;
 
+      Check_Inline_Pragma (Spec_Id);
+
       --  Case of fully private operation in the body of the protected type.
       --  We must create a declaration for the subprogram, in order to attach
       --  the protected subprogram that will be used in internal calls.
@@ -1101,22 +1193,7 @@ package body Sem_Ch6 is
                Plist := No_List;
             end if;
 
-            while Present (Formal) loop
-               Append
-                 (Make_Parameter_Specification (Loc,
-                   Defining_Identifier =>
-                     Make_Defining_Identifier (Sloc (Formal),
-                       Chars => Chars (Formal)),
-                   In_Present  => In_Present (Parent (Formal)),
-                   Out_Present => Out_Present (Parent (Formal)),
-                   Parameter_Type =>
-                     New_Reference_To (Etype (Formal), Loc),
-                   Expression =>
-                     New_Copy_Tree (Expression (Parent (Formal)))),
-                 Plist);
-
-               Next_Formal (Formal);
-            end loop;
+            Copy_Parameter_List (Plist);
 
             if Nkind (Body_Spec) = N_Procedure_Specification then
                New_Spec :=
@@ -1337,14 +1414,11 @@ package body Sem_Ch6 is
 
       elsif  Present (Spec_Id)
         and then Expander_Active
+        and then
+          (Is_Always_Inlined (Spec_Id)
+             or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
       then
-         Check_Following_Pragma;
-
-         if Is_Always_Inlined (Spec_Id)
-           or else (Has_Pragma_Inline (Spec_Id) and then Front_End_Inlining)
-         then
-            Build_Body_To_Inline (N, Spec_Id);
-         end if;
+         Build_Body_To_Inline (N, Spec_Id);
       end if;
 
       --  Ada 2005 (AI-262): In library subprogram bodies, after the analysis
@@ -2451,9 +2525,29 @@ package body Sem_Ch6 is
                     or else Is_Access_Constant (Etype (Old_Formal))
                               /= Is_Access_Constant (Etype (New_Formal)))
                then
-                  Conformance_Error
-                    ("type of & does not match!", New_Formal);
-                  return;
+                  --  It is allowed to omit the null-exclusion in case of
+                  --  stream attribute subprograms
+
+                  declare
+                     TSS_Name : TSS_Name_Type;
+
+                  begin
+                     Get_Name_String (Chars (New_Id));
+                     TSS_Name :=
+                       TSS_Name_Type
+                         (Name_Buffer
+                            (Name_Len - TSS_Name'Length + 1 .. Name_Len));
+
+                     if TSS_Name /= TSS_Stream_Read
+                       and then TSS_Name /= TSS_Stream_Write
+                       and then TSS_Name /= TSS_Stream_Input
+                       and then TSS_Name /= TSS_Stream_Output
+                     then
+                        Conformance_Error
+                          ("type of & does not match!", New_Formal);
+                        return;
+                     end if;
+                  end;
                end if;
 
                --  Check default expressions for in parameters
@@ -4696,7 +4790,7 @@ package body Sem_Ch6 is
          Decl       : constant Node_Id := Unit_Declaration_Node (E);
 
       begin
-         if Is_Package (Current_Scope)
+         if Is_Package_Or_Generic_Package (Current_Scope)
            and then In_Private_Part (Current_Scope)
          then
             Priv_Decls :=
@@ -5014,7 +5108,7 @@ package body Sem_Ch6 is
                   --  the fact that the full view of a private extension
                   --  re-inherits. It has to be dealt with.
 
-                  if Is_Package (Current_Scope)
+                  if Is_Package_Or_Generic_Package (Current_Scope)
                     and then In_Private_Part (Current_Scope)
                   then
                      Check_Operation_From_Private_View (S, E);
@@ -5423,9 +5517,12 @@ package body Sem_Ch6 is
               and then Is_Access_Type (Formal_Type)
               and then Null_Exclusion_Present (Param_Spec)
             then
-               if Can_Never_Be_Null (Formal_Type) then
+               if Can_Never_Be_Null (Formal_Type)
+                 and then Comes_From_Source (Related_Nod)
+               then
                   Error_Msg_N
-                    ("(Ada 2005) already a null-excluding type", Related_Nod);
+                    ("null exclusion must apply to a type that does not "
+                       & "exclude null ('R'M 3.10 (14)", Related_Nod);
                end if;
 
                Formal_Type :=