g-expect-vms.adb, [...]: Add pragma Warnings (Off) for unassigned IN OUT arguments

2007-12-19  Robert Dewar  <dewar@adacore.com>

	* g-expect-vms.adb, g-expect.adb, s-poosiz.adb: 
	Add pragma Warnings (Off) for unassigned IN OUT arguments

	* sem_warn.adb (Output_Reference): Suppress messages for internal names
	(Check_References): Extensive changes to tune up warnings
	(Output_Non_Modifed_In_Out_Warnings): Changes to tune up warnings
	(Has_Pragma_Unmodifed_Check_Spec): New function
	(Check_References): Implement pragma Unmodified
	(Warn_On_Unassigned_Out_Parameter): Implement pragma Unmodified

	* par-prag.adb: Dummy entry for pragma Unmodified

	* sem_prag.adb: Implement pragma Unmodified

	* einfo.ads, einfo.adb: (Has_Pragma_Unmodified): New flag
	(Proc_Next_Component_Or_Discriminant): Fix typo.
	Update comments.

	* sem_util.adb (Note_Possible_Modification): Add processinng for pragma
	Unmodified.
	(Reset_Analyzed_Flags): Use Traverse_Proc instead of Traverse_Func,
	because the former already takes care of discarding the result.
	(Mark_Coextensions): Remove ununused initial value from Is_Dynamic.
	Add comment.

	* snames.h, snames.ads, snames.adb: Add entry for pragma Unmodified

From-SVN: r131068

gcc/ada/einfo.adb

@@ -494,8 +494,8 @@ package body Einfo is
 
    --    Renamed_In_Spec                 Flag231
    --    Implemented_By_Entry            Flag232
+   --    Has_Pragma_Unmodified           Flag233
 
-   --    (unused)                        Flag233
    --    (unused)                        Flag234
    --    (unused)                        Flag235
    --    (unused)                        Flag236
@@ -1362,6 +1362,11 @@ package body Einfo is
       return Flag179 (Id);
    end Has_Pragma_Pure_Function;
 
+   function Has_Pragma_Unmodified (Id : E) return B is
+   begin
+      return Flag233 (Id);
+   end Has_Pragma_Unmodified;
+
    function Has_Pragma_Unreferenced (Id : E) return B is
    begin
       return Flag180 (Id);
@@ -3712,6 +3717,11 @@ package body Einfo is
       Set_Flag179 (Id, V);
    end Set_Has_Pragma_Pure_Function;
 
+   procedure Set_Has_Pragma_Unmodified (Id : E; V : B := True) is
+   begin
+      Set_Flag233 (Id, V);
+   end Set_Has_Pragma_Unmodified;
+
    procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True) is
    begin
       Set_Flag180 (Id, V);
@@ -7275,6 +7285,7 @@ package body Einfo is
       W ("Has_Pragma_Preelab_Init",         Flag221 (Id));
       W ("Has_Pragma_Pure",                 Flag203 (Id));
       W ("Has_Pragma_Pure_Function",        Flag179 (Id));
+      W ("Has_Pragma_Unmodified",           Flag233 (Id));
       W ("Has_Pragma_Unreferenced",         Flag180 (Id));
       W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id));
       W ("Has_Primitive_Operations",        Flag120 (Id));
@@ -8446,7 +8457,13 @@ package body Einfo is
 
    procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id) is
    begin
-      N := Next_Component (N);
+      N := Next_Entity (N);
+      while Present (N) loop
+         exit when Ekind (N) = E_Component
+                     or else
+                   Ekind (N) = E_Discriminant;
+         N := Next_Entity (N);
+      end loop;
    end Proc_Next_Component_Or_Discriminant;
 
    procedure Proc_Next_Discriminant              (N : in out Node_Id) is

gcc/ada/einfo.ads

@@ -1532,6 +1532,8 @@ package Einfo is
 --      Present in E_Variable and E_Constant entities. Set if the entity is
 --      declared in a local procedure p and is accessed in a procedure nested
 --      inside p. Only set when VM_Target /= No_VM currently.
