exp_ch3.adb, [...]: Minor reformatting.

gcc/ada/

2017-11-09  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch3.adb, gnat1drv.adb, namet.adb, namet.ads, sem_aggr.adb,
	sem_ch2.adb, sem_ch4.adb: Minor reformatting.
	* sem_res.adb (Resolve_Entity_Name): Suppress spurious error on read of
	out parameter when in Ada_83 mode, the oarameter is of a composite
	type, and it appears as the prefix of an attribute.

2017-11-09  Bob Duff  <duff@adacore.com>

	* sinfo.ads: Minor comment fix.

2017-11-09  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.ads: Add pragmas Unmodified and Unreferenced to table
	Pragma_Significant_In_SPARK.

gcc/testsuite/

2017-11-09  Hristian Kirtchev  <kirtchev@adacore.com>

	* gnat.dg/unreferenced.adb: New testcase.

2017-11-09  Ed Schonberg  <schonberg@adacore.com>

	* gnat.dg/out_param.adb: New testcase.

From-SVN: r254571

gcc/ada/exp_ch3.adb

@@ -8717,10 +8717,11 @@ package body Exp_Ch3 is
             --  Initialize secondary tags
 
             else
-               Initialize_Tag (Full_Typ,
-                 Iface     => Node (Iface_Elmt),
-                 Tag_Comp  => Tag_Comp,
-                 Iface_Tag => Node (Iface_Tag_Elmt));
+               Initialize_Tag
+                 (Typ       => Full_Typ,
+                  Iface     => Node (Iface_Elmt),
+                  Tag_Comp  => Tag_Comp,
+                  Iface_Tag => Node (Iface_Tag_Elmt));
             end if;
 
          --  Otherwise generate code to initialize the tag
@@ -8729,10 +8730,11 @@ package body Exp_Ch3 is
             if (In_Variable_Pos and then Variable_Comps)
               or else (not In_Variable_Pos and then Fixed_Comps)
             then
-               Initialize_Tag (Full_Typ,
-                 Iface     => Node (Iface_Elmt),
-                 Tag_Comp  => Tag_Comp,
-                 Iface_Tag => Node (Iface_Tag_Elmt));
+               Initialize_Tag
+                 (Typ       => Full_Typ,
+                  Iface     => Node (Iface_Elmt),
+                  Tag_Comp  => Tag_Comp,
+                  Iface_Tag => Node (Iface_Tag_Elmt));
             end if;
          end if;
 

gcc/ada/gnat1drv.adb

@@ -384,9 +384,10 @@ procedure Gnat1drv is
          Relaxed_RM_Semantics := True;
 
          if not Generate_CodePeer_Messages then
+
             --  Suppress compiler warnings by default when generating SCIL for
-            --  CodePeer, except when combined with -gnateC where we do want
-            --  to emit GNAT warnings.
+            --  CodePeer, except when combined with -gnateC where we do want to
+            --  emit GNAT warnings.
 
             Warning_Mode := Suppress;
          end if;

gcc/ada/namet.adb

@@ -175,7 +175,8 @@ package body Namet is
    --------------------
 
    procedure Append_Decoded
-     (Buf : in out Bounded_String; Id : Valid_Name_Id)
+     (Buf : in out Bounded_String;
+      Id  : Valid_Name_Id)
    is
       C    : Character;
       P    : Natural;
@@ -599,7 +600,8 @@ package body Namet is
    ------------------------
 
    procedure Append_Unqualified
-     (Buf : in out Bounded_String; Id : Valid_Name_Id)
+     (Buf : in out Bounded_String;
+      Id  : Valid_Name_Id)
    is
       Temp : Bounded_String;
    begin
@@ -1476,7 +1478,10 @@ package body Namet is
    -- Name_Equals --
    -----------------
 
-   function Name_Equals (N1, N2 : Valid_Name_Id) return Boolean is
+   function Name_Equals
+     (N1 : Valid_Name_Id;
+      N2 : Valid_Name_Id) return Boolean
+   is
    begin
       return N1 = N2 or else Get_Name_String (N1) = Get_Name_String (N2);
    end Name_Equals;

gcc/ada/namet.ads

@@ -358,7 +358,9 @@ package Namet is
    --  names, since these are efficiently located without hashing by Name_Find
    --  in any case.
 
