-- C641003.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 predicate 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 from C641002, donated to ACATS. -- 16 Dec 21 RLB Corrected comments to talk about predicates and -- Assertion_Error. -- --! package C641003_0 is pragma Assertion_Policy (Check); type Status is (Raw, Bound, Solved, Checked, Folded, Unknown) with Default_Value => Unknown; subtype Typical_Status is Status with Static_Predicate => Typical_Status in Raw | Solved | Folded; Unused : constant := -16#6789#; type Small_Integer is range -16#8000#..16#7FFF# with Default_Value => Unused; subtype Small_Even is Small_Integer with Dynamic_Predicate => Small_Even mod 2 = 0; type Word_16 is mod 2**16 with Default_Value => 16#DEAD#; subtype Valid_Flags is Word_16 with Dynamic_Predicate => (Valid_Flags and 16#FF40#) = 0; -- Only the bits not masked are used. Flt_Value : constant := -2.25; type Small_Float is digits 3 with Default_Value => Flt_Value; subtype Float_Natural is Small_Float with Static_Predicate => Float_Natural >= 0.0; 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 with Dynamic_Predicate => abs Smaller_Fixed <= 2.0; subtype Cases is Character range 'A' .. 'F'; procedure Get_Info (Usable : out Boolean; Kind : out Typical_Status; Count : out Small_Even; Flags : out Valid_Flags; 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 C641003_0; package body C641003_0 is pragma Assertion_Policy (Check); procedure Get_Info (Usable : out Boolean; Kind : out Typical_Status; Count : out Small_Even; Flags : out Valid_Flags; 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 := Folded; Flags := 16#000C#; Count := 4; when 'E' => Usable := True; Kind := Solved; Count := 16; Flags := 16#0028#; Data := 1.25; Magnitude := -0.25; when 'F' => Usable := True; Kind := Bound; Flags := 16#008A#; Count := 6; end case; end Get_Info; end C641003_0; with Report, Ada.Assertions; with C641003_0; use C641003_0; procedure C641003 is pragma Assertion_Policy (Check); begin Report.Test ("C641003", "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 predicate check"); -- First, try initialized objects: declare Is_Usable : Boolean := False; The_Kind : Typical_Status := Folded; The_Count : Small_Integer := 0; The_Flags : Valid_Flags := 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 /= Folded 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; C641003_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; C641003_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 do not satisfy the predicates of the parameters, -- 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; C641003_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 do not satisfy the predicates of the parameters, -- 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; C641003_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 /= Folded 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 more restrictive predicate -- 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 with Static_Predicate => Small_Fixed_Natural >= 0.0; 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; C641003_0.Get_Info (Is_Usable, The_Kind, The_Count, The_Flags, The_Data, The_Magnitude, Test_Case => 'E'); -- The result for The_Magnitude does not satisfy the predicate of -- the object, Assertion_Error should be raised. Report.Failed ("Copy-back out of fixed range did not raise " & "Assertion_Error"); exception when Ada.Assertions.Assertion_Error => null; -- Expected, OK. end; declare subtype Small_Very_Positive is Small_Integer with Static_Predicate => Small_Very_Positive > 10; 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; C641003_0.Get_Info (Is_Usable, The_Kind, The_Count, The_Flags, The_Data, The_Magnitude, Test_Case => 'F'); -- The result for The_Count does not satisfy the predicate of the -- object, Assertion_Error should be raised. Report.Failed ("Copy-back out of integer range did not raise " & "Assertion_Error"); exception when Ada.Assertions.Assertion_Error => null; -- Expected, OK. end; Report.Result; end C641003;