+--      Why only set it under those conditions, sounds reasonable to always
+--      set this flag when appropriate ???
 
 --    Has_Nested_Block_With_Handler (Flag101)
 --       Present in scope entities. Set if there is a nested block within the
@@ -1619,9 +1621,15 @@ package Einfo is
 --       Pure_Function was given for the entity. In some cases, we need to
 --       know that Is_Pure was explicitly set using this pragma.
 
+--    Has_Pragma_Unmodified (Flag233)
+--       Present in all entities. Can only be set for variables (E_Variable,
+--       E_Out_Parameter, E_In_Out_Parameter). Set if a valid pragma Unmodified
+--       applies to the variable, indicating that no warning should be given
+--       if the entity is never modified.
+
 --    Has_Pragma_Unreferenced (Flag180)
 --       Present in all entities. Set if a valid pragma Unreferenced applies
---       to the pragma, indicating that no warning should be given if the
+--       to the entity, indicating that no warning should be given if the
 --       entity has no references, but a warning should be given if it is
 --       in fact referenced. For private types, this flag is set in both the
 --       private entity and full entity if the pragma applies to either.
@@ -2402,8 +2410,8 @@ package Einfo is
 --       extended Import pragmas. Can only be set for OpenVMS versions of GNAT.
 
 --    Is_Ordinary_Fixed_Point_Type (synthesized)
---       Applies to all entities, true for ordinary fixed point types
---       and subtypes
+--       Applies to all entities, true for ordinary fixed point types and
+--       subtypes.
 
 --    Is_Overriding_Operation (Flag39)
 --       Present in subprograms. Set if the subprogram is a primitive
@@ -2479,8 +2487,8 @@ package Einfo is
 
 --    Is_Primitive (Flag218)
 --       Present in overloadable entities and in generic subprograms. Set to
---       indicate that this is a primitive operation of some type, which may be
---       a tagged type or a non-tagged type. Used to verify overriding
+--       indicate that this is a primitive operation of some type, which may
+--       be a tagged type or a non-tagged type. Used to verify overriding
 --       indicators in bodies.
 
 --    Is_Primitive_Wrapper (Flag195)
@@ -2650,14 +2658,14 @@ package Einfo is
 --       associated with accessibility level.
 
 --    Is_True_Constant (Flag163)
---       This flag applies to all entities for constants and variables. Set
---       in constants and variables which have an initial value specified but
---       which are never assigned, partially or in the whole. For variables, it
---       means that the variable was initialized but never modified, and hence
---       can be treated as a constant by the code generator. For a constant, it
---       means that the constant was not modified by generated code (e.g. to
---       set a discriminant in an init proc). Assignments by user or generated
---       code will reset this flag.
+--       Present in all entities for constants and variables. Set in constants
+--       and variables which have an initial value specified but which are
+--       never assigned, partially or in the whole. For variables, it means
+--       that the variable was initialized but never modified, and hence can be
+--       treated as a constant by the code generator. For a constant, it means
+--       that the constant was not modified by generated code (e.g. to set a
+--       discriminant in an init proc). Assignments by user or generated code
+--       will reset this flag.
 --
 --       Note: there is one situation in which the back end does not permit
 --       this flag to be set, even if no assignments are generated. This is
@@ -3378,7 +3386,7 @@ package Einfo is
 --       the Scope will be the parent package, and for a non-child package,
 --       the Scope will be Standard.
 
---    Scope_Depth (synth)
+--    Scope_Depth (synthesized)
 --       Applies to program units, blocks, concurrent types and entries,
 --       and also to record types, i.e. to any entity that can appear on
 --       the scope stack. Yields the scope depth value, which for those
@@ -4473,6 +4481,7 @@ package Einfo is
    --    Has_Pragma_Pack                     (Flag121)  (base type only)
    --    Has_Pragma_Pure                     (Flag203)
    --    Has_Pragma_Pure_Function            (Flag179)