-   function Name_Equals (N1, N2 : Valid_Name_Id) return Boolean;
+   function Name_Equals
+     (N1 : Valid_Name_Id;
+      N2 : Valid_Name_Id) return Boolean;
    --  Return whether N1 and N2 denote the same character sequence
 
    function Get_Name_String (Id : Valid_Name_Id) return String;

gcc/ada/sem_aggr.adb

@@ -2765,7 +2765,7 @@ package body Sem_Aggr is
    -----------------------------
 
    procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
-      Base   : constant Node_Id := Expression (N);
+      Base : constant Node_Id := Expression (N);
 
    begin
       if not Is_Composite_Type (Typ) then
@@ -2789,12 +2789,14 @@ package body Sem_Aggr is
 
    procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is
       Deltas : constant List_Id := Component_Associations (N);
+
       Assoc      : Node_Id;
       Choice     : Node_Id;
       Index_Type : Entity_Id;
 
    begin
       Index_Type := Etype (First_Index (Typ));
+
       Assoc := First (Deltas);
       while Present (Assoc) loop
          if Nkind (Assoc) = N_Iterated_Component_Association then
@@ -2843,10 +2845,12 @@ package body Sem_Aggr is
 
                else
                   Analyze (Choice);
+
                   if Is_Entity_Name (Choice)
                     and then Is_Type (Entity (Choice))
                   then
-                     --  Choice covers a range of values.
+                     --  Choice covers a range of values
+
                      if Base_Type (Entity (Choice)) /=
                         Base_Type (Index_Type)
                      then
@@ -2874,28 +2878,17 @@ package body Sem_Aggr is
    ------------------------------------
 
    procedure Resolve_Delta_Record_Aggregate (N   : Node_Id; Typ : Entity_Id) is
-      Deltas : constant List_Id := Component_Associations (N);
-      Assoc      : Node_Id;
-      Choice     : Node_Id;
-      Comp_Type  : Entity_Id;
-
-      --  Variables used to verify that discriminant-dependent components
-      --  appear in the same variant.
-
-      Variant  : Node_Id;
-      Comp_Ref : Entity_Id;
-
       procedure Check_Variant (Id : Entity_Id);
       --  If a given component of the delta aggregate appears in a variant
       --  part, verify that it is within the same variant as that of previous
       --  specified variant components of the delta.
 
-      function Nested_In (V1, V2 : Node_Id) return Boolean;
-      --  Determine whether variant V1 is within variant V2.
-
       function Get_Component_Type (Nam : Node_Id) return Entity_Id;
-      --  Locate component with a given name and return its type. If none
-      --  found report error.
+      --  Locate component with a given name and return its type. If none found
+      --  report error.
+
+      function Nested_In (V1 : Node_Id; V2 : Node_Id) return Boolean;
+      --  Determine whether variant V1 is within variant V2
 
       function Variant_Depth (N : Node_Id) return Integer;
       --  Determine the distance of a variant to the enclosing type
@@ -2907,13 +2900,17 @@ package body Sem_Aggr is
 
       procedure Check_Variant (Id : Entity_Id) is
          Comp         : Entity_Id;
+         Comp_Ref     : Entity_Id;
          Comp_Variant : Node_Id;
+         Variant      : Node_Id;
 
       begin
          if not Has_Discriminants (Typ) then
             return;
          end if;
 
+         Variant := Empty;
+
          Comp := First_Entity (Typ);
          while Present (Comp) loop
             exit when Chars (Comp) = Chars (Id);
@@ -2937,9 +2934,9 @@ package body Sem_Aggr is
                begin
                   if D1 = D2
                     or else
-                     (D1 > D2 and then not Nested_In (Variant, Comp_Variant))
+                      (D1 > D2 and then not Nested_In (Variant, Comp_Variant))
                     or else
-                     (D2 > D1 and then not Nested_In (Comp_Variant, Variant))
+                      (D2 > D1 and then not Nested_In (Comp_Variant, Variant))
                   then
                      Error_Msg_Node_2 := Comp_Ref;
                      Error_Msg_NE
@@ -2955,18 +2952,45 @@ package body Sem_Aggr is
          end if;
       end Check_Variant;
 
