path: root/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a

-- CXB3012.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
--     this public release, the Government intends to confer upon all
--     recipients unlimited rights  equal to those held by the Government.
--     These rights include rights to use, duplicate, release or disclose the
--     released technical data and computer software in whole or in part, in
--     any manner and for any purpose whatsoever, and to have or permit others
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--      Check that Procedure Update modifies the value pointed to by
--      the chars_ptr parameter Item, starting at the position
--      corresponding to parameter Offset, using the chars in
--      char_array parameter Chars.
--
--      Check that the version of Procedure Update with a String parameter
--      behaves in the manner described above, but with the character
--      values in the String overwriting the char values in Item.
--
--      Check that both of the above versions of Procedure Update will
--      propagate Update_Error if Check is True, and if the length of
--      the new chars in Chars, when overlaid starting from position
--      Offset, will overwrite the first nul in Item.
--
-- TEST DESCRIPTION:
--      This test checks two versions of Procedure Update.  In the first
--      version of the procedure, the parameter Chars indicates a char_array
--      argument.  These char_array parameters are provided through the use
--      of the To_C function (with String IN parameter), both with and
--      without a terminating nul.  In the case below where a terminating nul
--      char is appended, the effect of "updating" the value pointed to by the
--      Item parameter will include its shortening, due to the insertion of
--      this additional nul in the middle of the char_array.
--
--      In the second version of Procedure Update evaluated here, the string
--      parameter Str is used to modify the char_array pointed to by Item.
--
--      Finally, both versions of the procedure are evaluated to ensure that
--      they propagate Update_Error and Dereference_Error under the proper
--      conditions.
--
--      This test assumes that the following characters are all included
--      in the implementation defined type Interfaces.C.char:
--      ' ', 'a'..'z', 'A'..'Z', '0'..'9', '-' and '.'.
--
-- APPLICABILITY CRITERIA:
--      This test is applicable to all implementations that provide
--      package Interfaces.C.Strings.  If an implementation provides
--      package Interfaces.C.Strings, this test must compile, execute,
--      and report "PASSED".
--
--
-- CHANGE HISTORY:
--      05 Oct 95   SAIC    Initial prerelease version.
--      13 May 96   SAIC    Incorporated reviewer comments for ACVC 2.1.
--      26 Oct 96   SAIC    Incorporated reviewer comments.
--      14 Sep 99   RLB     Removed incorrect and unnecessary
--                          Unchecked_Conversion. Added check for raising
--                          of Dereference_Error for Update (From Technical
--                          Corrigendum 1).
--      07 Jan 05   RLB     Modified to reflect change to Update by AI-242
--                          (which is expected to be part of Amendment 1).
--                          [This version allows either semantics.]

--!

with Report;
with Ada.Exceptions;
with Interfaces.C.Strings;                                    -- N/A => ERROR

