path: root/gcc/testsuite/ada/acats-4/tests/c6/c641002.a

-- C641002.A
--
--                             Grant of Unlimited Rights
--
--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
--     rights in the software and documentation contained herein. Unlimited
--     rights are the same as those granted by the U.S. Government for older
--     parts of the Ada Conformity Assessment Test Suite, and are defined
--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--     intends to confer upon all recipients unlimited rights equal to those
--     held by the ACAA. 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 ACAA 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.
--
--                                     Notice
--
--     The ACAA has created and maintains the Ada Conformity Assessment Test
--     Suite for the purpose of conformity assessments conducted in accordance
--     with the International Standard ISO/IEC 18009 - Ada: Conformity
--     assessment of a language processor. This test suite should not be used
--     to make claims of conformance unless used in accordance with
--     ISO/IEC 18009 and any applicable ACAA procedures.
--*
-- OBJECTIVES:
--     Check that, for an out parameter of a scalar type with a specified
--     Default_Value, the value of the actual parameter is passed in without
--     any constraint check.
--
-- TEST DESCRIPTION:
--     Ada has a general principle that an out parameter (which is logically
--     uninitialized) will as much as practical not raise any exception when
--     making a call. (Of course, an exception could be raised inside the
--     called subprogram, and for by-copy types, the copy back might raise
--     an exception if the value is changed by the called subprogram.)
--
--     This test checks 6.4.1(13.1/3). The purpose of this rule is that an
--     actual object for an out parameter which initially has a valid value
--     will remain valid without raising an exception before the call. This
--     should be true even if the out parameter is not written in the 
--     subprogram even if the Default_Value of the type does not belong to
--     the subtype of the parameter.
--
--     So we test calls on a procedure which may or may not write the out
--     parameters. This procedure models a subprogram which returns multiple
--     results -- here, which parameters are used for results depends
--     upon the result returned in other parameters. (This is a fairly common
--     usage pattern; it's often used as a function can return only a single
--     result.)
--
-- CHANGE HISTORY:
--     30 Mar 21   RLB     Created test for RRS, donated to ACATS.
--
--!
package C641002_0 is

   type Status is (Raw, Bound, Solved, Unknown)
      with Default_Value => Unknown;
   subtype Good_Status is Status range Raw .. Solved;
      
   Unused : constant := -16#6789#;
   type Small_Integer is range -16#8000#..16#7FFF#
      with Default_Value => Unused;
   subtype Small_Natural is Small_Integer range 0 .. Small_Integer'Last;
      
   type Word_16 is mod 2**16
      with Default_Value => 16#DEAD#;
   subtype Half_Word is Word_16 range 0 .. 16#0FFF#;

   Flt_Value : constant := -2.25;

   type Small_Float is digits 3
      with Default_Value => Flt_Value;
   subtype Float_Natural is Small_Float range 0.0 .. Small_Float'Last;
    
   Fix_Value : constant := 3.75;

   type Small_Fixed is delta 0.125 range -4.0 .. 4.0
      with Small => 0.125, Default_Value => Fix_Value;
   subtype Smaller_Fixed is Small_Fixed range -2.0 .. 2.0;
    

   subtype Cases is Character range 'A' .. 'F';
    
   procedure Get_Info (Usable    : out Boolean;
                       Kind      : out Good_Status;
                       Count     : out Small_Natural;
                       Flags     : out Half_Word;
                       Data      : out Float_Natural;
                       Magnitude : out Smaller_Fixed;
                       Test_Case : in Cases);
      -- Returns a different result for each test case.
      -- If Usable is False, none of the other values contains data.
      -- If Usable is True, then the Kind determines which other
      -- parameters contain data. If Kind = Raw, Flags only has data.
      -- If Kind = Bound, then the Count and Flags have data.
      -- If Kind = Solved, then all of the parameters have data.

end C641002_0;