+      ------------------------
+      -- Get_Component_Type --
+      ------------------------
+
+      function Get_Component_Type (Nam : Node_Id) return Entity_Id is
+         Comp : Entity_Id;
+
+      begin
+         Comp := First_Entity (Typ);
+         while Present (Comp) loop
+            if Chars (Comp) = Chars (Nam) then
+               if Ekind (Comp) = E_Discriminant then
+                  Error_Msg_N ("delta cannot apply to discriminant", Nam);
+               end if;
+
+               return Etype (Comp);
+            end if;
+
+            Comp := Next_Entity (Comp);
+         end loop;
+
+         Error_Msg_NE ("type& has no component with this name", Nam, Typ);
+         return Any_Type;
+      end Get_Component_Type;
+
       ---------------
       -- Nested_In --
       ---------------
 
       function Nested_In (V1, V2 : Node_Id) return Boolean is
          Par : Node_Id;
+
       begin
          Par := Parent (V1);
          while Nkind (Par) /= N_Full_Type_Declaration loop
             if Par = V2 then
                return True;
             end if;
+
             Par := Parent (Par);
          end loop;
 
@@ -2980,53 +3004,35 @@ package body Sem_Aggr is
       function Variant_Depth (N : Node_Id) return Integer is
          Depth : Integer;
          Par   : Node_Id;
+
       begin
          Depth := 0;
          Par   := Parent (N);
          while Nkind (Par) /= N_Full_Type_Declaration loop
             Depth := Depth + 1;
-            Par := Parent (Par);
+            Par   := Parent (Par);
          end loop;
 
          return Depth;
       end Variant_Depth;
 
-      ------------------------
-      -- Get_Component_Type --
-      ------------------------
-
-      function Get_Component_Type (Nam : Node_Id) return Entity_Id is
-         Comp : Entity_Id;
-
-      begin
-         Comp := First_Entity (Typ);
-
-         while Present (Comp) loop
-            if Chars (Comp) = Chars (Nam) then
-               if Ekind (Comp) = E_Discriminant then
-                  Error_Msg_N ("delta cannot apply to discriminant", Nam);
-               end if;
-
-               return Etype (Comp);
-            end if;
+      --  Local variables
 
-            Comp := Next_Entity (Comp);
-         end loop;
+      Deltas : constant List_Id := Component_Associations (N);
 
-         Error_Msg_NE ("type& has no component with this name", Nam, Typ);
-         return Any_Type;
-      end Get_Component_Type;
+      Assoc     : Node_Id;
+      Choice    : Node_Id;
+      Comp_Type : Entity_Id;
 
    --  Start of processing for Resolve_Delta_Record_Aggregate
 
    begin
-      Variant := Empty;
       Assoc := First (Deltas);
-
       while Present (Assoc) loop
          Choice := First (Choice_List (Assoc));
          while Present (Choice) loop
             Comp_Type := Get_Component_Type (Choice);
+
             if Comp_Type /= Any_Type then
                Check_Variant (Choice);
             end if;

gcc/ada/sem_ch2.adb

@@ -68,9 +68,7 @@ package body Sem_Ch2 is
       --  this is the result of some kind of previous error generating a
       --  junk identifier.
 
-      if not Is_Valid_Name (Chars (N))
-        and then Total_Errors_Detected /= 0
-      then
+      if not Is_Valid_Name (Chars (N)) and then Total_Errors_Detected /= 0 then
          return;
       else
          Find_Direct_Name (N);

gcc/ada/sem_ch4.adb

@@ -412,12 +412,12 @@ package body Sem_Ch4 is
    -- Analyze_Aggregate --
    -----------------------
 
-   --  Most of the analysis of Aggregates requires that the type be known,
-   --  and is therefore put off until resolution of the context.
-   --  Delta aggregates have a base component that determines the type of the
-   --  enclosing aggregate so its type can be ascertained earlier. This also
-   --  allows delta aggregates to appear in the context of a record type with
-   --  a private extension, as per the latest update of AI12-0127.
+   --  Most of the analysis of Aggregates requires that the type be known, and
+   --  is therefore put off until resolution of the context. Delta aggregates
+   --  have a base component that determines the enclosing aggregate type so
+   --  its type can be ascertained earlier. This also allows delta aggregates
+   --  to appear in the context of a record type with a private extension, as
+   --  per the latest update of AI12-0127.
 
    procedure Analyze_Aggregate (N : Node_Id) is
    begin