+   --    Has_Pragma_Unmodified               (Flag233)
    --    Has_Pragma_Unreferenced             (Flag180)
    --    Has_Private_Declaration             (Flag155)
    --    Has_Qualified_Name                  (Flag161)
@@ -5781,6 +5790,7 @@ package Einfo is
    function Has_Pragma_Preelab_Init             (Id : E) return B;
    function Has_Pragma_Pure                     (Id : E) return B;
    function Has_Pragma_Pure_Function            (Id : E) return B;
+   function Has_Pragma_Unmodified               (Id : E) return B;
    function Has_Pragma_Unreferenced             (Id : E) return B;
    function Has_Pragma_Unreferenced_Objects     (Id : E) return B;
    function Has_Primitive_Operations            (Id : E) return B;
@@ -6322,6 +6332,7 @@ package Einfo is
    procedure Set_Has_Pragma_Preelab_Init         (Id : E; V : B := True);
    procedure Set_Has_Pragma_Pure                 (Id : E; V : B := True);
    procedure Set_Has_Pragma_Pure_Function        (Id : E; V : B := True);
+   procedure Set_Has_Pragma_Unmodified           (Id : E; V : B := True);
    procedure Set_Has_Pragma_Unreferenced         (Id : E; V : B := True);
    procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True);
    procedure Set_Has_Primitive_Operations        (Id : E; V : B := True);
@@ -6644,7 +6655,7 @@ package Einfo is
      renames Proc_Next_Component;
 
    procedure Next_Component_Or_Discriminant (N : in out Node_Id)
-     renames Proc_Next_Component;
+     renames Proc_Next_Component_Or_Discriminant;
 
    procedure Next_Discriminant              (N : in out Node_Id)
      renames Proc_Next_Discriminant;
@@ -6931,6 +6942,7 @@ package Einfo is
    pragma Inline (Has_Pragma_Preelab_Init);
    pragma Inline (Has_Pragma_Pure);
    pragma Inline (Has_Pragma_Pure_Function);
+   pragma Inline (Has_Pragma_Unmodified);
    pragma Inline (Has_Pragma_Unreferenced);
    pragma Inline (Has_Pragma_Unreferenced_Objects);
    pragma Inline (Has_Primitive_Operations);
@@ -7343,6 +7355,7 @@ package Einfo is
    pragma Inline (Set_Has_Pragma_Preelab_Init);
    pragma Inline (Set_Has_Pragma_Pure);
    pragma Inline (Set_Has_Pragma_Pure_Function);
+   pragma Inline (Set_Has_Pragma_Unmodified);
    pragma Inline (Set_Has_Pragma_Unreferenced);
    pragma Inline (Set_Has_Pragma_Unreferenced_Objects);
    pragma Inline (Set_Has_Primitive_Operations);

gcc/ada/g-expect-vms.adb

@@ -1082,6 +1082,9 @@ package body GNAT.Expect is
       Args  : System.Address)
    is
       pragma Warnings (Off, Pid);
+      pragma Warnings (Off, Pipe1);
+      pragma Warnings (Off, Pipe2);
+      pragma Warnings (Off, Pipe3);
 
    begin
       --  Since the code between fork and exec on VMS executes
@@ -1099,6 +1102,7 @@ package body GNAT.Expect is
       --  Since we are still called from the parent process, there is no way
       --  currently we can cleanly close the unneeded ends of the pipes, but
       --  this doesn't really matter.
+
       --  We could close Pipe1.Output, Pipe2.Input, Pipe3.Input.
 
       Dup2 (Pipe1.Input,  GNAT.OS_Lib.Standin);
@@ -1106,7 +1110,6 @@ package body GNAT.Expect is
       Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr);
 
       Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.Nul, Args);
-
    end Set_Up_Child_Communications;
 
    ---------------------------
@@ -1156,6 +1159,9 @@ package body GNAT.Expect is
       Pipe3 : in out Pipe_Type)
    is
       pragma Warnings (Off, Pid);