package body C641002_0 is

   procedure Get_Info (Usable    : out Boolean;
                       Kind      : out Good_Status;
                       Count     : out Small_Natural;
                       Flags     : out Half_Word;
                       Data      : out Float_Natural;
                       Magnitude : out Smaller_Fixed;
                       Test_Case : in Cases) is
      -- Returns a different result for each test case. (See spec for
      -- details).
   begin
      -- Note: We cannot read any of the out parameters lest they be
      -- invalid for the declared subtype.
      case Test_Case is
         when 'A' =>
            Usable := True;
            Kind   := Raw;
            Flags  := 16#0010#;
         when 'B' =>
            Usable := True;
            Kind   := Solved;
            Count  := 12;
            Flags  := 16#0012#;
            Data   := 1.75;
            Magnitude := 0.625;
         when 'C' =>
            Usable := False;
         when 'D' =>
            Usable := True;
            Kind   := Bound;
            Flags  := 16#000C#;
            Count  := 4;
         when 'E' =>
            Usable := True;
            Kind   := Solved;
            Count  := 7;
            Flags  := 16#0028#;
            Data   := 1.25;
            Magnitude := -0.25;
         when 'F' =>
            Usable := True;
            Kind   := Bound;
            Flags  := 16#000A#;
            Count  := 3;
      end case;
   end Get_Info;
       
end C641002_0;


with Report;
with C641002_0; use C641002_0;
procedure C641002 is