@@ -425,14 +425,15 @@ package body Sem_Ch4 is
          if Nkind (N) = N_Delta_Aggregate then
             declare
                Base : constant Node_Id := Expression (N);
+
                I  : Interp_Index;
                It : Interp;
 
             begin
                Analyze (Base);
 
-               --  If the base is overloaded, propagate interpretations
-               --  to the enclosing aggregate.
+               --  If the base is overloaded, propagate interpretations to the
+               --  enclosing aggregate.
 
                if Is_Overloaded (Base) then
                   Get_First_Interp (Base, I, It);
@@ -1533,12 +1534,15 @@ package body Sem_Ch4 is
               and then Present (Limited_View (Scope (Etype (N))))
               and then not Analyzed (Unit_Declaration_Node (Scope (Etype (N))))
             then
-               Error_Msg_NE ("cannot call function that returns "
-                 & "limited view of}", N, Etype (N));
                Error_Msg_NE
-                 ("\there must be a regular with_clause for package& "
-                   & "in the current unit, or in some unit in its context",
-                    N, Scope (Etype (N)));
+                 ("cannot call function that returns limited view of}",
+                  N, Etype (N));
+
+               Error_Msg_NE
+                 ("\there must be a regular with_clause for package & in the "
+                  & "current unit, or in some unit in its context",
+                  N, Scope (Etype (N)));
+
                Set_Etype (N, Any_Type);
             end if;
          end if;

gcc/ada/sem_prag.ads

@@ -191,6 +191,8 @@ package Sem_Prag is
       Pragma_Remote_Types                  => False,
       Pragma_Shared_Passive                => False,
       Pragma_Task_Dispatching_Policy       => False,
+      Pragma_Unmodified                    => False,
+      Pragma_Unreferenced                  => False,
       Pragma_Warnings                      => False,
       others                               => True);
 

gcc/ada/sem_res.adb

@@ -2442,8 +2442,8 @@ package body Sem_Res is
 
                elsif Nkind_In (N, N_Case_Expression,
                                   N_Character_Literal,
-                                  N_If_Expression,
-                                  N_Delta_Aggregate)
+                                  N_Delta_Aggregate,
+                                  N_If_Expression)
                then
                   Set_Etype (N, Expr_Type);
 
@@ -5197,11 +5197,11 @@ package body Sem_Res is
             --  user about it here.
 
             if Ekind (Typ) = E_Anonymous_Access_Type
-               and then Is_Controlled_Active (Desig_T)
+              and then Is_Controlled_Active (Desig_T)
             then
-               Error_Msg_N ("??anonymous access-to-controlled object will "
-                            & "be finalized when its enclosing unit goes out "
-                            & "of scope", N);
+               Error_Msg_N
+                 ("??anonymous access-to-controlled object will be finalized "
+                  & "when its enclosing unit goes out of scope", N);
             end if;
          end if;
       end if;
@@ -7276,9 +7276,13 @@ package body Sem_Res is
       elsif Ekind (E) = E_Generic_Function then
          Error_Msg_N ("illegal use of generic function", N);
 
-      --  In Ada 83 an OUT parameter cannot be read
+      --  In Ada 83 an OUT parameter cannot be read, but attributes of
+      --  array types (i.e. bounds and length) are legal.
 
       elsif Ekind (E) = E_Out_Parameter