+      pragma Warnings (Off, Pipe1);
+      pragma Warnings (Off, Pipe2);
+      pragma Warnings (Off, Pipe3);
 
    begin
 

gcc/ada/g-expect.adb

@@ -1190,6 +1190,9 @@ package body GNAT.Expect is
       Args  : System.Address)
    is
       pragma Warnings (Off, Pid);
+      pragma Warnings (Off, Pipe1);
+      pragma Warnings (Off, Pipe2);
+      pragma Warnings (Off, Pipe3);
 
       Input  : File_Descriptor;
       Output : File_Descriptor;
@@ -1210,7 +1213,8 @@ package body GNAT.Expect is
       --  Since we are still called from the parent process, there is no way
       --  currently we can cleanly close the unneeded ends of the pipes, but
       --  this doesn't really matter.
-      --  We could close Pipe1.Output, Pipe2.Input, Pipe3.Input.
+
+      --  We could close Pipe1.Output, Pipe2.Input, Pipe3.Input
 
       Dup2 (Pipe1.Input,  GNAT.OS_Lib.Standin);
       Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout);
@@ -1298,6 +1302,9 @@ package body GNAT.Expect is
       Pipe3 : in out Pipe_Type)
    is
       pragma Warnings (Off, Pid);
+      pragma Warnings (Off, Pipe1);
+      pragma Warnings (Off, Pipe2);
+      pragma Warnings (Off, Pipe3);
    begin
       Close (Pipe1.Input);
       Close (Pipe2.Output);

gcc/ada/par-prag.adb

@@ -1181,6 +1181,7 @@ begin
            Pragma_Unimplemented_Unit            |
            Pragma_Universal_Aliasing            |
            Pragma_Universal_Data                |
+           Pragma_Unmodified                    |
            Pragma_Unreferenced                  |
            Pragma_Unreferenced_Objects          |
            Pragma_Unreserve_All_Interrupts      |

gcc/ada/s-poosiz.adb

@@ -301,6 +301,8 @@ package body System.Pool_Size is
          Storage_Size : SSE.Storage_Count;
          Alignment    : SSE.Storage_Count)
       is
+         pragma Warnings (Off, Pool);
+
          Align_Size : constant SSE.Storage_Count :=
                         ((Storage_Size + Alignment - 1) / Alignment) *
                                                                  Alignment;

gcc/ada/sem_prag.adb

@@ -10755,6 +10755,54 @@ package body Sem_Prag is
                Error_Pragma ("?pragma% ignored (applies only to AAMP)");
             end if;
 
+         ----------------
+         -- Unmodified --
+         ----------------
+
+         --  pragma Unmodified (local_Name {, local_Name});
+
+         when Pragma_Unmodified => Unmodified : declare
+            Arg_Node : Node_Id;
+            Arg_Expr : Node_Id;
+            Arg_Ent  : Entity_Id;
+
+         begin
+            GNAT_Pragma;
+            Check_At_Least_N_Arguments (1);
+
+            --  Loop through arguments
+
+            Arg_Node := Arg1;
+            while Present (Arg_Node) loop
+               Check_No_Identifier (Arg_Node);
+
+               --  Note: the analyze call done by Check_Arg_Is_Local_Name
+               --  will in fact generate reference, so that the entity will
+               --  have a reference, which will inhibit any warnings about
+               --  it not being referenced, and also properly show up in the
+               --  ali file as a reference. But this reference is recorded
+               --  before the Has_Pragma_Unreferenced flag is set, so that
+               --  no warning is generated for this reference.
+
+               Check_Arg_Is_Local_Name (Arg_Node);
+               Arg_Expr := Get_Pragma_Arg (Arg_Node);
+
+               if Is_Entity_Name (Arg_Expr) then
+                  Arg_Ent := Entity (Arg_Expr);
+
+                  if not Is_Assignable (Arg_Ent) then
+                     Error_Pragma_Arg
+                       ("pragma% can only be applied to a variable",
+                        Arg_Expr);
+                  else
+                     Set_Has_Pragma_Unmodified (Arg_Ent);
+                  end if;
+               end if;
+
+               Next (Arg_Node);
+            end loop;
+         end Unmodified;
+
          ------------------
          -- Unreferenced --
          ------------------