procedure CXB3012 is
begin

   Report.Test ("CXB3012", "Check that both versions of Procedure Update " &
                           "produce correct results");

   Test_Block:
   declare

      package IC  renames Interfaces.C;
      package ICS renames Interfaces.C.Strings;
      use Ada.Exceptions;

      use type IC.char;
      use type IC.char_array;
      use type IC.size_t;
      use type ICS.chars_ptr;

      TC_String_1        : String(1..1)    := "J";
      TC_String_2        : String(1..2)    := "Ab";
      TC_String_3        : String(1..3)    := "xyz";
      TC_String_4        : String(1..4)    := "ACVC";
      TC_String_5        : String(1..5)    := "1a2b3";
      TC_String_6        : String(1..6)    := "---...";
      TC_String_7        : String(1..7)    := "AABBBAA";
      TC_String_8        : String(1..8)    := "aBcDeFgH";
      TC_String_9        : String(1..9)    := "JustATest";
      TC_String_10       : String(1..10)   := "0123456789";

      TC_Result_String_1 : constant String := "JXXXXXXXXX";
      TC_Result_String_2 : constant String := "XXXXXXXXAb";
      TC_Result_String_3 : constant String := "XXXxyz";
      TC_Result_String_4 : constant String := "XACVC";
      TC_Result_String_5 : constant String := "1a2b3";
      TC_Result_String_6 : constant String := "XXX---...";

      TC_Amd_Result_String_4 :
                           constant String := "XACVCXXXXX";
      TC_Amd_Result_String_5 :
                           constant String := "1a2b3XXXXX";
      TC_Amd_Result_String_6 :
                           constant String := "XXX---...X";
      TC_Amd_Result_String_9 :
                           constant String := "JustATestX";

      TC_char_array        : IC.char_array(0..10) := IC.To_C("XXXXXXXXXX");
      TC_Result_char_array : IC.char_array(0..10) := IC.To_C("XXXXXXXXXX");
      TC_chars_ptr         : ICS.chars_ptr;
      TC_Length            : IC.size_t;

   begin

      -- Check that Procedure Update modifies the value pointed to by
      -- the chars_ptr parameter Item, starting at the position
      -- corresponding to parameter Offset, using the chars in
      -- char_array parameter Chars.
      -- Note: If parameter Chars contains a nul char (such as a
      --       terminating nul), the result may be the overall shortening
      --       of parameter Item.

      TC_chars_ptr := ICS.New_Char_Array(TC_char_array);

      ICS.Update(Item   => TC_chars_ptr,
                 Offset => 0,
                 Chars  => IC.To_C(TC_String_1, False),  -- No nul char.
                 Check  => True);

      if ICS.Value(TC_chars_ptr) /= TC_Result_String_1 then
         Report.Failed("Incorrect result from Procedure Update - 1");
      end if;
      ICS.Free(TC_chars_ptr);


      TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
      ICS.Update(TC_chars_ptr,
                 Offset => ICS.Strlen(TC_chars_ptr) - 2,
                 Chars  => IC.To_C(TC_String_2, False),  -- No nul char.
                 Check  => True);

      if ICS.Value(TC_chars_ptr) /= TC_Result_String_2 then
         Report.Failed("Incorrect result from Procedure Update - 2");
      end if;
      ICS.Free(TC_chars_ptr);


      TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
      ICS.Update(TC_chars_ptr,
                 3,
                 Chars  => IC.To_C(TC_String_3),   -- Nul appended, shortens
                 Check  => False);                 -- array.

      if ICS.Value(TC_chars_ptr) /= TC_Result_String_3 then
         Report.Failed("Incorrect result from Procedure Update - 3");
      end if;
      ICS.Free(TC_chars_ptr);


      TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
      ICS.Update(TC_chars_ptr,
                 0,
                 IC.To_C(TC_String_10), -- Complete replacement of array.
                 Check  => False);

      if ICS.Value(TC_chars_ptr) /= TC_String_10 then
         Report.Failed("Incorrect result from Procedure Update - 4");
      end if;

      -- Perform a character-by-character comparison of the result of
      -- Procedure Update. Note that char_array lower bound is 0, and
      -- that the nul char is not compared with any character in the
      -- string (since the string is not nul terminated).
      begin
         TC_Length := ICS.Strlen(TC_chars_ptr);
         TC_Result_char_array(0..10) := ICS.Value(TC_chars_ptr);
         for i in 0..TC_Length-1 loop
            if TC_Result_char_array(i) /=
               IC.To_C(TC_String_10(Integer(i+1)))
            then
               Report.Failed("Incorrect result from the character-by-" &
                             "character evaluation of the result of "  &
                             "Procedure Update");
            end if;
         end loop;
      exception
         when others =>
           Report.Failed("Exception raised during the character-by-" &
                         "character evaluation of the result of "    &
                         "Procedure Update");
      end;
      ICS.Free(TC_chars_ptr);



      -- Check that the version of Procedure Update with a String rather
      -- than a char_array parameter behaves in the manner described above,
      -- but with the character values in the String overwriting the char
      -- values in Item.
      --
      -- Note: In Ada 95, In each of the cases below, the String parameter
      --       Str is treated as if it were nul terminated, which means that
      --       the char_array pointed to by TC_chars_ptr will be "shortened"
      --       so that it ends after the last character of the Str
      --       parameter. For Ada 2005, this rule is dropped, so the
      --       number of characters remains the same.

      TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
      ICS.Update(TC_chars_ptr, 1, TC_String_4, False);

      if ICS.Value(TC_chars_ptr) = TC_Result_String_4 then
         Report.Comment("Ada 95 result from Procedure Update - 5");
      elsif ICS.Value(TC_chars_ptr) = TC_Amd_Result_String_4 then
         Report.Comment("Amendment 1 result from Procedure Update - 5");
      else
         Report.Failed("Incorrect result from Procedure Update - 5");
      end if;
      ICS.Free(TC_chars_ptr);


      TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
      ICS.Update(Item   => TC_chars_ptr,
                 Offset => 0,
                 Str    => TC_String_5);

      if ICS.Value(TC_chars_ptr) = TC_Result_String_5 then
         Report.Comment("Ada 95 result from Procedure Update - 6");
      elsif ICS.Value(TC_chars_ptr) = TC_Amd_Result_String_5 then
         Report.Comment("Amendment 1 result from Procedure Update - 6");
      else
         Report.Failed("Incorrect result from Procedure Update - 6");
      end if;
      ICS.Free(TC_chars_ptr);


      TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
      ICS.Update(TC_chars_ptr,
                 3,
                 Str    => TC_String_6,
                 Check  => True);

      if ICS.Value(TC_chars_ptr) = TC_Result_String_6 then
         Report.Comment("Ada 95 result from Procedure Update - 7");
      elsif ICS.Value(TC_chars_ptr) = TC_Amd_Result_String_6 then
         Report.Comment("Amendment 1 result from Procedure Update - 7");
      else
         Report.Failed("Incorrect result from Procedure Update - 7");
      end if;
      ICS.Free(TC_chars_ptr);


      TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
      ICS.Update(TC_chars_ptr, 0, TC_String_9, True);

      if ICS.Value(TC_chars_ptr) = TC_String_9 then
         Report.Comment("Ada 95 result from Procedure Update - 8");
      elsif ICS.Value(TC_chars_ptr) = TC_Amd_Result_String_9 then
         Report.Comment("Amendment 1 result from Procedure Update - 8");
      else
         Report.Failed("Incorrect result from Procedure Update - 8");
      end if;
      ICS.Free(TC_chars_ptr);

      -- Check what happens if the string and array are the same size (this
      -- is the case that caused the change made by the Amendment).
      begin
         TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
         ICS.Update(Item   => TC_chars_ptr,
                    Offset => 0,
                    Str    => TC_String_10,
                    Check  => True);
          if ICS.Value(TC_chars_ptr) = TC_String_10 then
             Report.Comment("Amendment 1 result from Procedure Update - 9");
          else
             Report.Failed("Incorrect result from Procedure Update - 9");
          end if;
      exception
         when ICS.Update_Error =>
             Report.Comment("Ada 95 exception expected from Procedure Update - 9");
         when others           =>
           Report.Failed("Incorrect exception raised by Procedure Update " &
                         "with Str parameter - 9");
      end;
      ICS.Free(TC_chars_ptr);


      -- Check that both of the above versions of Procedure Update will
      -- propagate Update_Error if Check is True, and if the length of
      -- the new chars in Chars, when overlaid starting from position
      -- Offset, will overwrite the first nul in Item.

      begin
         TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
         ICS.Update(Item   => TC_chars_ptr,
                    Offset => 5,
                    Chars  => IC.To_C(TC_String_7),
                    Check  => True);
         Report.Failed("Update_Error not raised by Procedure Update with " &
                       "Chars parameter");
         Report.Comment(ICS.Value(TC_chars_ptr) & "used here to defeat " &
                        "optimization - should never be printed");
      exception
         when ICS.Update_Error => null;  -- OK, expected exception.
         when others           =>
           Report.Failed("Incorrect exception raised by Procedure Update " &
                         "with Chars parameter");
      end;

      ICS.Free(TC_chars_ptr);

      begin
         TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
         ICS.Update(Item   => TC_chars_ptr,
                    Offset => ICS.Strlen(TC_chars_ptr),
                    Str    => TC_String_8); -- Default Check parameter value.
         Report.Failed("Update_Error not raised by Procedure Update with " &
                       "Str parameter");
         Report.Comment(ICS.Value(TC_chars_ptr) & "used here to defeat " &
                        "optimization - should never be printed");
      exception
         when ICS.Update_Error => null;  -- OK, expected exception.
         when others           =>
           Report.Failed("Incorrect exception raised by Procedure Update " &
                         "with Str parameter");
      end;

      ICS.Free(TC_chars_ptr);

      -- Check that both of the above versions of Procedure Update will
      -- propagate Dereference_Error if Item is Null_Ptr.
      -- Note: Free sets TC_chars_ptr to Null_Ptr.

      begin
         ICS.Update(Item   => TC_chars_ptr,
                    Offset => 5,
                    Chars  => IC.To_C(TC_String_7),
                    Check  => True);
         Report.Failed("Dereference_Error not raised by Procedure Update with " &
                       "Chars parameter");
      exception
         when ICS.Dereference_Error => null;  -- OK, expected exception.
         when others           =>
           Report.Failed("Incorrect exception raised by Procedure Update " &
                         "with Chars parameter");
      end;

      begin
         ICS.Update(Item   => TC_chars_ptr,
                    Offset => ICS.Strlen(TC_chars_ptr),
                    Str    => TC_String_8); -- Default Check parameter value.
         Report.Failed("Dereference_Error not raised by Procedure Update with " &
                       "Str parameter");
      exception
         when ICS.Dereference_Error => null;  -- OK, expected exception.
         when others           =>
           Report.Failed("Incorrect exception raised by Procedure Update " &
                         "with Str parameter");
      end;

   exception
      when The_Error : others =>
         Report.Failed ("The following exception was raised in the " &
                        "Test_Block: " & Exception_Name(The_Error));
   end Test_Block;

   Report.Result;

end CXB3012;