+        and then (Nkind (Parent (N)) /= N_Attribute_Reference
+                   or else Is_Scalar_Type (Etype (E)))
+
         and then (Nkind (Parent (N)) in N_Op
                    or else Nkind (Parent (N)) = N_Explicit_Dereference
                    or else Is_Assignment_Or_Object_Expression

gcc/ada/sinfo.ads

@@ -38,7 +38,7 @@
 
 --  The tree contains not only the full syntactic representation of the
 --  program, but also the results of semantic analysis. In particular, the
---  nodes for defining identifiers, defining character literals and defining
+--  nodes for defining identifiers, defining character literals, and defining
 --  operator symbols, collectively referred to as entities, represent what
 --  would normally be regarded as the symbol table information. In addition a
 --  number of the tree nodes contain semantic information.
@@ -213,7 +213,7 @@ package Sinfo is
 
    --  The Present function tests for Empty, which in this case signals the end
    --  of the list. First returns Empty immediately if the list is empty.
-   --  Present is defined in Atree, First and Next are defined in Nlists.
+   --  Present is defined in Atree; First and Next are defined in Nlists.
 
    --  The exceptions to this rule occur with {DEFINING_IDENTIFIERS} in all
    --  contexts, which is handled as described in the previous section, and
@@ -389,7 +389,7 @@ package Sinfo is
 
    --  In the following node definitions, all fields, both syntactic and
    --  semantic, are documented. The one exception is in the case of entities
-   --  (defining identifiers, character literals and operator symbols), where
+   --  (defining identifiers, character literals, and operator symbols), where
    --  the usage of the fields depends on the entity kind. Entity fields are
    --  fully documented in the separate package Einfo.
 
@@ -1116,7 +1116,7 @@ package Sinfo is
    --    complete a subprogram declaration.
 
    --  Corresponding_Spec_Of_Stub (Node2-Sem)
-   --    This field is present in subprogram, package, task and protected body
+   --    This field is present in subprogram, package, task, and protected body
    --    stubs where it points to the corresponding spec of the stub. Due to
    --    clashes in the structure of nodes, we cannot use Corresponding_Spec.
 
@@ -1754,7 +1754,7 @@ package Sinfo is
 
    --  Is_Generic_Contract_Pragma (Flag2-Sem)
    --    This flag is present in N_Pragma nodes. It is set when the pragma is
-   --    a source construct, applies to a generic unit or its body and denotes
+   --    a source construct, applies to a generic unit or its body, and denotes
    --    one of the following contract-related annotations:
    --      Abstract_State
    --      Contract_Cases
@@ -1910,7 +1910,7 @@ package Sinfo is
    --    nodes which emulate the body of a task unit.
 
    --  Is_Task_Master (Flag5-Sem)
-   --    A flag set in a Subprogram_Body, Block_Statement or Task_Body node to
+   --    A flag set in a Subprogram_Body, Block_Statement, or Task_Body node to
    --    indicate that the construct is a task master (i.e. has declared tasks
    --    or declares an access to a task type).
 
@@ -2019,7 +2019,7 @@ package Sinfo is
    --    calls to Freeze_Expression.
 
    --  Next_Entity (Node2-Sem)
-   --    Present in defining identifiers, defining character literals and
+   --    Present in defining identifiers, defining character literals, and
    --    defining operator symbols (i.e. in all entities). The entities of a
    --    scope are chained, and this field is used as the forward pointer for
    --    this list. See Einfo for further details.
@@ -2236,7 +2236,7 @@ package Sinfo is
    --    because Analyze wants to insert extra actions on this list.
 
    --  Rounded_Result (Flag18-Sem)
-   --    Present in N_Type_Conversion, N_Op_Divide and N_Op_Multiply nodes.
+   --    Present in N_Type_Conversion, N_Op_Divide, and N_Op_Multiply nodes.
    --    Used in the fixed-point cases to indicate that the result must be
    --    rounded as a result of the use of the 'Round attribute. Also used for
    --    integer N_Op_Divide nodes to indicate that the result should be
@@ -2269,7 +2269,7 @@ package Sinfo is
    --    operation named (statically) in a dispatching call.
 
    --  Scope (Node3-Sem)
-   --    Present in defining identifiers, defining character literals and
+   --    Present in defining identifiers, defining character literals, and
    --    defining operator symbols (i.e. in all entities). The entities of a
    --    scope all use this field to reference the corresponding scope entity.
    --    See Einfo for further details.
@@ -2341,7 +2341,7 @@ package Sinfo is
    --    always set to No_List.
 
    --  Treat_Fixed_As_Integer (Flag14-Sem)
-   --    This flag appears in operator nodes for divide, multiply, mod and rem
+   --    This flag appears in operator nodes for divide, multiply, mod, and rem
    --    on fixed-point operands. It indicates that the operands are to be
    --    treated as integer values, ignoring small values. This flag is only
    --    set as a result of expansion of fixed-point operations. Typically a
@@ -2731,7 +2731,7 @@ package Sinfo is
       --  pain to allow these aspects to pervade the pragma syntax, and the
       --  representation of pragma nodes internally. So what we do is to
       --  replace these ASPECT_MARK forms with identifiers whose name is one
-      --  of the special internal names _Pre, _Post or _Type_Invariant.
+      --  of the special internal names _Pre, _Post, or _Type_Invariant.
 
       --  We do a similar replacement of these Aspect_Mark forms in the
       --  Expression of a pragma argument association for the cases of
@@ -3028,8 +3028,8 @@ package Sinfo is
       --    [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
       --    [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
 
-      --  Note: ABSTRACT, LIMITED and record extension part are not permitted
-      --  in Ada 83 mode
+      --  Note: ABSTRACT, LIMITED, and record extension part are not permitted
+      --  in Ada 83 mode.
 
       --  Note: a record extension part is required if ABSTRACT is present
 
@@ -3340,7 +3340,7 @@ package Sinfo is
       --  Subtype_Indication field or else the Access_Definition field.
 
       --  N_Component_Definition
-      --  Sloc points to ALIASED, ACCESS or to first token of subtype mark
+      --  Sloc points to ALIASED, ACCESS, or to first token of subtype mark
       --  Aliased_Present (Flag4)
       --  Null_Exclusion_Present (Flag11)
       --  Subtype_Indication (Node5) (set to Empty if not present)
@@ -3488,7 +3488,7 @@ package Sinfo is
       --    end record
       --  | null record
 
-      --  Note: the Abstract_Present, Tagged_Present and Limited_Present
+      --  Note: the Abstract_Present, Tagged_Present, and Limited_Present
       --  flags appear only for a record definition appearing in a record
       --  type definition.
 
@@ -4016,7 +4016,7 @@ package Sinfo is
       --  Instead the Attribute_Name and Expressions fields of the parent
       --  node (N_Attribute_Reference node) hold the information.
 
-      --  Note: if ACCESS, DELTA or DIGITS appears in an attribute
+      --  Note: if ACCESS, DELTA, or DIGITS appears in an attribute
       --  designator, then they are treated as identifiers internally
       --  rather than the keywords of the same name.
 
@@ -7910,7 +7910,7 @@ package Sinfo is
       --  to aspects/pragmas Contract_Cases and Test_Case. The ordering in the
       --  list is in LIFO fashion.
 
-      --  Classifications contains pragmas that either declare, categorize or
+      --  Classifications contains pragmas that either declare, categorize, or
       --  establish dependencies between subprogram or package inputs and
       --  outputs. Currently the following pragmas appear in this list:
       --    Abstract_States
@@ -13067,7 +13067,7 @@ package Sinfo is
         4 => False,   --  unused
         5 => False),  --  unused
 
-   --  Entries for Empty, Error and Unused. Even thought these have a Chars
+   --  Entries for Empty, Error, and Unused. Even though these have a Chars
    --  field for debugging purposes, they are not really syntactic fields, so
    --  we mark all fields as unused.
 

gcc/testsuite/ChangeLog

 2017-11-09  Hristian Kirtchev  <kirtchev@adacore.com>
 
+	* gnat.dg/unreferenced.adb: New testcase.
+
+2017-11-09  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/out_param.adb: New testcase.
+
+2017-11-09  Hristian Kirtchev  <kirtchev@adacore.com>
+
 	* gnat.dg/elab3.adb, gnat.dg/elab3.ads, gnat.dg/elab3_pkg.adb,
 	gnat.dg/elab3_pkg.ads: New testcase.
 

gcc/testsuite/gnat.dg/out_param.adb

+--  { dg-do compile }
+--  { dg-options "-gnat83" }
+
+procedure Out_Param
+  (Source : in String; Dest : out String; Char_Count : out Natural) is
+begin
+    --| Logic_Step:
+    --|   Copy string Source to string Dest
+  Dest       := (others => ' ');
+  Char_Count := 0;
+  if Source'Length > 0 and then Dest'Length > 0 then
+    if Source'Length > Dest'Length then
+      Char_Count := Dest'Length;
+    else
+      Dest (Dest'First .. (Dest'First + Source'Length - 1)) := Source;
+      Char_Count                                            := Source'Length;
+    end if;
+  else
+    null;
+  end if;
+end Out_Param;

gcc/testsuite/gnat.dg/unreferenced.adb

+--  { dg-do compile }
+--  { dg-options "-gnatd.F" }
+
+procedure Unreferenced is
+   X : aliased Integer;
+   Y : access  Integer := X'Access;
+   Z : Integer renames Y.all;
+   pragma Unreferenced (Z);
+begin
+   null;
+end Unreferenced;