begin

   Report.Test
     ("C641002",
      "Check that, for a parameter of a scalar type with a specified " &
      "Default_Value, the value of the actual parameter is passed in " &
      "without any constraint check");

   -- First, try initialized objects:
   declare
      Is_Usable     : Boolean := False;
      The_Kind      : Good_Status := Bound;
      The_Count     : Small_Integer := 0;
      The_Flags     : Half_Word := 0;
      The_Data      : Float_Natural := 0.0;
      The_Magnitude : Smaller_Fixed := 0.0;
   begin
      if Is_Usable then
          Report.Failed ("Bad initial value - A1");
      end if;         
      if The_Kind /= Bound then
          Report.Failed ("Bad initial value - A2");
      end if;         
      if The_Count /= 0 then
          Report.Failed ("Bad initial value - A3");
      end if;         
      if The_Flags /= 0 then
          Report.Failed ("Bad initial value - A4");
      end if;         
      if The_Data /= 0.0 then
          Report.Failed ("Bad initial value - A5");
      end if;         
      if The_Magnitude /= 0.0 then
          Report.Failed ("Bad initial value - A6");
      end if;         
      C641002_0.Get_Info (Is_Usable, The_Kind, The_Count, The_Flags, 
                          The_Data, The_Magnitude, Test_Case => 'A');
          -- Should not raise an exception even if buggy, all parameter values
          -- in range.
      if not Is_Usable then
          Report.Failed ("Bad result value - A1");
      end if;         
      if The_Kind /= Raw then
          Report.Failed ("Bad result value - A2");
      end if;         
      if The_Count /= 0 then
          Report.Failed ("Bad result value - A3");
      end if;         
      if The_Flags /= 16#0010# then
          Report.Failed ("Bad result value - A4");
      end if;         
      if The_Data /= 0.0 then
          Report.Failed ("Bad result value - A5");
      end if;         
      if The_Magnitude /= 0.0 then
          Report.Failed ("Bad result value - A6");
      end if;
   end;        

   -- Next, try default initialized objects with the results set:
   declare
      Is_Usable     : Boolean;
      The_Kind      : Status;
      The_Count     : Small_Integer;
      The_Flags     : Word_16;
      The_Data      : Small_Float;
      The_Magnitude : Small_Fixed;
   begin
      -- Is_Usable is not initialized at all, can't pre-test it.
      if The_Kind /= Unknown then
          Report.Failed ("Bad initial value - B2");
      end if;         
      if The_Count /= Unused then
          Report.Failed ("Bad initial value - B3");
      end if;         
      if The_Flags /= 16#DEAD# then
          Report.Failed ("Bad initial value - B4");
      end if;         
      if The_Data /= Flt_Value then
          Report.Failed ("Bad initial value - B5");
      end if;         
      if The_Magnitude /= Fix_Value then
          Report.Failed ("Bad initial value - B6");
      end if;         
      C641002_0.Get_Info (Is_Usable, The_Kind, The_Count, The_Flags, 
                          The_Data, The_Magnitude, Test_Case => 'B');
      if not Is_Usable then
          Report.Failed ("Bad result value - B1");
      end if;         
      if The_Kind /= Solved then
          Report.Failed ("Bad result value - B2");
      end if;         
      if The_Count /= 12 then
          Report.Failed ("Bad result value - B3");
      end if;         
      if The_Flags /= 16#0012# then
          Report.Failed ("Bad result value - B4");
      end if;         
      if The_Data /= 1.75 then
          Report.Failed ("Bad result value - B5");
      end if;         
      if The_Magnitude /= 0.625 then
          Report.Failed ("Bad result value - B6");
      end if;
   end;        

   -- Now, try default initialized objects with the results unchanged:
   -- Note: The defaults are outside of the parameter range, but no
   -- exception should be raised upon the call nor on the copy-back.
   declare
      Is_Usable     : Boolean;
      The_Kind      : Status;
      The_Count     : Small_Integer;
      The_Flags     : Word_16;
      The_Data      : Small_Float;
      The_Magnitude : Small_Fixed;
   begin
      -- Is_Usable is not initialized at all, can't pre-test it.
      if The_Kind /= Unknown then
          Report.Failed ("Bad initial value - C2");
      end if;         
      if The_Count /= Unused then
          Report.Failed ("Bad initial value - C3");
      end if;         
      if The_Flags /= 16#DEAD# then
          Report.Failed ("Bad initial value - C4");
      end if;         
      if The_Data /= Flt_Value then
          Report.Failed ("Bad initial value - C5");
      end if;         
      if The_Magnitude /= Fix_Value then
          Report.Failed ("Bad initial value - C6");
      end if;         
      C641002_0.Get_Info (Is_Usable, The_Kind, The_Count, The_Flags, 
                          The_Data, The_Magnitude, Test_Case => 'C');
      if Is_Usable then
          Report.Failed ("Bad result value - C1");
      end if;         
      if The_Kind /= Unknown then
          Report.Failed ("Bad result value - C2");
      end if;         
      if The_Count /= Unused then
          Report.Failed ("Bad result value - C3");
      end if;         
      if The_Flags /= 16#DEAD# then
          Report.Failed ("Bad result value - C4");
      end if;         
      if The_Data /= Flt_Value then
          Report.Failed ("Bad result value - C5");
      end if;         
      if The_Magnitude /= Fix_Value then
          Report.Failed ("Bad result value - C6");
      end if;
   end;        

   -- Now, try default initialized objects with some written and some
   -- unchanged by the call:
   -- Note: The defaults are outside of the parameter range, but no
   -- exception should be raised upon the call nor on the copy-back.
   declare
      Is_Usable     : Boolean;
      The_Kind      : Status;
      The_Count     : Small_Integer;
      The_Flags     : Word_16;
      The_Data      : Small_Float;
      The_Magnitude : Small_Fixed;
   begin
      -- Is_Usable is not initialized at all, can't pre-test it.
      if The_Kind /= Unknown then
          Report.Failed ("Bad initial value - D2");
      end if;         
      if The_Count /= Unused then
          Report.Failed ("Bad initial value - D3");
      end if;         
      if The_Flags /= 16#DEAD# then
          Report.Failed ("Bad initial value - D4");
      end if;         
      if The_Data /= Flt_Value then
          Report.Failed ("Bad initial value - D5");
      end if;         
      if The_Magnitude /= Fix_Value then
          Report.Failed ("Bad initial value - D6");
      end if;         
      C641002_0.Get_Info (Is_Usable, The_Kind, The_Count, The_Flags, 
                          The_Data, The_Magnitude, Test_Case => 'D');
      if not Is_Usable then
          Report.Failed ("Bad result value - D1");
      end if;         
      if The_Kind /= Bound then
          Report.Failed ("Bad result value - D2");
      end if;         
      if The_Count /= 4 then
          Report.Failed ("Bad result value - D3");
      end if;         
      if The_Flags /= 16#000C# then
          Report.Failed ("Bad result value - D4");
      end if;         
      if The_Data /= Flt_Value then
          Report.Failed ("Bad result value - D5");
      end if;         
      if The_Magnitude /= Fix_Value then
          Report.Failed ("Bad result value - D6");
      end if;
   end;        

   -- Now, try an object with a narrower range
   -- so that one of the results will not fit (an exception should
   -- be raised on the copy-back).
   declare
      subtype Small_Fixed_Natural is Small_Fixed range 0.0 .. Small_Fixed'Last;
      Is_Usable     : Boolean;
      The_Kind      : Status;
      The_Count     : Small_Integer;
      The_Flags     : Word_16;
      The_Data      : Small_Float;
      The_Magnitude : Small_Fixed_Natural;
   begin
      -- Is_Usable is not initialized at all, can't pre-test it.
      if The_Kind /= Unknown then
          Report.Failed ("Bad initial value - E2");
      end if;         
      if The_Count /= Unused then
          Report.Failed ("Bad initial value - E3");
      end if;         
      if The_Flags /= 16#DEAD# then
          Report.Failed ("Bad initial value - E4");
      end if;         
      if The_Data /= Flt_Value then
          Report.Failed ("Bad initial value - E5");
      end if;         
      if The_Magnitude /= Fix_Value then
          Report.Failed ("Bad initial value - E6");
      end if;         
      C641002_0.Get_Info (Is_Usable, The_Kind, The_Count, The_Flags, 
                          The_Data, The_Magnitude, Test_Case => 'E');
          -- The result for The_Magnitude is out of range, Constraint_Error
          -- should be raised.
      Report.Failed ("Copy-back out of fixed range did not raise " &
                     "Constraint_Error");   
   exception
      when Constraint_Error =>
          null; -- Expected, OK.
   end;
   
   declare
      subtype Small_Very_Positive is Small_Integer 
         range 10 .. Small_Integer'Last;
      Is_Usable     : Boolean;
      The_Kind      : Status;
      The_Count     : Small_Very_Positive := 92;
      The_Flags     : Word_16;
      The_Data      : Small_Float;
      The_Magnitude : Small_Fixed;
   begin
      -- Is_Usable is not initialized at all, can't pre-test it.
      if The_Kind /= Unknown then
          Report.Failed ("Bad initial value - F2");
      end if;         
      if The_Count /= 92 then
          Report.Failed ("Bad initial value - F3");
      end if;         
      if The_Flags /= 16#DEAD# then
          Report.Failed ("Bad initial value - F4");
      end if;         
      if The_Data /= Flt_Value then
          Report.Failed ("Bad initial value - F5");
      end if;         
      if The_Magnitude /= Fix_Value then
          Report.Failed ("Bad initial value - F6");
      end if;         
      C641002_0.Get_Info (Is_Usable, The_Kind, The_Count, The_Flags, 
                          The_Data, The_Magnitude, Test_Case => 'F');
          -- The result for The_Count is out of range, Constraint_Error
          -- should be raised.
      Report.Failed ("Copy-back out of integer range did not raise " &
                     "Constraint_Error");   
   exception
      when Constraint_Error =>
          null; -- Expected, OK.
   end;        

   Report.Result;

end C641002;