@@ -11501,6 +11549,7 @@ package body Sem_Prag is
       Pragma_Unimplemented_Unit            => -1,
       Pragma_Universal_Aliasing            => -1,
       Pragma_Universal_Data                => -1,
+      Pragma_Unmodified                    => -1,
       Pragma_Unreferenced                  => -1,
       Pragma_Unreferenced_Objects          => -1,
       Pragma_Unreserve_All_Interrupts      => -1,

gcc/ada/sem_util.adb

@@ -7398,7 +7398,9 @@ package body Sem_Util is
    -----------------------
 
    procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
-      Is_Dynamic : Boolean := False;
+      Is_Dynamic : Boolean;
+      --  Indicates whether the context causes nested coextensions to be
+      --  dynamic or static
 
       function Mark_Allocator (N : Node_Id) return Traverse_Result;
       --  Recognize an allocator node and label it as a dynamic coextension
@@ -7932,6 +7934,10 @@ package body Sem_Util is
                if Comes_From_Source (Exp)
                  or else Modification_Comes_From_Source
                then
+                  if Has_Pragma_Unmodified (Ent) then
+                     Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent);
+                  end if;
+
                   Set_Never_Set_In_Source (Ent, False);
                end if;
 
@@ -8565,16 +8571,12 @@ package body Sem_Util is
          return OK;
       end Clear_Analyzed;
 
-      function Reset_Analyzed is
-        new Traverse_Func (Clear_Analyzed);
-
-      Discard : Traverse_Result;
-      pragma Warnings (Off, Discard);
+      procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
 
    --  Start of processing for Reset_Analyzed_Flags
 
    begin
-      Discard := Reset_Analyzed (N);
+      Reset_Analyzed (N);
    end Reset_Analyzed_Flags;
 
    ---------------------------

gcc/ada/snames.adb

@@ -326,6 +326,7 @@ package body Snames is
      "unchecked_union#" &
      "unimplemented_unit#" &
      "universal_aliasing#" &
+     "unmodified#" &
      "unreferenced#" &
      "unreferenced_objects#" &
      "unreserve_all_interrupts#" &

gcc/ada/snames.h

@@ -367,17 +367,18 @@ extern unsigned char Get_Pragma_Id (int);
 #define  Pragma_Unchecked_Union               148
 #define  Pragma_Unimplemented_Unit            149
 #define  Pragma_Universal_Aliasing            150
-#define  Pragma_Unreferenced                  151
-#define  Pragma_Unreferenced_Objects          152
-#define  Pragma_Unreserve_All_Interrupts      153
-#define  Pragma_Volatile                      154
-#define  Pragma_Volatile_Components           155
-#define  Pragma_Weak_External                 156
-#define  Pragma_AST_Entry                     157
-#define  Pragma_Fast_Math                     158
-#define  Pragma_Interface                     159
-#define  Pragma_Priority                      160
-#define  Pragma_Storage_Size                  161
-#define  Pragma_Storage_Unit                  162
+#define  Pragma_Unmodified                    151
+#define  Pragma_Unreferenced                  152
+#define  Pragma_Unreferenced_Objects          153
+#define  Pragma_Unreserve_All_Interrupts      154
+#define  Pragma_Volatile                      155
+#define  Pragma_Volatile_Components           156
+#define  Pragma_Weak_External                 157
+#define  Pragma_AST_Entry                     158
+#define  Pragma_Fast_Math                     159
+#define  Pragma_Interface                     160
+#define  Pragma_Priority                      161
+#define  Pragma_Storage_Size                  162
+#define  Pragma_Storage_Unit                  163
 
 /* End of snames.h (C version of Snames package spec) */