b460002.a
b460004.a
b460005.a
+b460006.a
b46002a.ada
b46003a.ada
b46004a.ada
b8510010.a
b8510011.a
b8510012.am
+b854001.a
b86001a0.ada
b86001a1.ada
b87b23b.ada
bd8004c.tst
bdb0a01.a
bdd2001.a
+bdd2002.a
bde0001.a
bde0002.a
bde0003.a
bde0006.a
bde0007.a
bde0008.a
+bde0009.a
+bde0010.a
be2101e.ada
be2101j.ada
be2114a.ada
c37404b.ada
c37405a.ada
c37411a.ada
+c380001.a
+c380002.a
+c380003.a
+c380004.a
c38002a.ada
c38002b.ada
c38005a.ada
c45532p.dep
c45534b.ada
c45536a.dep
+c456001.a
c45611a.ada
c45611b.dep
c45611c.dep
c45614a.ada
c45614b.dep
c45614c.dep
-c45622a.ada
-c45624a.ada
-c45624b.ada
c45631a.ada
c45631b.dep
c45631c.dep
c761007.a
c761010.a
c761011.a
+c761012.a
c83007a.ada
c83012d.ada
c83022a.ada
c85019a.ada
c854001.a
c854002.a
+c854003.a
c86003a.ada
c86004a.ada
c86004b0.ada
cc51004.a
cc51006.a
cc51007.a
+cc51008.a
cc51a01.a
cc51b03.a
cc51d01.a
cc70c01.a
cc70c02.a
cd10001.a
+cd10002.a
cd1009a.ada
cd1009b.ada
cd1009d.ada
cdb0a02.a
cdd1001.a
cdd2001.a
+cdd2a01.a
+cdd2a02.a
+cdd2a03.a
cde0001.a
ce2102a.ada
ce2102b.ada
fcndecl.ada
fd72a00.a
fdb0a00.a
+fdd2a00.a
fxa5a00.a
fxaca00.a
fxacb00.a
la5008f1.ada
la5008g0.ada
la5008g1.ada
+lc300010.a
+lc300011.a
+lc300012.am
+lc300020.a
+lc300021.a
+lc300022.am
+lc300030.a
+lc300031.a
+lc300032.am
lencheck.ada
lxd70010.a
lxd70011.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
+-- 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
+-- 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
+-- 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
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
Minimum_Task_Switch : constant Duration := 0.001;
-- ^^^ --- MODIFY HERE AS NEEDED
+ -- The above constant has been chosen for use with delay statements in the
+ -- GCC testsuite so that they do not take too long, but may be too small.
+
Long_Minimum_Task_Switch : constant Duration := 0.1;
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
Switch_To_New_Task : constant Duration := 0.001;
-- ^^^ -- MODIFY HERE AS NEEDED
+ -- The above constant has been chosen for use with delay statements in the
+ -- GCC testsuite so that they do not take too long, but may be too small.
+
Long_Switch_To_New_Task : constant Duration := 0.1;
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-- CD30005_1_Foreign_Address : constant System.Address:=
-- System.Storage_Elements.To_Address ( 16#0000_0000# )
- -- --MODIFY HERE AS REQUIRED --- ^^^^^^^^^^^^^
+ -- MODIFY HERE AS REQUIRED --- ^^^^^^^^^^^^^
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-- package Address_Value_IO is
-- new Ada.Text_IO.Integer_IO(System.Storage_Elements.Integer_Address);
- package Address_Value_IO is
- new Ada.Text_IO.Modular_IO(System.Storage_Elements.Integer_Address);
+ package Address_Value_IO is
+ new Ada.Text_IO.Modular_IO(System.Storage_Elements.Integer_Address);
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
+ -- The following constants have been defined for use with various delay
+ -- statements in the GCC testsuite so that they do not take too long.
+
One_Second : constant Duration := 0.001;
One_Long_Second : constant Duration := 0.1;
package body ImpDef.Annex_G is
+ -- NOTE: These are example bodies. It is expected that implementors
+ -- will write their own versions of these routines.
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
- -- This function must return a negative zero value for implementations
- -- for which Float'Signed_Zeros is True.
- -- We generate the smallest normalized negative number, and divide by a
- -- few powers of two to obtain a number whose absolute value equals zero
- -- but whose sign is negative.
+ -- This function must return a negative zero value for implementations
+ -- for which Float'Signed_Zeros is True.
+ --
+ -- The default body simply returns a negated literal 0.0. If the
+ -- default body does not return the value corresponding to a negatively
+ -- signed zero for the implementation under test, it must be replaced
+ -- by one which does. See RM A.5.3(13).
function Negative_Zero return Float is
- negz : float := -1.0 *
- float (float'Machine_Radix)
- ** ( Float'Machine_Emin - Float'Machine_Mantissa);
begin
- return negz / 8.0;
+ return -0.0; -- Note: If this value is not negative zero for the
+ -- implementation, use of this "default" value
+ -- could result in false failures in
+ -- implementations where Float'Signed_Zeros
+ -- is True.
+
+ -- ^^^^^^^^^^^^^^^^^^^^ MODIFY THIS BODY AS NEEDED ^^^^^^^^^^^^^^^^^^^^
+
end Negative_Zero;
--=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
end ImpDef.Annex_G;
-
-- IDENTIFIER SUCH AS NO_SUCH_TYPE_AVAILABLE.)
-- USED IN: C45231D CD7101G
NAME LONG_LONG_INTEGER
-
+
-- $OPTIONAL_DISC
-- A DISCRIMINANT USED AS THE DISCRIMINANT PART OF $RECORD_NAME.
-- IF MACHINE CODE INSERTIONS ARE NOT SUPPORTED THEN SUBSTITUTE
-- THE NUMBER OF STORAGE UNITS REQUIRED FOR A TASK ACTIVATION.
-- USED IN: BD2C01D BD2C02A BD2C03A C87B62D CD1009K CD1009T
-- CD1009U CD1C03E CD1C06A CD2C11A CC1225A CD2C11D
-TASK_STORAGE_SIZE 1024
+TASK_STORAGE_SIZE 32768
-- $VARIABLE_ADDRESS
-- AN EXPRESSION YIELDING A LEGAL ADDRESS FOR A VARIABLE FOR THIS
-- THE MACROS $VARIABLE_ADDRESS AND $VARIABLE_ADDRESS1.
-- USED IN: SPPRT13SP
VARIABLE_ADDRESS2 VAR_ADDR2
-
-- RLB 3/16/00 UPDATED ACATS VERSION STRING TO "2.3".
-- CHANGED VARIOUS STRINGS TO READ "ACATS".
-- RLB 3/22/01 UPDATED ACATS VERSION STRING TO "2.4".
--- RLB 3/29/01 UPDATED ACATS VERSION STRING TO "2.5".
+-- RLB 3/29/02 UPDATED ACATS VERSION STRING TO "2.5".
+-- RLB 3/06/07 UPDATED ACATS VERSION STRING TO "2.6".
WITH TEXT_IO, CALENDAR;
USE TEXT_IO, CALENDAR;
- ACATS_VERSION : CONSTANT STRING := "2.5";
+ ACATS_VERSION : CONSTANT STRING := "2.6";
-- VERSION OF ACATS BEING RUN (X.XX).
PROCEDURE PUT_MSG (MSG : STRING) IS
-- 16 MAR 00 RLB Changed foundation id to reflect test suite version.
-- 22 MAR 01 RLB Changed foundation id to reflect test suite version.
-- 29 MAR 02 RLB Changed foundation id to reflect test suite version.
+-- 06 MAR 07 RLB Changed foundation id to reflect test suite version.
--
--!
package TCTouch is
- Foundation_ID : constant String := "TCTouch ACATS 2.5";
+ Foundation_ID : constant String := "TCTouch ACATS 2.6";
Max_Touch_Count : constant := 80;
procedure Assert ( SB_True : Boolean; Message : String );
--- /dev/null
+--
+-- C352001.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 the predefined Character type comprises 256 positions.
+-- Check that the names of the non-graphic characters are usable with
+-- the attributes (Wide_)Image and (Wide_)Value, and that these
+-- attributes produce the correct result.
+--
+-- TEST DESCRIPTION:
+-- Build two tables of nongraphic characters from positions of Row 00
+-- (0000-001F and 007F-009F) of the ISO 10646 Basic Multilingual Plane.
+-- Fill the first table with compiler created strings. Fill the second
+-- table with strings defined by the language. Compare the two tables.
+-- Check 256 positions of the predefined character type. Use attributes
+-- (Wide_)Image and (Wide_)Value to check the values of the non-graphic
+-- characters and the last 2 characters.
+--
+--
+-- CHANGE HISTORY:
+-- 20 Jun 95 SAIC Initial prerelease version.
+-- 27 Jan 96 SAIC Revised for 2.1. Hid values, added "del" case.
+--
+--!
+
+with Ada.Characters.Handling;
+with Report;
+procedure C352001 is
+
+ Lower_Bound : Integer := 0;
+ Middle_Bound : Integer := 31;
+ Upper_Bound : Integer := 159;
+ Half_Bound : Integer := 127;
+ Max_Bound : Integer := 255;
+
+ type Dyn_String is access String;
+ type Value_Result is array (Character) of Dyn_String;
+
+ Table_Of_Character : Value_Result;
+ TC_Table : Value_Result;
+
+ function CVII(K : Natural) return Character is
+ begin
+ return Character'Val( Report.Ident_Int(K) );
+ end CVII;
+
+ function "=" (L, R : String) return Boolean is
+ UCL : String (L'First .. L'Last);
+ UCR : String (R'First .. R'last);
+ begin
+ UCL := Ada.Characters.Handling.To_Upper (L);
+ UCR := Ada.Characters.Handling.To_Upper (R);
+ if UCL'Last /= UCR'Last then
+ return False;
+ else
+ for I in UCL'First .. UCR'Last loop
+ if UCL (I) /= UCR (I) then
+ return False;
+ end if;
+ end loop;
+ return True;
+ end if;
+ end "=";
+
+begin
+
+ Report.Test ("C352001", "Check that, the predefined Character type " &
+ "comprises 256 positions. Check that the names of the " &
+ "non-graphic characters are usable with the attributes " &
+ "(Wide_)Image and (Wide_)Value, and that these attributes " &
+ "produce the correct result");
+
+ -- Fill table with strings (positions of Row 00 (0000-001F) of the ISO
+ -- 10646 Basic Multilingual Plane created by the compiler.
+
+ for I in CVII(Lower_Bound) .. CVII(Middle_Bound) loop
+ Table_Of_Character (I) := new String'(Character'Image(I));
+ end loop;
+
+ -- Fill table with strings (positions of Row 00 (007F-009F) of the ISO
+ -- 10646 Basic Multilingual Plane created by the compiler.
+
+ for I in CVII(Half_Bound) .. CVII(Upper_Bound) loop
+ Table_Of_Character (I) := new String'(Character'Image(I));
+ end loop;
+
+ -- Fill table with strings (positions of Row 00 (0000-001F) of the ISO
+ -- 10646 Basic Multilingual Plane defined by the language.
+
+ TC_Table (CVII(0)) := new String'("nul");
+ TC_Table (CVII(1)) := new String'("soh");
+ TC_Table (CVII(2)) := new String'("stx");
+ TC_Table (CVII(3)) := new String'("etx");
+ TC_Table (CVII(4)) := new String'("eot");
+ TC_Table (CVII(5)) := new String'("enq");
+ TC_Table (CVII(6)) := new String'("ack");
+ TC_Table (CVII(7)) := new String'("bel");
+ TC_Table (CVII(8)) := new String'("bs");
+ TC_Table (CVII(9)) := new String'("ht");
+ TC_Table (CVII(10)) := new String'("lf");
+ TC_Table (CVII(11)) := new String'("vt");
+ TC_Table (CVII(12)) := new String'("ff");
+ TC_Table (CVII(13)) := new String'("cr");
+ TC_Table (CVII(14)) := new String'("so");
+ TC_Table (CVII(15)) := new String'("si");
+ TC_Table (CVII(16)) := new String'("dle");
+ TC_Table (CVII(17)) := new String'("dc1");
+ TC_Table (CVII(18)) := new String'("dc2");
+ TC_Table (CVII(19)) := new String'("dc3");
+ TC_Table (CVII(20)) := new String'("dc4");
+ TC_Table (CVII(21)) := new String'("nak");
+ TC_Table (CVII(22)) := new String'("syn");
+ TC_Table (CVII(23)) := new String'("etb");
+ TC_Table (CVII(24)) := new String'("can");
+ TC_Table (CVII(25)) := new String'("em");
+ TC_Table (CVII(26)) := new String'("sub");
+ TC_Table (CVII(27)) := new String'("esc");
+ TC_Table (CVII(28)) := new String'("fs");
+ TC_Table (CVII(29)) := new String'("gs");
+ TC_Table (CVII(30)) := new String'("rs");
+ TC_Table (CVII(31)) := new String'("us");
+ TC_Table (CVII(127)) := new String'("del");
+
+ -- Fill table with strings (positions of Row 00 (007F-009F) of the ISO
+ -- 10646 Basic Multilingual Plane defined by the language.
+
+ TC_Table (CVII(128)) := new String'("reserved_128");
+ TC_Table (CVII(129)) := new String'("reserved_129");
+ TC_Table (CVII(130)) := new String'("bph");
+ TC_Table (CVII(131)) := new String'("nbh");
+ TC_Table (CVII(132)) := new String'("reserved_132");
+ TC_Table (CVII(133)) := new String'("nel");
+ TC_Table (CVII(134)) := new String'("ssa");
+ TC_Table (CVII(135)) := new String'("esa");
+ TC_Table (CVII(136)) := new String'("hts");
+ TC_Table (CVII(137)) := new String'("htj");
+ TC_Table (CVII(138)) := new String'("vts");
+ TC_Table (CVII(139)) := new String'("pld");
+ TC_Table (CVII(140)) := new String'("plu");
+ TC_Table (CVII(141)) := new String'("ri");
+ TC_Table (CVII(142)) := new String'("ss2");
+ TC_Table (CVII(143)) := new String'("ss3");
+ TC_Table (CVII(144)) := new String'("dcs");
+ TC_Table (CVII(145)) := new String'("pu1");
+ TC_Table (CVII(146)) := new String'("pu2");
+ TC_Table (CVII(147)) := new String'("sts");
+ TC_Table (CVII(148)) := new String'("cch");
+ TC_Table (CVII(149)) := new String'("mw");
+ TC_Table (CVII(150)) := new String'("spa");
+ TC_Table (CVII(151)) := new String'("epa");
+ TC_Table (CVII(152)) := new String'("sos");
+ TC_Table (CVII(153)) := new String'("reserved_153");
+ TC_Table (CVII(154)) := new String'("sci");
+ TC_Table (CVII(155)) := new String'("csi");
+ TC_Table (CVII(156)) := new String'("st");
+ TC_Table (CVII(157)) := new String'("osc");
+ TC_Table (CVII(158)) := new String'("pm");
+ TC_Table (CVII(159)) := new String'("apc");
+
+
+ -- Compare the first half of two tables.
+ for I in CVII(Lower_Bound) .. CVII(Middle_Bound) loop
+ if TC_Table(I).all /= Table_Of_Character(I).all then
+ Report.Failed("Value of character#" & Integer'Image(Character'Pos(I)) &
+ " is not the same in the first half of the table");
+ end if;
+ end loop;
+
+
+ -- Compare the second half of two tables.
+ for I in CVII(Half_Bound) .. CVII(Upper_Bound) loop
+ if TC_Table(I).all /= Table_Of_Character(I).all then
+ Report.Failed("Value of character#" & Integer'Image(Character'Pos(I)) &
+ " is not the same in the second half of the table");
+ end if;
+ end loop;
+
+
+ -- Check the first character.
+ if Character'Image( Character'First ) /= "NUL" then
+ Report.Failed("Value of character#" &
+ Integer'Image(Character'Pos (Character'First)) &
+ " is not NUL");
+ end if;
+
+
+ -- Check that the names of the non-graphic characters are usable with
+ -- Image and Value attributes.
+ if Character'Value( Character'Image( CVII(153) )) /=
+ CVII( 153 ) then
+ Report.Failed ("Value of character#" &
+ Integer'Image( Character'Pos(CVII(153)) ) &
+ " is not reserved_153");
+ end if;
+
+
+ for I in CVII(Lower_Bound) .. CVII(Max_Bound) loop
+ if Character'Value(
+ Report.Ident_Str(
+ Character'Image(CVII(Character'Pos(I)))))
+ /= CVII( Character'Pos(I)) then
+ Report.Failed ("Value of character#" &
+ Integer'Image( Character'Pos(I) ) &
+ " is not the same as the predefined character type");
+ end if;
+ end loop;
+
+
+ -- Check Wide_Character attributes.
+ for I in Wide_Character'Val(Lower_Bound) .. Wide_Character'Val(Max_Bound)
+ loop
+ if Wide_Character'Wide_Value(
+ Report.Ident_Wide_Str(
+ Wide_Character'Wide_Image(
+ Wide_Character'Val(Wide_Character'Pos(I)))))
+ /= Wide_Character'Val(Wide_Character'Pos(I))
+ then
+ Report.Failed ("Value of the predefined Wide_Character type " &
+ "is not correct");
+ end if;
+ end loop;
+
+
+ if Wide_Character'Value( Wide_Character'Image(Wide_Character'Val(132)) )
+ /= Wide_Character'Val( Report.Ident_Int(132) ) then
+ Report.Failed ("Wide_Character at 132 is not reserved_132");
+ end if;
+
+
+ if Wide_Character'Image( Wide_Character'First ) /= "NUL" then
+ Report.Failed ("Wide_Character'First is not NUL");
+ end if;
+
+
+ if Wide_Character'Image
+ (Wide_Character'Pred (Wide_Character'Last) ) /= "FFFE" then
+ Report.Failed ("Wide_Character at 65534 is not FFFE");
+ end if;
+
+
+ if Wide_Character'Image(Wide_Character'Last) /= "FFFF" then
+ Report.Failed ("Wide_Character'Last is not FFFF");
+ end if;
+
+ Report.Result;
+
+end C352001;
--
-- HISTORY:
-- 16 DEC 1999 RLB Initial Version.
+-- 20 JAN 2009 RLB Corrected error messages.
with Report;
procedure C433001 is
Report.Failed ("First Component incorrect (" & Test_Case & ")");
end if;
if Obj(Low+1) /= Second_Component then
- Report.Failed ("First Component incorrect (" & Test_Case & ")");
+ Report.Failed ("Second Component incorrect (" & Test_Case & ")");
end if;
if Obj(High) /= Last_Component then
- Report.Failed ("First Component incorrect (" & Test_Case & ")");
+ Report.Failed ("Last Component incorrect (" & Test_Case & ")");
end if;
end Check_1;
Report.Failed ("First Component incorrect (" & Test_Case & ")");
end if;
if Obj(Color_Type'Succ(Low)) /= Second_Component then
- Report.Failed ("First Component incorrect (" & Test_Case & ")");
+ Report.Failed ("Second Component incorrect (" & Test_Case & ")");
end if;
if Obj(High) /= Last_Component then
- Report.Failed ("First Component incorrect (" & Test_Case & ")");
+ Report.Failed ("Last Component incorrect (" & Test_Case & ")");
end if;
end Check_2;
--- /dev/null
+-- C453001.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 overflow checking is not performed for adding operators of
+-- modular types.
+--
+-- TEST DESCRIPTION:
+-- Check that Constraint_Error is not raised by + or - when the result
+-- is out of the range of the base type.
+-- Also check that assignment to values in the upper half of the range
+-- does not raise Constraint_Error.
+--
+-- We define modular types of various common sizes. We cannot
+-- assume a binary modulus greater than 2**16 is supported by 3.5.4(23),
+-- so the DWord type might be smaller on some targets. We also try
+-- a small prime number as a modulus (these are often used for hashing).
+-- We also the language-defined types
+-- System.Storage_Elements.Storage_Element, Ada.Streams.Stream_Element,
+-- and Ada.Containers.Hash_Type.
+--
+-- CHANGE HISTORY:
+-- 11 Feb 17 JAC Initial pre-release version.
+-- 30 Mar 17 RLB Renamed, removed non-modular test cases, removed
+-- types that aren't required to be supported, added
+-- other language-defined types, added key to locate
+-- failures, added additional test cases.
+-- 03 Apr 17 RLB Removed Ada.Containers from the Ada 95 version of
+-- this test.
+--
+--!
+with Report;
+with System.Storage_Elements;
+with Ada.Streams;
+
+procedure C453001 is
+ type Unsigned_Byte_Type is mod 16#100#; -- 256;
+
+ type Unsigned_Word_Type is mod 16#1_0000#; -- 65536;
+
+ type Unsigned_DWord_Type is mod
+ Natural'Min (2**32, System.Max_Binary_Modulus);
+
+ type Unsigned_NBM_Type is mod System.Max_Nonbinary_Modulus;
+
+ type Biggest_Unsigned_Type is mod System.Max_Binary_Modulus;
+
+ type Prime_Type is mod 23; -- Prime number for hashing.
+
+ generic
+ type Mod_Type is mod <>; -- Assume this is a base type.
+ Key : in String;
+ procedure Test_Operators;
+
+ procedure Test_Operators is
+
+ function Ident_Mod (Val : in Mod_Type) return Mod_Type is
+ -- Optimization breaker.
+ begin
+ if Report.Equal (4, 12) then -- Always False (but complex).
+ return 1;
+ else
+ return Val;
+ end if;
+ end Ident_Mod;
+
+ begin
+ if Mod_Type'First /= 0 then -- The First of a base type is always 0.
+ Report.Failed ("Not base type first - " & Key);
+ end if;
+ if Mod_Type'Last /= Mod_Type'Base'Last then
+ Report.Failed ("Not base type last - " & Key);
+ end if;
+
+ -- Note: Mod_Type'First always is 0.
+
+ -- Check addition
+ declare
+ M : constant Mod_Type := Mod_Type'Last;
+ V : Mod_Type;
+ begin
+ V := M + 1; -- Should wrap around
+ if Ident_Mod (V) /= 0 then
+ Report.Failed ("Addition didn't wrap round - " & Key);
+ end if;
+ V := Ident_Mod (M - 2) + 5; -- Should wrap around
+ if Ident_Mod (V) /= 2 then
+ Report.Failed ("Addition didn't wrap round again - " & Key);
+ end if;
+ exception
+ when Constraint_Error =>
+ Report.Failed ("Constraint_Error raised for addition - " & Key);
+ when others =>
+ Report.Failed
+ ("Some even more unexpected exception raised for addition - " &
+ Key);
+ end;
+
+ -- Check subtraction
+ declare
+ M : constant Mod_Type := 0;
+ V : Mod_Type;
+ begin
+ V := M - 1; -- Should wrap around
+ if Ident_Mod (V) /= Mod_Type'Last then
+ Report.Failed ("Subtraction didn't wrap round - " & Key);
+ end if;
+ V := Ident_Mod (3) - 7; -- Should wrap around
+ if Ident_Mod (V) /= Mod_Type'Last-3 then
+ Report.Failed ("Subtraction didn't wrap round again - " & Key);
+ end if;
+ exception
+ when Constraint_Error =>
+ Report.Failed ("Constraint_Error raised for subtraction - " & Key);
+ when others =>
+ Report.Failed
+ ("Some even more unexpected exception raised for subtraction - " &
+ Key);
+ end;
+
+ end Test_Operators;
+
+ procedure Test_Unsigned_Byte_Operators is new Test_Operators
+ (Unsigned_Byte_Type, "Byte");
+
+ procedure Test_Unsigned_Word_Operators is new Test_Operators
+ (Unsigned_Word_Type, "Word");
+
+ procedure Test_Unsigned_DWord_Operators is new Test_Operators
+ (Unsigned_DWord_Type, "DWord");
+
+ procedure Test_Unsigned_NBM_Operators is new Test_Operators
+ (Unsigned_NBM_Type, "NBM");
+
+ procedure Test_Biggest_Unsigned_Operators is new Test_Operators
+ (Biggest_Unsigned_Type, "Big");
+
+ procedure Test_Prime_Operators is new Test_Operators (Prime_Type, "Prime");
+
+ procedure Test_Storage_Element_Operators is new Test_Operators
+ (System.Storage_Elements.Storage_Element, "Storage");
+
+ procedure Test_Stream_Element_Operators is new Test_Operators
+ (Ada.Streams.Stream_Element, "Stream");
+
+begin
+
+ Report.Test
+ ("C453001",
+ "Check that overflow checking is not performed for adding operators " &
+ "of modular types");
+
+ -- Check assignment
+ declare
+ -- Define subtypes
+ subtype My_Unsigned_Byte_Type is Unsigned_Byte_Type;
+ subtype My_Unsigned_Word_Type is Unsigned_Word_Type;
+ subtype My_Unsigned_DWord_Type is Unsigned_DWord_Type;
+
+ -- Define constants in upper half of range
+ C1 : constant Unsigned_Byte_Type := Unsigned_Byte_Type'Last;
+ C2 : constant My_Unsigned_Byte_Type := 16#FE#;
+ C3 : constant Unsigned_Word_Type := 16#FACE#;
+ C4 : constant My_Unsigned_Word_Type := My_Unsigned_Word_Type'Last;
+ C5 : constant Unsigned_DWord_Type := My_Unsigned_DWord_Type'Last;
+
+ -- Define variables
+ V1 : Unsigned_Byte_Type;
+ V2 : My_Unsigned_Byte_Type;
+ V3 : Unsigned_Word_Type;
+ V4 : My_Unsigned_Word_Type;
+ V5 : Unsigned_DWord_Type;
+ begin
+ V1 := C1;
+ V1 := C2;
+ V2 := C1;
+ V2 := C2;
+ V3 := C3;
+ V3 := C4;
+ V4 := C3;
+ V4 := C4;
+ V5 := C5;
+ if V1 /= C2 or V2 /= C2 or V3 /= C4 or V4 /= C4 or V5 /= C5 then
+ Report.Comment ("Don't optimize assignment!"); -- Optimization breaker
+ end if;
+ exception
+ when Constraint_Error =>
+ Report.Failed ("Constraint_Error raised for assignment");
+ when others =>
+ Report.Failed ("Some even more unexpected exception raised " &
+ "for assignment");
+ end;
+
+ Test_Unsigned_Byte_Operators;
+ Test_Unsigned_Word_Operators;
+ Test_Unsigned_DWord_Operators;
+ Test_Unsigned_NBM_Operators;
+ Test_Biggest_Unsigned_Operators;
+ Test_Prime_Operators;
+ Test_Storage_Element_Operators;
+ Test_Stream_Element_Operators;
+
+ Report.Result;
+
+end C453001;
+
+++ /dev/null
--- C45622A.ADA
-
--- 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:
--- FOR EXPONENTIATION OF FLOATING POINT TYPES, CHECK THAT
--- CONSTRAINT_ERROR IS RAISED IF
--- MACHINE_OVERFLOWS IS TRUE AND THE RESULT IS OUTSIDE THE RANGE OF
--- THE BASE TYPE. THIS TESTS DIGITS 5.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
--- *** -- 9X
-
--- HISTORY:
--- BCB 02/09/88 CREATED ORIGINAL TEST.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45622A IS
-
- TYPE FLT IS DIGITS 5;
-
- F : FLT;
-
- FUNCTION EQUAL_FLT (ONE, TWO : FLT) RETURN BOOLEAN IS
- BEGIN
- RETURN ONE = TWO * FLT (IDENT_INT(1));
- END EQUAL_FLT;
-
-BEGIN
- TEST ("C45622A", "FOR EXPONENTIATION OF FLOATING POINT TYPES, " &
- "CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED IF MACHINE_OVERFLOWS IS TRUE AND " &
- "THE RESULT IS OUTSIDE THE RANGE OF THE BASE " &
- "TYPE. THIS TESTS DIGITS 5");
-
- IF FLT'MACHINE_OVERFLOWS THEN
- BEGIN
- F := (FLT'BASE'LAST)**IDENT_INT (2);
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED FOR " &
- "EXPONENTIATION");
-
- IF NOT EQUAL_FLT(F,F) THEN
- COMMENT ("DON'T OPTIMIZE F");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR WAS RAISED FOR " &
- "EXPONENTIATION");
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED FOR EXPONENTIATION");
- END;
- ELSE
- NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " &
- "MACHINE_OVERFLOWS BEING FALSE");
- END IF;
-
- RESULT;
-END C45622A;
+++ /dev/null
--- C45624A.ADA
-
--- 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:
--- FOR FLOATING POINT TYPES, CHECK THAT CONSTRAINT_ERROR
--- IS RAISED IF THE RESULT OF A FLOATING POINT
--- EXPONENTIATION IS OUTSIDE THE RANGE OF THE BASE TYPE AND
--- MACHINE_OVERFLOWS IS FALSE. THIS TESTS DIGITS 5.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
--- *** -- 9X
-
--- HISTORY:
--- BCB 02/09/88 CREATED ORIGINAL TEST.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45624A IS
-
- TYPE FLT IS DIGITS 5;
-
- F : FLT;
-
- FUNCTION EQUAL_FLT (ONE, TWO : FLT) RETURN BOOLEAN IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN ONE = TWO;
- ELSE
- RETURN ONE /= TWO;
- END IF;
- END EQUAL_FLT;
-
-BEGIN
- TEST ("C45624A", "FOR FLOATING POINT TYPES, CHECK THAT " &
- "CONSTRAINT_ERROR IS RAISED " &
- "IF MACHINE_OVERFLOWS IS FALSE. THIS TESTS " &
- "DIGITS 5");
-
- IF FLT'MACHINE_OVERFLOWS THEN
- NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " &
- "MACHINE_OVERFLOWS BEING TRUE");
- ELSE
- BEGIN
- F := FLT'BASE'FIRST**IDENT_INT (2);
- COMMENT ("CONSTRAINT_ERROR WAS NOT RAISED WHEN " &
- "MACHINE_OVERFLOWS WAS FALSE");
-
- IF EQUAL_FLT(F,F**IDENT_INT(1)) THEN
- COMMENT ("DON'T OPTIMIZE F");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR WAS RAISED WHEN " &
- "MACHINE_OVERFLOWS WAS FALSE");
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED");
- END;
- END IF;
-
- RESULT;
-END C45624A;
+++ /dev/null
--- C45624B.ADA
-
--- 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:
--- FOR FLOATING POINT TYPES, CHECK THAT
--- CONSTRAINT_ERROR IS RAISED IF THE RESULT OF A FLOATING POINT
--- EXPONENTIATION IS OUTSIDE THE RANGE OF THE BASE TYPE AND
--- MACHINE_OVERFLOWS IS FALSE. THIS TESTS DIGITS 6.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
--- *** -- 9X
-
--- HISTORY:
--- BCB 07/14/88 CREATED ORIGINAL TEST.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45624B IS
-
- TYPE FLT IS DIGITS 6;
-
- F : FLT;
-
- FUNCTION EQUAL_FLT (ONE, TWO : FLT) RETURN BOOLEAN IS
- BEGIN
- RETURN ONE = TWO * FLT (IDENT_INT(1));
- END EQUAL_FLT;
-
-BEGIN
- TEST ("C45624B", "FOR FLOATING POINT TYPES, CHECK THAT " &
- "CONSTRAINT_ERROR IS RAISED " &
- "IF MACHINE_OVERFLOWS IS FALSE. THIS TESTS " &
- "DIGITS 6");
-
- IF FLT'MACHINE_OVERFLOWS THEN
- NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " &
- "MACHINE_OVERFLOWS BEING TRUE");
- ELSE
- BEGIN
- F := FLT'BASE'LAST**IDENT_INT (2);
- COMMENT ("CONSTRAINT_ERROR WAS NOT RAISED WHEN " &
- "MACHINE_OVERFLOWS WAS FALSE");
- IF NOT EQUAL_FLT(F,F**IDENT_INT(1)) THEN
- COMMENT ("DON'T OPTIMIZE F");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR WAS RAISED WHEN " &
- "MACHINE_OVERFLOWS WAS FALSE");
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED");
- END;
- END IF;
-
- RESULT;
-END C45624B;
--- /dev/null
+-- C460013.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 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 if the target subtype excludes null, the value is not
+-- null. Check access parameters, which null-excluding if:
+-- (1) not null is given in their definition;
+-- (2) the access parameter is controlling;
+-- (3) an Ada 95 compiler is in use.
+--
+-- Note that the not null syntax is required even for Ada 95 compilers
+-- (see AI95-00447).
+--
+-- CHANGE HISTORY:
+-- 18 DEC 2006 RLB Initial version.
+-- 05 JAN 2007 RLB Corrected syntax error.
+--
+--!
+with Ada.Exceptions;
+use Ada.Exceptions;
+with Report;
+use Report;
+procedure C460013 is
+
+
+ package Nest1 is
+ type Doggie is tagged record
+ Cnt : Natural;
+ end record;
+ type Doggie_Access is access all Doggie;
+
+ procedure Controlled (P : access Doggie); -- Always null-excluding.
+ end Nest1;
+
+ package Nest2 is
+ type Kitty is record
+ Cnt : Natural;
+ end record;
+ type Kitty_Access is access all Kitty;
+
+ procedure Include (P : access Kitty); -- Null-excluding only in Ada 95.
+ procedure Exclude (P : not null access Kitty); -- Always null-excluding.
+ end Nest2;
+
+
+ package body Nest1 is
+ procedure Controlled (P : access Doggie) is
+ begin
+ if P.Cnt /= Ident_Int(4) then
+ Failed ("Bad value in null-excluding controlling parameter");
+ -- else OK
+ end if;
+ exception
+ when Constraint_Error => -- Dereference of null
+ Failed ("Null allowed in null-excluding controlling parameter");
+ end Controlled;
+ end Nest1;
+
+ package body Nest2 is
+ procedure Include (P : access Kitty) is
+ begin
+ if P.Cnt /= Ident_Int(31) then
+ Failed ("Bad value in access parameter");
+ -- else OK
+ end if;
+ exception
+ when Constraint_Error => -- Dereference of null
+ null;
+ --Comment ("Null allowed in access parameter - Ada 2005 semantics");
+ end Include;
+
+ procedure Exclude (P : not null access Kitty) is
+ begin
+ if P.Cnt /= Ident_Int(80) then
+ Failed ("Bad value in explicit null-excluding parameter");
+ -- else OK
+ end if;
+ exception
+ when Constraint_Error => -- Dereference of null
+ Failed ("Null allowed in explicit null-excluding parameter");
+ end Exclude;
+ end Nest2;
+
+ Shep : aliased Nest1.Doggie := (Cnt => 4);
+ Frisky : aliased Nest2.Kitty := (Cnt => 80);
+ Snuggles : aliased Nest2.Kitty := (Cnt => 31);
+
+begin
+ Test ("C460013",
+ "Check that if the target subtype excludes null, the value is not" &
+ " null - access parameter cases");
+
+ declare
+ Ptr : Nest1.Doggie_Access := Shep'Access;
+ begin
+ begin
+ Nest1.Controlled (Ptr); -- OK.
+ exception
+ when A: others =>
+ Failed ("Unexpected exception " & Exception_Name (A) &
+ " raised (1A) - " & Exception_Message (A));
+ end;
+ Ptr := null;
+ begin
+ Nest1.Controlled (Ptr);
+ Failed ("Null allowed for null-excluding controlling access parameter (1)");
+ exception
+ when Constraint_Error =>
+ null;
+ when B: others =>
+ Failed ("Unexpected exception " & Exception_Name (B) &
+ " raised (1B) - " & Exception_Message (B));
+ end;
+ end;
+
+ declare
+ Ptr : Nest2.Kitty_Access := Frisky'Access;
+ begin
+ begin
+ Nest2.Exclude (Ptr); -- OK.
+ exception
+ when C: others =>
+ Failed ("Unexpected exception " & Exception_Name (C) &
+ " raised (2A) - " & Exception_Message (C));
+ end;
+ Ptr := null;
+ begin
+ Nest2.Exclude (Ptr);
+ Failed ("Null allowed for null-excluding access parameter (2)");
+ exception
+ when Constraint_Error =>
+ null;
+ when D: others =>
+ Failed ("Unexpected exception " & Exception_Name (D) &
+ " raised (2B) - " & Exception_Message (D));
+ end;
+ end;
+
+ declare
+ Ptr : Nest2.Kitty_Access := Snuggles'Access;
+ begin
+ begin
+ Nest2.Include (Ptr); -- OK.
+ exception
+ when E: others =>
+ Failed ("Unexpected exception " & Exception_Name (E) &
+ " raised (3A) - " & Exception_Message (E));
+ end;
+ Ptr := null;
+ begin
+ Nest2.Include (Ptr);
+ Comment ("Null allowed for normal access parameter - " &
+ "Ada 2005 semantics");
+ exception
+ when Constraint_Error =>
+ Comment ("Null not allowed for normal access parameter - " &
+ "Ada 95 semantics");
+ when F: others =>
+ Failed ("Unexpected exception " & Exception_Name (F) &
+ " raised (3B) - " & Exception_Message (F));
+ end;
+ end;
+
+ Result;
+end C460013;
+
--- /dev/null
+-- C460014.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 if the operand type of a type conversion is
+-- access-to-class-wide, Constraint_Error is raised if the tag of the
+-- object designated by the operand does not identify a specific type
+-- that is covered by or descended from the target type.
+--
+-- TEST DESCRIPTION:
+-- Attempt to convert a parameter of a type that designates a class-wide
+-- type to an object of a type that designates a specific member of that
+-- class, for both an actual with a different tag and an actual with a
+-- matching tag.
+--
+-- This test checks 4.6(42) as required by 4.6(50).
+--
+-- CHANGE HISTORY:
+-- 19 Aug 16 JAC Initial pre-release version.
+-- 19 Jan 17 RLB Readied for release: replaced objective, renamed
+-- to appropriate number, added class-wide cases,
+-- eliminated 11.6 problems, added third level of
+-- types, and checks on null.
+--
+--!
+package C460014_1 is
+ type Root_Facade_Type is tagged record
+ Error_Code : Integer;
+ end record;
+
+ type Root_Facade_Ptr_Type is access all Root_Facade_Type;
+
+ type Facade_Class_Ptr_Type is access all Root_Facade_Type'Class;
+
+ type Data_A_Type is
+ record
+ A : Boolean;
+ end record;
+
+ type Facade_A_Type is new Root_Facade_Type with
+ record
+ Data_A : Data_A_Type;
+ end record;
+
+ type Facade_A_Ptr_Type is access all Facade_A_Type;
+
+ type Facade_A_Class_Ptr_Type is access all Facade_A_Type'Class;
+
+ type Facade_B_Type is new Facade_A_Type with
+ record
+ B : Character;
+ end record;
+
+ type Facade_B_Ptr_Type is access all Facade_B_Type;
+
+ type Facade_B_Class_Ptr_Type is access all Facade_B_Type'Class;
+
+ procedure Define_Construct
+ (Facade_Class_Ptr : in Facade_Class_Ptr_Type);
+
+ procedure Define_Class_Construct
+ (Facade_Class_Ptr : in Facade_Class_Ptr_Type);
+
+ function Init_Root_Facade_Ptr return Root_Facade_Ptr_Type;
+
+ function Init_Facade_A_Ptr return Facade_A_Ptr_Type;
+
+ function Init_Facade_B_Ptr return Facade_B_Ptr_Type;
+
+ function Init_Facade_Class_Ptr_with_Root return Facade_Class_Ptr_Type;
+
+ function Init_Facade_Class_Ptr_with_A return Facade_Class_Ptr_Type;
+
+ function Init_Facade_Class_Ptr_with_B return Facade_Class_Ptr_Type;
+
+end C460014_1;
+
+with Report;
+package body C460014_1 is
+
+ procedure Define_Construct
+ (Facade_Class_Ptr : in Facade_Class_Ptr_Type) is
+
+ Facade_A_Ptr : constant Facade_A_Ptr_Type :=
+ Facade_A_Ptr_Type (Facade_Class_Ptr);
+
+ My_A : Data_A_Type renames Facade_A_Ptr.Data_A;
+ begin
+ if not My_A.A then
+ Report.Comment ("Wrong value"); -- So My_A is not dead by 11.6(5).
+ end if;
+ end Define_Construct;
+
+ procedure Define_Class_Construct
+ (Facade_Class_Ptr : in Facade_Class_Ptr_Type) is
+
+ Facade_Class_A_Ptr : constant Facade_A_Class_Ptr_Type :=
+ Facade_A_Class_Ptr_Type (Facade_Class_Ptr);
+
+ begin
+ if Facade_Class_A_Ptr /= null and then
+ (not Facade_Class_A_Ptr.Data_A.A) then
+ Report.Comment ("Wrong value"); -- So the ptr is not dead by 11.6(5).
+ end if;
+ end Define_Class_Construct;
+
+ Dummy_Root_Facade : aliased Root_Facade_Type := (Error_Code => 123);
+
+ function Init_Root_Facade_Ptr return Root_Facade_Ptr_Type is
+ begin
+ return Dummy_Root_Facade'Access;
+ end Init_Root_Facade_Ptr;
+
+ Dummy_Facade_A : aliased Facade_A_Type := (Error_Code => 123,
+ Data_A => (A => True));
+
+ function Init_Facade_A_Ptr return Facade_A_Ptr_Type is
+ begin
+ return Dummy_Facade_A'Access;
+ end Init_Facade_A_Ptr;
+
+ Dummy_Facade_B : aliased Facade_B_Type := (Error_Code => 234,
+ Data_A => (A => True),
+ B => 'P');
+
+ function Init_Facade_B_Ptr return Facade_B_Ptr_Type is
+ begin
+ return Dummy_Facade_B'Access;
+ end Init_Facade_B_Ptr;
+
+ function Init_Facade_Class_Ptr_with_Root return Facade_Class_Ptr_Type is
+ begin
+ return Dummy_Root_Facade'Access;
+ end Init_Facade_Class_Ptr_with_Root;
+
+ function Init_Facade_Class_Ptr_with_A return Facade_Class_Ptr_Type is
+ begin
+ return Dummy_Facade_A'Access;
+ end Init_Facade_Class_Ptr_with_A;
+
+ function Init_Facade_Class_Ptr_with_B return Facade_Class_Ptr_Type is
+ begin
+ return Dummy_Facade_B'Access;
+ end Init_Facade_Class_Ptr_with_B;
+
+end C460014_1;
+
+
+with C460014_1;
+with Report;
+
+procedure C460014 is
+
+ My_Root_Facade_Ptr : constant C460014_1.Facade_Class_Ptr_Type :=
+ C460014_1.Init_Facade_Class_Ptr_with_Root;
+
+ My_Facade_A_Ptr : constant C460014_1.Facade_Class_Ptr_Type :=
+ C460014_1.Init_Facade_Class_Ptr_with_A;
+
+ My_Facade_B_Ptr : constant C460014_1.Facade_Class_Ptr_Type :=
+ C460014_1.Init_Facade_Class_Ptr_with_B;
+
+ My_Null_Facade_B_Ptr : constant C460014_1.Facade_B_Ptr_Type := null;
+
+ Constraint_Error_Raised : Boolean;
+
+ procedure Test_Define_Construct
+ (Facade_Class_Ptr : in C460014_1.Facade_Class_Ptr_Type) is
+ begin
+ Constraint_Error_Raised := False;
+ -- Should fail Tag_Check and therefore raise Constraint_Error if
+ -- parameter doesn't designate an object of Facade_A_Type
+ -- or Facade_B_Type.
+ C460014_1.Define_Construct (Facade_Class_Ptr => Facade_Class_Ptr);
+ exception
+ when Constraint_Error =>
+ Constraint_Error_Raised := True;
+ end Test_Define_Construct;
+
+
+ procedure Test_Define_Class_Construct
+ (Facade_Class_Ptr : in C460014_1.Facade_Class_Ptr_Type) is
+ begin
+ Constraint_Error_Raised := False;
+ -- Should fail Tag_Check and therefore raise Constraint_Error if
+ -- parameter doesn't designate an object of Facade_A_Type
+ -- or Facade_B_Type.
+ C460014_1.Define_Class_Construct (Facade_Class_Ptr => Facade_Class_Ptr);
+ exception
+ when Constraint_Error =>
+ Constraint_Error_Raised := True;
+ end Test_Define_Class_Construct;
+
+begin
+
+ Report.Test
+ ("C460014",
+ "Check that if the operand type of a type conversion is " &
+ "access-to-class-wide, Constraint_Error is raised if the tag of the " &
+ "object designated by the operand does not identify a specific type " &
+ "that is covered by or descended from the target type");
+
+ Test_Define_Construct (Facade_Class_Ptr => My_Root_Facade_Ptr);
+
+ if not Constraint_Error_Raised then
+ Report.Failed ("Didn't get expected Constraint_Error (1)");
+ end if;
+
+ Test_Define_Construct
+ (Facade_Class_Ptr => My_Facade_A_Ptr);
+
+ if Constraint_Error_Raised then
+ Report.Failed ("Unexpected Constraint_Error (2)");
+ end if;
+
+ Test_Define_Construct
+ (Facade_Class_Ptr => My_Facade_B_Ptr);
+
+ if Constraint_Error_Raised then
+ Report.Failed ("Unexpected Constraint_Error (3)");
+ end if;
+
+ Test_Define_Class_Construct (Facade_Class_Ptr => My_Root_Facade_Ptr);
+
+ if not Constraint_Error_Raised then
+ Report.Failed ("Didn't get expected Constraint_Error (4)");
+ end if;
+
+ Test_Define_Class_Construct
+ (Facade_Class_Ptr => My_Facade_A_Ptr);
+
+ if Constraint_Error_Raised then
+ Report.Failed ("Unexpected Constraint_Error (5)");
+ end if;
+
+ Test_Define_Class_Construct
+ (Facade_Class_Ptr => My_Facade_B_Ptr);
+
+ if Constraint_Error_Raised then
+ Report.Failed ("Unexpected Constraint_Error (6)");
+ end if;
+
+ -- Check that it is OK to pass null and that does not cause some failure.
+ Test_Define_Class_Construct (Facade_Class_Ptr => null);
+
+ if Constraint_Error_Raised then
+ Report.Failed ("Unexpected Constraint_Error (7)");
+ end if;
+
+ Test_Define_Class_Construct (Facade_Class_Ptr =>
+ C460014_1.Facade_Class_Ptr_Type (My_Null_Facade_B_Ptr));
+
+ if Constraint_Error_Raised then
+ Report.Failed ("Unexpected Constraint_Error (8)");
+ end if;
+
+ Report.Result;
+
+end C460014;
--- /dev/null
+-- C620001.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 elementary parameters are passed by copy.
+--
+-- Part 1: Integer, float, and access types, procedures and functions.
+--
+-- TEST DESCRIPTION:
+-- Subtests are:
+-- (A) Scalar parameters to procedures.
+-- (B) Scalar parameters to functions.
+-- (C) Access parameters to procedures.
+-- (D) Access parameters to functions.
+--
+-- For the procedure examples, we pass array elements indexed by dynamically
+-- determined indexes. Doing this side-steps the check of 6.4.1(6.15/3) and
+-- makes the test more realistic.
+--
+-- To completely test this objective, we should also try in out and out
+-- parameters for functions (Ada 2012), in/in out/out parameters for
+-- task and protected entries, and a variety of different scalar types
+-- (enumeration, modular, fixed, decimal).
+--
+-- CHANGE HISTORY:
+-- 14 Jan 1980 DAS Created test.
+-- 26 Oct 1982 SPS
+-- 25 May 1984 CPP
+-- 29 Oct 1985 EG Eliminate the use of Numeric_Error in the test.
+-- 14 Mar 2014 RLB Revised so test cases are legal for Ada 2012, modernized
+-- objective, converted to modern format, added float cases.
+
+with Report;
+procedure C620001 is
+
+ use Report;
+
+begin
+ Test ("C620001", "Check that elementary parameters are passed by copy");
+
+ --------------------------------------------------
+
+ declare -- (A)
+
+ I,J,K : Natural := Report.Ident_Int(1); -- Index values.
+ Arr : array (1 .. 4) of Integer;
+ E : exception;
+
+ procedure P (PI : in Integer;
+ PO : out Integer;
+ PIO : in out Integer) is
+
+ Tmp : Integer;
+
+ begin
+
+ Tmp := PI; -- Save value of PI at procedure entry.
+
+ PO := 10;
+ if (PI /= Tmp) then
+ Failed ("Assignement to scalar out " &
+ "parameter changes the value of " &
+ "input parameter");
+ Tmp := PI; -- Reset Tmp for next case.
+ end if;
+
+ PIO := PIO + 100;
+ if (PI /= Tmp) then
+ Failed ("Assignment to scalar in out " &
+ "parameter changes the value of " &
+ "inputparameter");
+ Tmp := PI; -- Reset Tmp for next case.
+ end if;
+
+ Arr(I) := Arr(I) + 1;
+ if (PI /= Tmp) then
+ Failed ("Assignment to scalar actual " &
+ "parameter changes the value of " &
+ "input parameter");
+ end if;
+
+ raise E; -- Check exception handling.
+ end P;
+
+ begin -- (A)
+ Arr := (others => 0);
+ P (Arr(I), Arr(J), Arr(K));
+ Failed ("Exception not raised - A");
+ exception
+ when E =>
+ if (Arr(I) /= 1) then
+ case Arr(I) is
+ when 11 =>
+ Failed ("Out actual scalar parameter " &
+ "changed global value");
+ when 101 =>
+ Failed ("In out actual scalar " &
+ "parameter changed global value");
+ when 111 =>
+ Failed ("Out and in out actual scalar " &
+ "parameters changed global " &
+ "value");
+ when others =>
+ Failed ("Uundetermined change to global " &
+ "value");
+ end case;
+ end if;
+ when others =>
+ Failed ("Wrong exception raised - A");
+ end; -- (A)
+
+ --------------------------------------------------
+
+ declare -- (B)
+
+ I,J : Integer;
+
+ function F (FI : in Integer) return Integer is
+
+ Tmp : Integer := FI;
+
+ begin
+
+ I := I + 1;
+ if (FI /= Tmp) then
+ Failed ("Assignment to scalar actual function " &
+ "parameter changes the value of " &
+ "input parameter");
+ end if;
+
+ return (100);
+ end F;
+
+ begin -- (B)
+ I := 100;
+ J := F (I);
+ end; -- (B)
+
+ --------------------------------------------------
+
+ declare -- (C)
+
+ type Acctype is access Integer;
+
+ I,J,K : Natural := Report.Ident_Int(2); -- Index values.
+ Arr : array (1 .. 5) of Acctype;
+ E : exception;
+
+ procedure P (PI : in Acctype;
+ PO : out Acctype;
+ PIO : in out Acctype) is
+
+ Tmp : Acctype;
+
+ begin
+
+ Tmp := PI; -- Save value of PI at procedure entry.
+
+ Arr(I) := new Integer'(101);
+ if (PI /= Tmp) then
+ Failed ("Assignment to access actual " &
+ "parameter changes the value of " &
+ "input parameter");
+ Tmp := PI; -- Reset Tmp for next case.
+ end if;
+
+ PO := new Integer'(1);
+ if (PI /= Tmp) then
+ Failed ("Assignment to access out " &
+ "parameter changes the value of " &
+ "input parameter");
+ Tmp := PI; -- Reset Tmp for next case.
+ end if;
+
+ PIO := new Integer'(10);
+ if (PI /= Tmp) then
+ Failed ("Assignment to access in out " &
+ "parameter changes the value of " &
+ "input parameter");
+ end if;
+
+ raise E; -- Check exception handling.
+ end P;
+
+ begin -- (C)
+ Arr(I) := new Integer'(100);
+ P (Arr(I), Arr(J), Arr(K));
+ Failed ("Exception not raised - C");
+ exception
+ when E =>
+ if (Arr(I).all /= 101) then
+ Failed ("Out or in out actual procedure " &
+ "parameter value changed despite " &
+ "raised exception");
+ end if;
+ when others =>
+ Failed ("Wrong exception raised - C");
+ end; -- (C)
+
+ --------------------------------------------------
+
+ declare -- (D)
+
+ Type Acctype is access Integer;
+
+ I,J : Acctype;
+
+ function F (FI : in Acctype) return Acctype is
+
+ Tmp : Acctype := FI;
+
+ begin
+
+ I := new Integer;
+ if (FI /= Tmp) then
+ Failed ("Assignment to access actual function " &
+ "parameter changes the value of " &
+ "Input parameter");
+ end if;
+
+ return null;
+ end F;
+
+ begin -- (D)
+ I := null;
+ J := F(I);
+ end; -- (D)
+
+ --------------------------------------------------
+
+ declare -- (E)
+
+ I,J,K : Natural := Report.Ident_Int(3); -- Index values.
+ Arr : array (1 .. 3) of Float;
+ E : exception;
+
+ procedure P (PI : in Float;
+ PO : out Float;
+ PIO : in out Float) is
+
+ Tmp : Float;
+
+ begin
+
+ Tmp := PI; -- Save value of PI at procedure entry.
+
+ PO := 0.5;
+ if (PI /= Tmp) then
+ Failed ("Assignement to float out " &
+ "parameter changes the value of " &
+ "input parameter");
+ Tmp := PI; -- Reset Tmp for next case.
+ end if;
+
+ PIO := PIO + 0.25;
+ if (PI /= Tmp) then
+ Failed ("Assignment to float in out " &
+ "parameter changes the value of " &
+ "inputparameter");
+ Tmp := PI; -- Reset Tmp for next case.
+ end if;
+
+ Arr(I) := Arr(I) + 1.0;
+ if (PI /= Tmp) then
+ Failed ("Assignment to float actual " &
+ "parameter changes the value of " &
+ "input parameter");
+ end if;
+
+ raise E; -- Check exception handling.
+ end P;
+
+ begin -- (E)
+ Arr := (others => 0.0);
+ P (Arr(I), Arr(J), Arr(K));
+ Failed ("Exception not raised - E");
+ exception
+ when E =>
+ if (Arr(I) /= 1.0) then
+ Failed ("Out or in out actual procedure " &
+ "parameter value changed despite " &
+ "raised exception");
+ end if;
+ when others =>
+ Failed ("Wrong exception raised - E");
+ end; -- (E)
+
+ --------------------------------------------------
+
+ declare -- (F)
+
+ I,J : Float;
+
+ function F (FI : in Float) return Float is
+
+ Tmp : Float := FI;
+
+ begin
+
+ I := I + 1.0;
+ if (FI /= Tmp) then
+ Failed ("Assignment to float actual function " &
+ "parameter changes the value of " &
+ "input parameter");
+ end if;
+
+ return 100.0;
+ end F;
+
+ begin -- (F)
+ I := 100.0;
+ J := F (I);
+ end; -- (F)
+
+ --------------------------------------------------
+
+ Result;
+
+end C620001;
--- /dev/null
+-- C620001.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 elementary parameters are passed by copy.
+--
+-- Part 2: Integer, float, and access types, task and protected entries.
+--
+-- TEST DESCRIPTION:
+-- Subtests are:
+-- (A) Scalar parameters to task entries.
+-- (B) Scalar parameters to protected entries.
+-- (C) Access parameters to task entries.
+-- (D) Access parameters to protected entries.
+--
+-- For all of these examples, we pass array elements indexed by dynamically
+-- determined indexes. Doing this side-steps the check of 6.4.1(6.15/3) and
+-- makes the test more realistic.
+--
+-- Note: This is based on legacy test C95072A.ADA (which was withdrawn).
+--
+-- CHANGE HISTORY:
+-- 22 Jul 1985 DAS Created test.
+-- 12 May 2020 RLB Revised so test cases are legal for Ada 2012, modernized
+-- objective, converted to modern format, added float
+-- and protected cases.
+
+with Report;
+procedure C620002 is
+
+ use Report;
+
+begin
+ Test ("C620002", "Check that elementary parameters are passed by copy," &
+ " part 2 - task and protected entries");
+
+ --------------------------------------------------
+
+ declare -- (A)
+
+ I,J,K : Natural := Report.Ident_Int (1); -- Index values.
+ Arr : array (1 .. 4) of Integer;
+ E : exception;
+
+ task TA is
+ entry EA (EI : in Integer;
+ EO : out Integer;
+ EIO : in out Integer);
+ end TA;
+
+ task body TA is
+
+ Tmp : Integer;
+
+ begin
+
+ accept EA (EI : in Integer;
+ EO : out Integer;
+ EIO : in out Integer) do
+
+ Tmp := EI; -- Save value of EI at accept.
+
+ EO := 10;
+ if EI /= Tmp then
+ Failed ("Assignement to scalar out " &
+ "parameter changes the value of " &
+ "input parameter - A");
+ Tmp := EI; -- Reset Tmp for next case.
+ end if;
+
+ EIO := EIO + 100;
+ if EI /= Tmp then
+ Failed ("Assignment to scalar in out " &
+ "parameter changes the value of " &
+ "input parameter - A");
+ Tmp := EI; -- Reset Tmp for next case.
+ end if;
+
+ Arr(I) := Arr(I) + 1;
+ if EI /= Tmp then
+ Failed ("Assignment to scalar actual " &
+ "parameter changes the value of " &
+ "input parameter - A");
+ end if;
+
+ raise E; -- Check exception handling.
+ end EA;
+
+ exception
+ when others => null;
+ end TA;
+
+ begin -- (A)
+ Arr := (others => 0);
+ TA.EA (Arr(I), Arr(J), Arr(K));
+ Failed ("Exception not raised - A");
+ exception
+ when E =>
+ if Arr(I) /= 1 then
+ case Arr(I) is
+ when 11 =>
+ Failed ("Out actual scalar parameter " &
+ "changed global value - A");
+ when 101 =>
+ Failed ("In out actual scalar " &
+ "parameter changed global value - A");
+ when 111 =>
+ Failed ("Out and in out actual scalar " &
+ "parameters changed global " &
+ "value - A");
+ when others =>
+ Failed ("Undetermined change to global " &
+ "value - A");
+ end case;
+ end if;
+ when others =>
+ Failed ("Wrong exception raised - A");
+ end; -- (A)
+
+ --------------------------------------------------
+
+ declare -- (B)
+
+ I,J,K : Natural := Report.Ident_Int (3); -- Index values.
+ Arr : array (1 .. 5) of Integer;
+ E : exception;
+
+ protected PA is
+ entry EA (EI : in Integer;
+ EO : out Integer;
+ EIO : in out Integer);
+ end PA;
+
+ protected body PA is
+
+ entry EA (EI : in Integer;
+ EO : out Integer;
+ EIO : in out Integer) when True is
+
+ Tmp : Integer;
+
+ begin
+
+ Tmp := EI; -- Save value of EI at entry.
+
+ EO := 10;
+ if EI /= Tmp then
+ Failed ("Assignement to scalar out " &
+ "parameter changes the value of " &
+ "input parameter - B");
+ Tmp := EI; -- Reset Tmp for next case.
+ end if;
+
+ EIO := EIO + 100;
+ if EI /= Tmp then
+ Failed ("Assignment to scalar in out " &
+ "parameter changes the value of " &
+ "input parameter - B");
+ Tmp := EI; -- Reset Tmp for next case.
+ end if;
+
+ Arr(I) := Arr(I) + 1;
+ if EI /= Tmp then
+ Failed ("Assignment to scalar actual " &
+ "parameter changes the value of " &
+ "input parameter - B");
+ end if;
+
+ raise E; -- Check exception handling.
+ end EA;
+
+ end PA;
+
+ begin -- (B)
+ Arr := (others => 0);
+ PA.EA (Arr(I), Arr(J), Arr(K));
+ Failed ("Exception not raised - B");
+ exception
+ when E =>
+ if Arr(I) /= 1 then
+ case Arr(I) is
+ when 11 =>
+ Failed ("Out actual scalar parameter " &
+ "changed global value - B");
+ when 101 =>
+ Failed ("In out actual scalar " &
+ "parameter changed global value - B");
+ when 111 =>
+ Failed ("Out and in out actual scalar " &
+ "parameters changed global " &
+ "value - B");
+ when others =>
+ Failed ("Undetermined change to global " &
+ "value - B");
+ end case;
+ end if;
+ when others =>
+ Failed ("Wrong exception raised - B");
+ end; -- (B)
+
+ --------------------------------------------------
+
+ declare -- (C)
+
+ type Acctype is access Integer;
+
+ I,J,K : Natural := Report.Ident_Int (2); -- Index values.
+ Arr : array (1 .. 5) of Acctype;
+ E : exception;
+
+ task TB is
+ entry EB (EI : in Acctype;
+ EO : out Acctype;
+ EIO : in out Acctype);
+ end TB;
+
+ task body TB is
+
+ Tmp : Acctype;
+
+ begin
+
+ accept EB (EI : in Acctype;
+ EO : out Acctype;
+ EIO : in out Acctype) do
+
+ Tmp := EI; -- Save value of EI at accept.
+
+ Arr(I) := new Integer'(101);
+ if EI /= Tmp then
+ Failed ("Assignment to access actual " &
+ "parameter changes the value of " &
+ "input parameter - C");
+ Tmp := EI; -- Reset Tmp for next case.
+ end if;
+
+ EO := new Integer'(1);
+ if EI /= Tmp then
+ Failed ("Assignment to access out " &
+ "parameter changes the value of " &
+ "input parameter - C");
+ Tmp := EI; -- Reset Tmp for next case.
+ end if;
+
+ EIO := new Integer'(10);
+ if EI /= Tmp then
+ Failed ("Assignment to access in out " &
+ "parameter changes the value of " &
+ "input parameter - C");
+ end if;
+
+ raise E; -- Check exception handling.
+ end EB;
+
+ exception
+ when others => null;
+ end TB;
+
+ begin -- (C)
+ Arr(I) := new Integer'(100);
+ TB.EB (Arr(I), Arr(J), Arr(K));
+ Failed ("Exception not raised - C");
+ exception
+ when E =>
+ if (Arr(I).all /= 101) then
+ Failed ("Out or in out actual " &
+ "parameter value changed despite " &
+ "raised exception - C");
+ end if;
+ when others =>
+ Failed ("Wrong exception raised - C");
+ end; -- (C)
+
+ --------------------------------------------------
+
+ declare -- (D)
+
+ type Acctype is access Integer;
+
+ I,J,K : Natural := Report.Ident_Int (4); -- Index values.
+ Arr : array (1 .. 6) of Acctype;
+ E : exception;
+
+ protected PB is
+ entry EB (EI : in Acctype;
+ EO : out Acctype;
+ EIO : in out Acctype);
+ end PB;
+
+ protected body PB is
+
+ entry EB (EI : in Acctype;
+ EO : out Acctype;
+ EIO : in out Acctype) when True is
+
+ Tmp : Acctype;
+
+ begin
+ Tmp := EI; -- Save value of EI at entry.
+
+ Arr(I) := new Integer'(101);
+ if EI /= Tmp then
+ Failed ("Assignment to access actual " &
+ "parameter changes the value of " &
+ "input parameter - D");
+ Tmp := EI; -- Reset Tmp for next case.
+ end if;
+
+ EO := new Integer'(1);
+ if EI /= Tmp then
+ Failed ("Assignment to access out " &
+ "parameter changes the value of " &
+ "input parameter - D");
+ Tmp := EI; -- Reset Tmp for next case.
+ end if;
+
+ EIO := new Integer'(10);
+ if EI /= Tmp then
+ Failed ("Assignment to access in out " &
+ "parameter changes the value of " &
+ "input parameter - D");
+ end if;
+
+ raise E; -- Check exception handling.
+ end EB;
+
+ end PB;
+
+ begin -- (D)
+ Arr(I) := new Integer'(100);
+ PB.EB (Arr(I), Arr(J), Arr(K));
+ Failed ("Exception not raised - D");
+ exception
+ when E =>
+ if (Arr(I).all /= 101) then
+ Failed ("Out or in out actual " &
+ "parameter value changed despite " &
+ "raised exception - D");
+ end if;
+ when others =>
+ Failed ("Wrong exception raised - D");
+ end; -- (D)
+
+ --------------------------------------------------
+
+ declare -- (E)
+
+ I,J,K : Natural := Report.Ident_Int (3); -- Index values.
+ Arr : array (1 .. 3) of Float;
+ E : exception;
+
+ task TC is
+ entry EC (EI : in Float;
+ EO : out Float;
+ EIO : in out Float);
+ end TC;
+
+ task body TC is
+
+ Tmp : Float;
+
+ begin
+
+ accept EC (EI : in Float;
+ EO : out Float;
+ EIO : in out Float) do
+
+ Tmp := EI; -- Save value of EI at accept.
+
+ EO := 0.5;
+ if EI /= Tmp then
+ Failed ("Assignement to float out " &
+ "parameter changes the value of " &
+ "input parameter - E");
+ Tmp := EI; -- Reset Tmp for next case.
+ end if;
+
+ EIO := EIO + 0.25;
+ if EI /= Tmp then
+ Failed ("Assignment to float in out " &
+ "parameter changes the value of " &
+ "input parameter - E");
+ Tmp := EI; -- Reset Tmp for next case.
+ end if;
+
+ Arr(I) := Arr(I) + 1.0;
+ if EI /= Tmp then
+ Failed ("Assignment to float actual " &
+ "parameter changes the value of " &
+ "input parameter - E");
+ end if;
+
+ raise E; -- Check exception handling.
+ end EC;
+
+ exception
+ when others => null;
+ end TC;
+
+ begin -- (E)
+ Arr := (others => 0.0);
+ TC.EC (Arr(I), Arr(J), Arr(K));
+ Failed ("Exception not raised - E");
+ exception
+ when E =>
+ if (Arr(I) /= 1.0) then
+ Failed ("Out or in out actual procedure " &
+ "parameter value changed despite " &
+ "raised exception - E");
+ end if;
+ when others =>
+ Failed ("Wrong exception raised - E");
+ end; -- (E)
+
+ --------------------------------------------------
+
+ declare -- (F)
+
+ I,J,K : Natural := Report.Ident_Int (6); -- Index values.
+ Arr : array (1 .. 7) of Float;
+ E : exception;
+
+ protected PC is
+ entry EC (EI : in Float;
+ EO : out Float;
+ EIO : in out Float);
+ end PC;
+
+ protected body PC is
+
+ entry EC (EI : in Float;
+ EO : out Float;
+ EIO : in out Float) when True is
+
+ Tmp : Float;
+
+ begin
+
+ Tmp := EI; -- Save value of EI at entry.
+
+ EO := 0.5;
+ if EI /= Tmp then
+ Failed ("Assignement to float out " &
+ "parameter changes the value of " &
+ "input parameter - F");
+ Tmp := EI; -- Reset Tmp for next case.
+ end if;
+
+ EIO := EIO + 0.25;
+ if EI /= Tmp then
+ Failed ("Assignment to float in out " &
+ "parameter changes the value of " &
+ "input parameter - F");
+ Tmp := EI; -- Reset Tmp for next case.
+ end if;
+
+ Arr(I) := Arr(I) + 1.0;
+ if EI /= Tmp then
+ Failed ("Assignment to float actual " &
+ "parameter changes the value of " &
+ "input parameter - F");
+ end if;
+
+ raise E; -- Check exception handling.
+ end EC;
+
+ end PC;
+
+ begin -- (F)
+ Arr := (others => 0.0);
+ PC.EC (Arr(I), Arr(J), Arr(K));
+ Failed ("Exception not raised - F");
+ exception
+ when E =>
+ if (Arr(I) /= 1.0) then
+ Failed ("Out or in out actual procedure " &
+ "parameter value changed despite " &
+ "raised exception - F");
+ end if;
+ when others =>
+ Failed ("Wrong exception raised - F");
+ end; -- (F)
+
+ --------------------------------------------------
+
+ Result;
+
+end C620002;
-- 01 DEC 97 EDS Made correction wrt RM 7.6(21)
-- 16 MAR 01 RLB Corrected Adjust cases to avoid problems with
-- RM 7.6.1(16/1) from Technical Corrigendum 1.
+-- 05 JUL 12 RLB Redid Unchecked_Deallocation case to handle
+-- the fact that the behavior is unspecified (see
+-- AI95-0179-1). Also fixed indentation.
--
--!
-- finalization of Item/Target should cause PE
end Finalize_15;
- -- check failure in finalize due to Unchecked_Deallocation
+ -- check failure in finalize due to Unchecked_Deallocation
- type Shark is access C761006_2.Fin_Check;
+ procedure Finalize_17_Outer is
+ -- This procedure exists to make Shark local, so everything allocated
+ -- on it will be finalized when this routine exits.
- procedure Catch is
- new Unchecked_Deallocation( C761006_2.Fin_Check, Shark );
+ type Shark is access C761006_2.Fin_Check;
- procedure Finalize_17 is
- White : Shark := new C761006_2.Fin_Check;
- begin
- Catch( White );
- exception
- when Program_Error =>
+ procedure Catch is
+ new Unchecked_Deallocation( C761006_2.Fin_Check, Shark );
+
+ procedure Finalize_17_Inner is
+ White : Shark := new C761006_2.Fin_Check;
+ begin
+ Catch (White);
+ -- Note: It is unspecified if Catch deallocates the memory
+ -- of the allocated object, and if it ceases to exist.
+ -- As such, it is possible that it will be finalized when
+ -- the scope of the access type is exited. We check for this
+ -- case below.
+ exception
+ when Program_Error =>
if not Sup.Events_Occurring(Sup.Good_Finalize) then
Report.Failed("Unchecked_Deallocation: " & Fin_Not_Perf);
end if;
- end Finalize_17;
+ end Finalize_17_Inner;
+
+ begin
+ Finalize_17_Inner;
+ exception
+ when others =>
+ Report.Failed("Unchecked_Deallocation check, unwanted exception in Outer");
+ end Finalize_17_Outer;
begin
end Exception_In_Finalization;
Use_Of_Unchecked_Deallocation: begin
- Finalize_17;
+ Finalize_17_Outer;
exception
+ when Program_Error =>
+ Report.Comment("Unchecked_Deallocation check, double finalization occurred");
when others =>
- Report.Failed("Unchecked_Deallocation check, unwanted exception");
+ Report.Failed("Unchecked_Deallocation check, unwanted exception in caller");
end Use_Of_Unchecked_Deallocation;
end Finalize_Test;
-- 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
+-- 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
+-- 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
+-- 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
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CPP 08/15/84 CREATED ORIGINAL TEST.
-- JET 01/06/88 UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT
-- OPTIMIZATION.
+-- RLB 12/18/06 Changed so that the test will work for Ada 2005
+-- implementations.
WITH CALENDAR; USE CALENDAR;
WITH REPORT; USE REPORT;
END;
BEGIN
- YR := IDENT_INT(YEAR_NUMBER'LAST + 1);
- FAILED ("EXCEPTION NOT RAISED - (A)3");
+ YR := IDENT_INT(2100);
IF NOT EQUAL (YR, YR) THEN
COMMENT ("NO EXCEPTION RAISED");
END IF;
-
+ BEGIN
+ YR := 2399;
+ IF NOT EQUAL (YR, YR) THEN
+ COMMENT ("NO EXCEPTION RAISED");
+ END IF;
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("ADA 2005 CASE RAISED EXCEPTION ON 2399 - (A)");
+ END;
+ BEGIN
+ YR := IDENT_INT(2400);
+ IF NOT EQUAL (YR, YR) THEN
+ COMMENT ("NO EXCEPTION RAISED");
+ END IF;
+ FAILED ("EXCEPTION NOT RAISED - (A)3");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ Comment ("Upper bound of Year_Number is appropriate" &
+ " for Ada 2005");
+ END;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
- NULL;
+ Comment ("Upper bound of Year_Number is appropriate" &
+ " for Ada 95");
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - (A)3");
END;
-- 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
+-- 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
+-- 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
+-- 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
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- (A) TIME_ERROR IS RAISED ON INVALID DATES.
-- (B) CONSTRAINT_ERROR IS RAISED FOR OUT-OF-RANGE PARAMETERS.
--- CPP 8/16/84
+-- CPP 8/16/84
+-- RLB 12/18/06 - Changed so that the test will work for Ada 2005
+-- implementations.
WITH CALENDAR; USE CALENDAR;
WITH REPORT; USE REPORT;
END;
BEGIN
- BAD_TIME := TIME_OF (YEAR_NUMBER'LAST + 1, 8, 13);
- FAILED ("EXCEPTION NOT RAISED - 2100 (B)");
+ BAD_TIME := TIME_OF (YEAR_NUMBER'LAST+1, 8, 13);
+ FAILED ("EXCEPTION NOT RAISED - YEAR_NUM'LAST+1 (B)");
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2100 (B)");
+ FAILED ("WRONG EXCEPTION RAISED - YEAR_NUM'LAST+1 (B)");
END;
BEGIN
-- 06 Dec 94 SAIC ACVC 2.0
-- 08 Dec 00 RLB Removed Exception_Identity subtest, pending
-- resolution of AI95-00241.
--- Notes for future: Replace Exception_Identity
--- subtest with whatever the resolution is.
--- Add a subtest for Exception_Name(Null_Id), which
--- is missing from this test.
+-- 29 Mar 07 RLB Replaced Exception_Identity subtest, repaired
+-- Raise_Exception subtest for AI95-00446.
--!
with Report;
end if;
+ -- Verify that Raise_Exception has no effect in the case of Null_Id.
+ -- Modified by AI-446.
+ begin
+ Ada.Exceptions.Raise_Exception(A_Null_Exception_Id);
+ Report.Comment(
+ "No exception raised by procedure Raise_Exception " &
+ "when called with a Null_Id input parameter - compatible with " &
+ "original Ada95");
+ exception
+ when Constraint_Error => null; -- OK, expected exception.
+ Report.Comment(
+ "Constraint_Error exception raised by procedure Raise_Exception " &
+ "when called with a Null_Id input parameter - compatible with " &
+ "AI95-00446");
+ when others =>
+ Report.Failed(
+ "Unexpected exception raised by procedure Raise_Exception " &
+ "when called with a Null_Id input parameter");
+ end;
+
+ TC_Flag := False;
+
+
-- Verify that Reraise_Occurrence has no effect in the case of
-- Null_Occurrence.
begin
end;
--- -- Verify that function Exception_Identity raises Constraint_Error for
--- -- a Null_Occurrence input parameter.
--- -- Note: (RLB, 2000/12/08) This behavior may be modified by AI-00241.
--- -- As such, this test case has been removed pending a resolution.
--- begin
--- declare
--- Id : Ada.Exceptions.Exception_Id :=
--- Ada.Exceptions.Exception_Identity(A_Null_Exception_Occurrence);
--- begin
--- Report.Failed
--- ("Constraint_Error not raised by Function Exception_Identity " &
--- "when called with a Null_Occurrence input parameter");
--- end;
--- exception
--- when Constraint_Error => null; -- OK, expected exception.
--- when others =>
--- Report.Failed
--- ("Unexpected exception raised by Function Exception_Identity " &
--- "when called with a Null_Occurrence input parameter");
--- end;
+ -- Verify that function Exception_Identity raises Constraint_Error for
+ -- a Null_Occurrence input parameter.
+ -- Modified by AI-241.
+ begin
+ declare
+ Id : Ada.Exceptions.Exception_Id :=
+ Ada.Exceptions.Exception_Identity(A_Null_Exception_Occurrence);
+ begin
+ Report.Comment
+ ("No exception raised by Function Exception_Identity " &
+ "when called with a Null_Occurrence input parameter - " &
+ "compatible with AI95-00241.");
+ end;
+ exception
+ when Constraint_Error =>
+ Report.Comment
+ ("Constraint_Error raised by Function Exception_Identity " &
+ "when called with a Null_Occurrence input parameter - " &
+ "compatible with original Ada95.");
+ when others =>
+ Report.Failed
+ ("Unexpected exception raised by Function Exception_Identity " &
+ "when called with a Null_Occurrence input parameter");
+ end;
-- Verify that function Exception_Name raises Constraint_Error for
-- 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
+-- 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
+-- 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
+-- 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
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--- OFFICE, 3E 114, THE PENTAGON, WASHINGTON DC 20301-3081.
-- OBJECTIVE:
-- CHECK THAT AN INSTANTIATED PACKAGE HAS THE PROPERTIES REQUIRED
--- /dev/null
+-- CD30011.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 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.
+--
+-- 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.
+--
+--*
+-- OBJECTIVE:
+-- Check that a size specification can be given by an attribute definition
+-- clause for an enumeration type:
+-- * in the visible or private part of a package for a type declared
+-- in the visible part;
+-- * for a derived enumeration type;
+-- * for a derived private type whose full declaration is an
+-- enumeration type.
+--
+-- TEST DESCRIPTION:
+-- This test was created from legacy tests CD1009B and CD2A31C. The
+-- objective of CD1009B was also an objective of CD2A31C; the tests
+-- were merged to eliminate duplication and add appropriate applicability
+-- criteria.
+--
+-- APPLICABILITY CRITERIA:
+-- All implementations must attempt to compile this test.
+--
+-- For implementations validating against Systems Programming Annex (C):
+-- this test must execute and report PASSED.
+--
+-- or implementations not validating against Annex C:
+-- this test may report compile time errors at one or more points
+-- indicated by "-- ANX-C RQMT", in which case it may be graded as
+-- inapplicable. Otherwise, the test must execute and report PASSED.
+--
+-- CHANGE HISTORY:
+-- 17 Jun 87 PWB Created original test CD2A21C.
+-- 07 Oct 87 VCL Created original test CD1009B.
+-- 17 Apr 89 DHH Changed extension from '.DEP' TO '.ADA', changed
+-- operators on 'Size tests, and added check on
+-- representation clause.
+-- 26 Mar 92 JRL Removed testing of nonobjective types.
+-- 29 Mar 17 RLB Created test from CD2A21C and CD1009B; reformatted
+-- to "modern" standards, added applicability criteria.
+
+with Report; use Report;
+with Length_Check; -- CONTAINS A CALL TO 'Failed'.
+procedure CD30011 is
+
+ type Basic_Enum is (A, B, C, D, E);
+ Specified_Size : constant := Basic_Enum'Size;
+
+ Minimum_Size : Integer := Report.Ident_Int (Specified_Size);
+
+ type Derived_Enum is new Basic_Enum;
+ for Derived_Enum'Size use Specified_Size; -- ANX-C RQMT.
+
+ package P is
+ type Enum_in_P is (A1, B1, C1, D1, E1, F1, G1);
+ for Enum_in_P'Size use Specified_Size; -- ANX-C RQMT.
+ type private_Enum is private;
+ type Alt_Enum_in_P is (A2, B2, C2, D2, E2, F2, G2);
+ private
+ type private_Enum is (A3, B3, C3, D3, E3, F3, G3);
+ for Alt_Enum_in_P'Size use Specified_Size; -- ANX-C RQMT.
+ end P;
+
+ type Derived_Private_Enum is new P.Private_Enum;
+ for Derived_Private_Enum'Size use Specified_Size; -- ANX-C RQMT.
+
+ use P;
+
+ procedure Check_1 is new Length_Check (Derived_Enum);
+ procedure Check_2 is new Length_Check (Enum_in_P);
+ procedure Check_3 is new Length_Check (Alt_Enum_in_P);
+
+ X : Enum_in_P := A1;
+ Y : Alt_Enum_in_P := A2;
+
+begin
+
+ Report.Test ("CD30011", "Check that 'Size attribute definition clauses " &
+ "can be given in the visible or private part " &
+ "of a package for enumeration types declared " &
+ "declared in the visible part, and for derived " &
+ "enumeration types and derived private types " &
+ "whose full declarations are as enumeration types");
+
+ Check_1 (C, Specified_Size, "Derived_Enum");
+ Check_2 (C1, Specified_Size, "Enum_in_P");
+ Check_3 (C2, Specified_Size, "Alt_Enum_in_P");
+
+ if Derived_Enum'Size /= Minimum_Size then
+ Failed ("Derived_Enum'Size should not be greater than" &
+ Integer'Image (Minimum_Size) & ". Actual Size is" &
+ Integer'Image (Derived_Enum'Size));
+ end if;
+
+ if Enum_in_P'Size /= Minimum_Size then
+ Failed ("Enum_in_P'Size should not be greater than" &
+ Integer'Image (Minimum_Size) & ". Actual Size is" &
+ Integer'Image (Enum_in_P'Size));
+ end if;
+
+ if Alt_Enum_in_P'Size /= Minimum_Size then
+ Failed ("Alt_Enum_in_P'Size should not be greater than" &
+ Integer'Image (Minimum_Size) & ". Actual Size is" &
+ Integer'Image (Alt_Enum_in_P'Size));
+ end if;
+
+ if Derived_Private_Enum'Size /= Minimum_Size then
+
+ Failed ("Derived_Private_Enum'Size should not be greater " &
+ "than " & Integer'Image (Minimum_Size) & ". Actual Size is" &
+ Integer'Image (Derived_Private_Enum'Size));
+ end if;
+
+ if X'Size < Specified_Size then
+ Failed ("Object'Size is too small --" &
+ Enum_in_P'Image (X));
+ end if;
+
+ if Y'Size < Specified_Size then
+ Failed ("Object'Size is too small --" &
+ Alt_Enum_in_P'Image (Y));
+ end if;
+
+ Report.Result;
+
+end CD30011;
--- /dev/null
+-- CD30012.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 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.
+--
+-- 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.
+--
+--*
+-- OBJECTIVE:
+-- Check that a size specification can be given by an attribute definition
+-- clause for an integer type:
+-- * in the visible or private part of a package for a type declared
+-- in the visible part;
+-- * for a derived integer type;
+-- * for a derived private type whose full declaration is an
+-- integer type.
+--
+-- TEST DESCRIPTION:
+-- This test was created from legacy tests CD1009B and CD2A31C. The
+-- objective of CD1009B was also an objective of CD30012; the tests
+-- were merged to eliminate duplication and add appropriate applicability
+-- criteria.
+--
+-- APPLICABILITY CRITERIA:
+-- All implementations must attempt to compile this test.
+--
+-- For implementations validating against Systems Programming Annex (C):
+-- this test must execute and report PASSED.
+--
+-- or implementations not validating against Annex C:
+-- this test may report compile time errors at one or more points
+-- indicated by "-- ANX-C RQMT", in which case it may be graded as
+-- inapplicable. Otherwise, the test must execute and report PASSED.
+--
+-- CHANGE HISTORY:
+-- 17 Jun 87 PWB Created original test CD2A31C.
+-- 09 Sep 87 VCL Created original test CD1009A.
+-- 06 Apr 89 DHH Changed extension from '.DEP' TO '.ADA', changed
+-- size clause value to 9, and added representation
+-- clause check and included test for for integer in a
+-- generic unit.
+-- 27 Mar 92 JRL Removed testing of nonobjective types.
+-- 17 Jun 92 DTN Removed the length clause for type Private_Int.
+-- 29 Mar 17 RLB Created test from CD2A31C and CD1009A; reformatted
+-- to "modern" standards, added applicability criteria,
+-- removed nonobjective packed array.
+
+with Report; use Report;
+with Length_Check; -- Contains a call to 'Failed'.
+procedure CD30012 is
+
+ type Basic_Int is range -60 .. 80;
+ Specified_Size : constant := 9;
+
+ type Derived_Int is new Basic_Int;
+ for Derived_Int'Size use Specified_Size; -- ANX-C RQMT.
+
+ package P is
+ type Int_in_P is range -125 .. 125;
+ for Int_in_P'Size use Specified_Size; -- ANX-C RQMT.
+ type Private_Int is private;
+ type Alt_Int_in_P is range -125 .. 125;
+ private
+ type Private_Int is range -125 .. 125;
+ for Alt_Int_in_P'Size use Specified_Size; -- ANX-C RQMT.
+ end P;
+
+ use P;
+ type Derived_Private_Int is new Private_Int;
+ for Derived_Private_Int'Size use Specified_Size; -- ANX-C RQMT.
+ Minimum_Size : Integer := Report.Ident_Int (Specified_Size);
+
+ -- Size specification given in a generic procedure:
+
+ generic
+ procedure Genproc;
+
+ procedure Genproc is
+ type Check_Int is range -125 .. 125;
+ for Check_Int'Size use Specified_Size; -- ANX-C RQMT.
+
+ procedure Check_4 is new Length_Check (Check_Int);
+
+ begin
+
+ if Check_Int'Size /= Minimum_Size then
+ Failed ("Generic Check_Int'Size is incorrect");
+ end if;
+ Check_4 (-60, 9, "generic Check_Int");
+
+ end Genproc;
+
+ procedure Newproc is new Genproc;
+
+ procedure Check_1 is new Length_Check (Derived_Int);
+ procedure Check_2 is new Length_Check (Int_in_P);
+ procedure Check_3 is new Length_Check (Alt_Int_in_P);
+
+ Obj1 : Int_in_P := 92;
+ Obj2 : Alt_Int_in_P := 52;
+
+begin
+
+ Report.Test ("CD30012", "Check that 'Size attribute definition clauses " &
+ "can be given in the visible or private part " &
+ "of a package for integer types declared " &
+ "declared in the visible part, and for derived " &
+ "integer types and derived private types " &
+ "whose full declarations are as integer types");
+
+ Check_1 (-60, 9, "Derived_Int");
+ Check_2 (-60, 9, "Int_in_P");
+ Check_3 (-60, 9, "Alt_Int_in_P");
+ Check_2 (Obj1, 9, "Int_in_P");
+ Check_3 (Obj2, 9, "Alt_Int_in_P");
+
+ Newproc;
+
+ if Derived_Int'Size /= Minimum_Size then
+ Failed ("Derived_Int'Size incorrect");
+ end if;
+
+ if Int_in_P'Size /= Minimum_Size then
+ Failed ("Int_in_P'Size incorrect");
+ end if;
+
+ if Alt_Int_in_P'Size /= Minimum_Size then
+ Failed ("Alt_Int_in_P'Size incorrect");
+ end if;
+
+ if Derived_Private_Int'Size /= Minimum_Size then
+ Failed ("Derived_Private_Int'Size incorrect");
+ end if;
+
+ if Obj1'Size < Specified_Size then
+ Failed ("Object'Size is too small --" &
+ Int_in_P'Image (Obj1));
+ end if;
+
+ if Obj2'Size < Specified_Size then
+ Failed ("Object'Size is too small --" &
+ Alt_Int_in_P'Image (Obj2));
+ end if;
+
+ Report.Result;
+
+end CD30012;
-- 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
+-- 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
+-- 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
+-- 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
+-- 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 Unchecked_Conversion is supported and is reversible in
-- the cases where:
--- Source'Size = Target'Size
--- Source'Alignment = Target'Alignment
--- Source and Target are both represented contiguously
+-- Source'Size = Target'Size
+-- Source'Alignment = Target'Alignment
+-- Source and Target are both represented contiguously
-- Bit pattern in Source is a meaningful value of Target type
---
+--
-- TEST DESCRIPTION:
-- This test declares an enumeration type with a representation
-- specification that should fit neatly into an 8 bit object; and a
-- 27 JUL 96 SAIC Allowed for partial N/A to be PASS
-- 14 FEB 97 PWB.CTA Corrected "=" to "/=" in alignment check.
-- 16 FEB 98 EDS Modified documentation.
+-- 21 DEC 05 RLB Corrected "=" to "/=" in other alignment check.
--!
----------------------------------------------------------------- CD90001_0
Report.Failed ("EU => EB conversion failed");
end if;
- end loop;
+ end loop;
end TC_Check_Case_1;
procedure TC_Check_Case_2 is
Report.Comment("The sizes of the 16 bit types used in this test "
& "do not match" );
Sixteen_NA := True;
- elsif CD90001_0.Signed_16'Alignment = CD90001_0.Bits_16'Alignment then
+ elsif CD90001_0.Signed_16'Alignment /= CD90001_0.Bits_16'Alignment then
Report.Comment("The alignments of the 16 bit types used in this "
& "test do not match" );
Sixteen_NA := True;
--- /dev/null
+-- CXA3004.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 the functions defined in package Ada.Characters.Handling
+-- for classification of and conversion between Wide_Character and
+-- Character values produce correct results when given the appropriate
+-- Character and String inputs.
+--
+-- TEST DESCRIPTION:
+-- This test demonstrates the functions defined in package
+-- Ada.Characters.Handling which provide for the classification of and
+-- conversion between Wide_Characters and Characters, in character
+-- variables and strings.
+-- Each of the functions is provided with input values that are of the
+-- appropriate range. The results of the function processing are
+-- subsequently evaluated.
+--
+-- APPLICABILITY CRITERIA:
+-- Applicable to all implementations using the Latin_1 set as the
+-- definition of Character.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+-- 27 Dec 94 SAIC Corrected variable names.
+--
+--!
+
+with Report;
+with Ada.Characters.Handling;
+
+procedure CXA3004 is
+begin
+
+ Report.Test ("CXA3004", "Check that the functions defined in package " &
+ "Ada.Characters.Handling for classification " &
+ "of and conversion between Wide_Character and " &
+ "Character values produce correct results " &
+ "when given the appropriate Character " &
+ "and String inputs");
+
+ Test_Block:
+ declare
+
+ package ACH renames Ada.Characters.Handling;
+
+ Char_End : Integer := 255;
+ WC_Start : Integer := 256;
+ Sub_Char : Character := '*';
+
+ Blank : Character := ' ';
+ First_Char : Character := Character'First;
+ Last_Char : Character := Character'Last;
+ F_Char : Character := 'F';
+
+
+ First_Wide_Char : Wide_Character := Wide_Character'First;
+ Last_Non_Wide_Char : Wide_Character := Wide_Character'Val(Char_End);
+ First_Unique_Wide_Char : Wide_Character := Wide_Character'Val(WC_Start);
+ Last_Wide_Char : Wide_Character := Wide_Character'Last;
+
+ A_String : String (1..3) := First_Char & 'X' & Last_Char;
+ A_Wide_String : Wide_String (1..3) := First_Wide_Char &
+ ACH.To_Wide_Character('X') &
+ ACH.To_Wide_Character(Last_Char);
+
+ Unique_Wide_String : Wide_String (1..2) := First_Unique_Wide_Char &
+ Last_Wide_Char;
+
+ Mixed_Wide_String : Wide_String (1..6) := ACH.To_Wide_Character('A') &
+ First_Wide_Char &
+ Last_Non_Wide_Char &
+ First_Unique_Wide_Char &
+ Last_Wide_Char &
+ ACH.To_Wide_Character('Z');
+
+
+ Basic_Char : Character := 'A';
+ Basic_Wide_Char : Wide_Character := 'A';
+ Basic_String : String (1..6) := "ABCXYZ";
+ Basic_Wide_String : Wide_String (1..6) := "ABCXYZ";
+
+ begin
+
+
+ -- Function Is_Character
+
+
+ if not ACH.Is_Character(First_Wide_Char) then
+ Report.Failed ("Incorrect result from Is_Character - 1");
+ end if;
+
+
+ if ACH.Is_Character(First_Unique_Wide_Char) or
+ ACH.Is_Character(Last_Wide_Char)
+ then
+ Report.Failed ("Incorrect result from Is_Character - 2");
+ end if;
+
+
+ -- Function Is_String
+
+
+ if not ACH.Is_String(A_Wide_String) then
+ Report.Failed ("Incorrect result from Is_String - 1");
+ end if;
+
+
+ if ACH.Is_String(Unique_Wide_String) or
+ ACH.Is_String(Mixed_Wide_String)
+ then
+ Report.Failed ("Incorrect result from Is_String - 2");
+ end if;
+
+
+ -- Function To_Character
+
+
+ -- Use default substitution character in call of To_Character.
+
+ if ACH.To_Character(First_Wide_Char) /= First_Char or
+ ACH.To_Character(Last_Non_Wide_Char) /= Last_Char
+ then
+ Report.Failed ("Incorrect result from To_Character - 1");
+ end if;
+
+
+ -- Provide a substitution character for use with To_Character.
+
+ if ACH.To_Character(First_Unique_Wide_Char, Blank) /= Blank or
+ ACH.To_Character(First_Unique_Wide_Char, Sub_Char) /= Sub_Char or
+ ACH.To_Character(Last_Wide_Char) /= ' ' -- default
+ then
+ Report.Failed ("Incorrect result from To_Character - 2");
+ end if;
+
+
+ -- Function To_String
+
+
+ if ACH.To_String(A_Wide_String) /= A_String then
+ Report.Failed ("Incorrect result from To_String - 1");
+ end if;
+
+
+ if ACH.To_String(Unique_Wide_String, Sub_Char) /= "**" then
+ Report.Failed ("Incorrect result from To_String - 2");
+ end if;
+
+
+
+ if ACH.To_String(Mixed_Wide_String, Sub_Char) /=
+ ('A' & First_Char & Last_Char & "**" & 'Z') or
+ ACH.To_String(Mixed_Wide_String, Sub_Char) /=
+ (ACH.To_Character(Mixed_Wide_String(1), Sub_Char) &
+ ACH.To_Character(Mixed_Wide_String(2), Sub_Char) &
+ ACH.To_Character(Mixed_Wide_String(3), Sub_Char) &
+ ACH.To_Character(Mixed_Wide_String(4), Sub_Char) &
+ ACH.To_Character(Mixed_Wide_String(5), Sub_Char) &
+ ACH.To_Character(Mixed_Wide_String(6), Sub_Char))
+ then
+ Report.Failed ("Incorrect result from To_String - 3");
+ end if;
+
+
+ -- Function To_Wide_Character
+
+
+ if ACH.To_Wide_Character(Basic_Char) /= Basic_Wide_Char then
+ Report.Failed ("Incorrect result from To_Wide_Character");
+ end if;
+
+
+ -- Function To_Wide_String
+
+
+ if not (ACH.To_Wide_String(Basic_String) = Basic_Wide_String) then
+ Report.Failed ("Incorrect result from To_Wide_String");
+ end if;
+
+
+ -- Functions Used In Combination
+
+ if not ACH.Is_Character (ACH.To_Wide_Character (
+ ACH.To_Character(First_Wide_Char)))
+ then
+ Report.Failed ("Incorrect result from functions in combination - 1");
+ end if;
+
+
+ if not ACH.Is_String(ACH.To_Wide_String(ACH.To_String(A_Wide_String)))
+ then
+ Report.Failed ("Incorrect result from functions in combination - 2");
+ end if;
+
+
+ if ACH.To_String(ACH.To_Wide_Character('A') &
+ ACH.To_Wide_Character(F_Char) &
+ ACH.To_Wide_Character('Z')) /= "AFZ"
+ then
+ Report.Failed ("Incorrect result from functions in combination - 3");
+ end if;
+
+
+ exception
+ when others => Report.Failed ("Exception raised in Test_Block");
+ end Test_Block;
+
+
+ Report.Result;
+
+end CXA3004;
--- /dev/null
+-- CXA5013.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 a discrete random number generator will yield each value
+-- in its result subtype in a finite number of calls, provided that
+-- the number of such values does not exceed 2**15.
+--
+-- TEST DESCRIPTION:
+-- This test demonstrates certain capabilities of the random number
+-- generator packages in Ada.Numerics. A generic subprogram is
+-- defined that will be instantiated to produce a total of two test
+-- subprograms.
+-- The area examined by this test is the production of random values
+-- over a discrete range. A generic procedure is instantiated with
+-- an instance of the Discrete_Random package, once for an integer type,
+-- and once for an enumeration type. The test procedure performs a
+-- test run, generating a specific number of random numbers over the
+-- range of the type. If this run did not generate each of the values
+-- in the type range, an asynchronous select statement is invoked. This
+-- select statement has a trigger statement delay for a specific
+-- (implementation defined) amount of time during which additional test
+-- runs will be performed.
+-- At the end of each run in this test, an evaluation is made to
+-- determine if each value in the range of possible values have been
+-- generated. At the conclusion of the runs, or if the specified test
+-- delay time expires, the test is concluded with a status value
+-- returned from the test procedure. An implementation is given three
+-- completely separate opportunities to run the test successfully, and
+-- if at the conclusion of all of these tests no successful result has
+-- been returned, the test is considered failed.
+--
+--
+-- CHANGE HISTORY:
+-- 27 Apr 95 SAIC Initial prerelease version.
+--
+--!
+
+with Ada.Numerics.Discrete_Random;
+with ImpDef;
+with Report;
+
+procedure CXA5013 is
+
+begin
+
+ Report.Test ("CXA5013", "Check that a discrete random number generator " &
+ "will yield each value in its result subtype " &
+ "in a finite number of calls");
+
+ Test_Block:
+ declare
+
+ use Ada.Numerics;
+
+ -- The following constant designed into the test creates a high
+ -- probability that a random series of numbers will satisfy the
+ -- requirements. Occasionally, even a random series of numbers
+ -- will fail. In such a case, the test will reset the random
+ -- number generator and rerun the test conditions. This constant
+ -- determines how many times the random number generator will be
+ -- reset before any individual test run is failed.
+
+ TC_Max_Random_Test_Runs : constant := 3;
+
+ -- The following constant will ensure that multiple attempts of the
+ -- complete set of tests are performed in the event of a failure of
+ -- a set of test runs.
+
+ TC_Finite_Number_Of_Tests : constant := 3;
+
+
+ TC_Test_Run : Integer := 0;
+ TC_Success : Boolean := False;
+ TC_Trials_Per_Test : Integer := 1500;
+
+ type Enum_Type is (One, Two, Three, Four, Five, Six, Seven);
+ type Discrete_Type is range 1..100;
+
+
+ package Enum_Pack is new Discrete_Random(Enum_Type);
+ package Discrete_Pack is
+ new Discrete_Random(Result_Subtype => Discrete_Type);
+
+
+
+ --
+ -- Definition of generic Random_Test procedure, which will be
+ -- instantiated for both an integer type and an enumeration type.
+ --
+
+ generic
+ with package Gen_Pack is new Ada.Numerics.Discrete_Random (<>);
+ procedure Random_Test (Trials_Per_Test : in Integer;
+ Success : out Boolean);
+
+
+ procedure Random_Test (Trials_Per_Test : in Integer;
+ Success : out Boolean) is
+ Total_Runs : Integer := 0;
+ Total_Trials : Integer := 0;
+ Total_Attempts_This_Test : Integer := 0;
+ Random_Array : array (Gen_Pack.Result_Subtype)
+ of Boolean := (others => False);
+ Gen : Gen_Pack.Generator;
+
+ function All_Values_Present return Boolean is
+ Result : Boolean := True;
+ begin
+ for i in Gen_Pack.Result_Subtype'Range loop
+ if not Random_Array(i) then
+ Result := False;
+ exit;
+ end if;
+ end loop;
+ return Result;
+ end All_Values_Present;
+
+ begin
+
+ Success := False; -- Initialized to failure prior to test.
+ Gen_Pack.Reset(Gen); -- Perform a time-dependent reset.
+
+ -- Guarantee that a specific minimum number of trials are performed
+ -- prior to the timer being set.
+
+ for i in 1..Trials_Per_Test loop
+ -- Set array element to True when a particular array
+ -- index is generated by the random number generator.
+ Random_Array(Gen_Pack.Random(Gen)) := True;
+ end loop;
+
+ if All_Values_Present then
+
+ Success := True; -- Test was successful, exit procedure with no
+ -- further testing performed.
+ else
+
+ -- Initial test above was unsuccessful, so set a timer and perform
+ -- additional trials to determine if all values in the discrete
+ -- range will be produced.
+
+ select
+
+ -- This asynchronous select has a triggering statement which
+ -- is a delay statement, set to an implementation defined
+ -- number of seconds for any particular test to execute.
+ -- The point here is to allow the implementation to decide
+ -- how long to run this test in order to generate an
+ -- appropriate (i.e., correct) sample from the Random Number
+ -- Generator.
+
+ delay ImpDef.Delay_Per_Random_Test; -- Delay per test.
+
+ -- If, after expiration of delay, the random number generator
+ -- has generated all values within the range at least once,
+ -- then the result is success; otherwise, a comment is output
+ -- to indicate that the random number generator was
+ -- unsuccessful in this series of test runs.
+
+ if All_Values_Present then
+ Success := True;
+ else
+ Total_Attempts_This_Test :=
+ Total_Runs * Trials_Per_Test + Total_Trials;
+ Report.Comment
+ ("Not all numbers within the Range were produced in " &
+ Integer'Image(
+ Integer(ImpDef.Delay_Per_Random_Test*1000.0)) &
+ " milliseconds or in " &
+ Integer'Image(Total_Attempts_This_Test) &
+ " trials during this test");
+ end if;
+
+ then abort
+
+ -- After setting the triggering statement above, the execution
+ -- of this abortable part is begun.
+ -- This loop continues until either a) every value has been
+ -- produced or b) the triggering statement times out.
+
+ Total_Runs := 1;
+
+ Test_Loop: -- This loop continues until a test run is
+ loop -- successful, the test run limit has been reached,
+ -- or the triggering statement times-out above.
+
+ Total_Trials := 0;
+
+ for i in 1..Trials_Per_Test loop
+ Total_Trials := i; -- Used above if triggering statement
+ -- completes prior to test completion.
+
+ -- Set array element to True when a particular array
+ -- index is generated by the random number generator.
+
+ Random_Array(Gen_Pack.Random(Gen)) := True;
+
+ end loop;
+
+ -- At the conclusion of a complete series of trials, the
+ -- following evaluation is performed to determine whether
+ -- the test run was successful, or whether an additional
+ -- test run should be re-attempted.
+
+ if All_Values_Present then
+ Success := True;
+ exit Test_Loop;
+ elsif Total_Runs = TC_Max_Random_Test_Runs then
+ Report.Comment
+ ("Not all numbers in the Range were produced in " &
+ Integer'Image(Total_Runs*Trials_Per_Test) &
+ " individual trials during this test");
+ exit Test_Loop;
+ else
+ Total_Runs := Total_Runs + 1;
+ end if;
+
+ end loop Test_Loop;
+ end select;
+ end if;
+ end Random_Test;
+
+
+
+ -- Instantiation of test procedures.
+
+ procedure Discrete_Random_Test is new Random_Test(Discrete_Pack);
+ procedure Enumeration_Random_Test is new Random_Test(Enum_Pack);
+
+
+ begin
+
+ -- Make a series of test runs, checking to ensure that discrete
+ -- random number generators produce each value in their result subtype
+ -- within a finite number of calls. In each case, if the first test
+ -- is not successful, another attempt is made, after a time-dependent
+ -- reset, up to a total of 3 runs. This allows an implementation
+ -- multiple opportunities to pass the test successfully.
+ -- Note: The odds of getting all 100 integer values in 1500 trials are
+ -- greater than 99.997 percent, confirmed by Monte Carlo
+ -- simulation.
+
+
+
+ -- Run the Random_Test for an integer discrete random number generator.
+
+ TC_Test_Run := 0;
+ TC_Success := False;
+ while TC_Test_Run < TC_Finite_Number_Of_Tests and
+ not TC_Success
+ loop
+ TC_Test_Run := TC_Test_Run + 1; -- Increment test counter.
+ Discrete_Random_Test (TC_Trials_Per_Test, -- Perform test.
+ TC_Success);
+ -- Increment the number of trials that will be performed
+ -- in the next test by 50%.
+ TC_Trials_Per_Test := TC_Trials_Per_Test + TC_Trials_Per_Test/2 ;
+ end loop;
+
+ if not TC_Success then
+ Report.Failed("Random_Test was run " & Integer'Image(TC_Test_Run) &
+ " times, but a successful result was not recorded " &
+ "from any run using the integer discrete random " &
+ "number generator");
+ end if;
+
+
+
+ -- Run the Random_Test for an enumeration type random number generator.
+
+ -- Note: The odds of getting all seven enumeration values in 100
+ -- trials are greater than 99.997 percent, confirmed by Monte
+ -- Carlo simulation.
+
+ TC_Test_Run := 0;
+ TC_Trials_Per_Test := 100;
+ TC_Success := False;
+ while TC_Test_Run < TC_Finite_Number_Of_Tests and
+ not TC_Success
+ loop
+ TC_Test_Run := TC_Test_Run + 1;
+ Enumeration_Random_Test (TC_Trials_Per_Test,
+ TC_Success);
+ -- Increment the number of trials that will be performed
+ -- in the next test by 50%.
+ TC_Trials_Per_Test := TC_Trials_Per_Test + TC_Trials_Per_Test/2 ;
+ end loop;
+
+ if not TC_Success then
+ Report.Failed("Random_Test was run " & Integer'Image(TC_Test_Run) &
+ " times, but a successful result was not recorded " &
+ "from any run using the enumeration random number " &
+ "generator");
+ end if;
+
+
+ exception
+ when others => Report.Failed ("Exception raised in Test_Block");
+ end Test_Block;
+
+ Report.Result;
+
+end CXA5013;
-- 12 FEB 2001 PHL Initial version.
-- 14 MAR 2001 RLB Readied for release; fixed Not_Applicable check
-- to terminate test gracefully.
+-- 05 MAR 2007 RLB Updated to avoid problems with return-by-reference.
--
--!
with Ada.Streams.Stream_Io;
package Checked_Stream_Io is
type File_Type (Max_Size : Stream_Element_Count) is limited private;
- function Stream_Io_File (File : File_Type) return Stream_Io.File_Type;
procedure Create (File : in out File_Type;
Mode : in Stream_Io.File_Mode := Stream_Io.Out_File;
function Index (File : in File_Type) return Stream_Io.Positive_Count;
+ function Size (File : in File_Type) return Stream_Io.Count;
+
procedure Set_Mode (File : in out File_Type;
Mode : in Stream_Io.File_Mode);
use Stream_Io;
- function Stream_Io_File (File : File_Type) return Stream_Io.File_Type is
- begin
- return File.File;
- end Stream_Io_File;
-
procedure Create (File : in out File_Type;
Mode : in Stream_Io.File_Mode := Stream_Io.Out_File;
Name : in String := "";
return New_Index;
end Index;
+ function Size (File : in File_Type) return Stream_Io.Count is
+ New_Size : constant Count := Stream_Io.Size (File.File);
+ begin
+ TC_Assert (New_Size <= Count(File.Max_Size), "File too large");
+ return New_Size;
+ end Size;
+
procedure Set_Mode (File : in out File_Type;
Mode : in Stream_Io.File_Mode) is
Old_Index : constant Count := File.Index;
begin
- Test ("CXAC005", "Check that stream file positioning work as specified");
+ Report.Test ("CXAC005",
+ "Check that stream file positioning work as specified");
declare
Name : constant String := Legal_File_Name;
-- Check the contents of the entire file.
declare
S : Stream_Element_Array
- (1 .. Stream_Element_Offset
- (Stream_Io.Size (Csio.Stream_Io_File (F))));
+ (1 .. Stream_Element_Offset (Csio.Size (F)));
begin
Csio.Reset (F, Stream_Io.In_File);
Csio.Read (F, S, Last);
Csio.Delete (F);
end;
- Result;
+ Report.Result;
exception
when Incomplete =>
Report.Result;
--- /dev/null
+-- CXB30061.AM
+--
+-- 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 the function To_C maps between the Ada type Wide_Character
+-- and the C type wchar_t.
+--
+-- Check that the function To_Ada maps between the C type wchar_t and
+-- the Ada type Wide_Character.
+--
+-- Check that the function Is_Nul_Terminated returns True if the
+-- wchar_array parameter contains wide_nul, and otherwise False.
+--
+-- Check that the function To_C produces a correct wchar_array result,
+-- with lower bound of 0, and length dependent upon the Item and
+-- Append_Nul parameters.
+--
+-- Check that the function To_Ada produces a correct wide_string result,
+-- with lower bound of 1, and length dependent upon the Item and
+-- Trim_Nul parameters.
+--
+-- Check that the function To_Ada raises Terminator_Error if the
+-- parameter Trim_Nul is set to True, but the actual Item parameter
+-- does not contain the wide_nul wchar_t.
+--
+-- TEST DESCRIPTION:
+-- This test uses a variety of Wide_Character, wchar_t, Wide_String, and
+-- wchar_array objects to test versions of the To_C, To_Ada, and
+-- Is_Nul_Terminated functions.
+--
+-- This test assumes that the following characters are all included
+-- in the implementation defined type Interfaces.C.wchar_t:
+-- ' ', ',', '.', '0'..'9', 'a'..'z' and 'A'..'Z'.
+--
+-- APPLICABILITY CRITERIA:
+-- This test is applicable to all implementations that provide
+-- package Interfaces.C. If an implementation provides
+-- package Interfaces.C, this test must compile, execute, and
+-- report "PASSED".
+--
+-- SPECIAL REQUIREMENTS:
+-- The file CXB30060.C must be compiled with a C compiler.
+-- Implementation dialects of C may require alteration of
+-- the C program syntax (see individual C files).
+--
+-- Note that the compiled C code must be bound with the compiled Ada
+-- code to create an executable image. An implementation must provide
+-- the necessary commands to accomplish this.
+--
+-- Note that the C code included in CXB30060.C conforms
+-- to ANSI-C. Modifications to these files may be required for other
+-- C compilers. An implementation must provide the necessary
+-- modifications to satisfy the function requirements.
+--
+-- TEST FILES:
+-- The following files comprise this test:
+--
+-- CXB30060.C
+-- CXB30061.AM
+--
+-- CHANGE HISTORY:
+-- 07 Sep 95 SAIC Initial prerelease version.
+-- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
+-- 13 Sep 99 RLB Replaced (bogus) Unchecked_Conversions with a
+-- C function character generator.
+--
+--!
+
+with Report;
+with Interfaces.C; -- N/A => ERROR
+with Ada.Characters.Latin_1;
+with Ada.Characters.Handling;
+with Ada.Exceptions;
+with Ada.Strings.Wide_Fixed;
+with Impdef;
+
+procedure CXB30061 is
+begin
+
+ Report.Test ("CXB3006", "Check that the functions To_C and To_Ada " &
+ "produce correct results");
+
+ Test_Block:
+ declare
+
+ use Interfaces, Interfaces.C;
+ use Ada.Characters, Ada.Characters.Latin_1, Ada.Characters.Handling;
+ use Ada.Strings.Wide_Fixed;
+
+ First_Character,
+ Last_Character : Character;
+ TC_wchar_t,
+ TC_Low_wchar_t,
+ TC_High_wchar_t : wchar_t := wchar_t'First;
+ TC_Wide_String : Wide_String(1..8) := (others => Wide_Character'First);
+ TC_wchar_array : wchar_array(0..7) := (others => C.wide_nul);
+
+ -- The function Char_Gen returns a character corresponding to its
+ -- argument.
+ -- Value 0 .. 9 ==> '0' .. '9'
+ -- Value 10 .. 19 ==> 'A' .. 'J'
+ -- Value 20 .. 29 ==> 'k' .. 't'
+ -- Value 30 ==> ' '
+ -- Value 31 ==> '.'
+ -- Value 32 ==> ','
+
+ function Char_Gen (Value : in int) return wchar_t;
+
+ -- Use the user-defined C function char_gen as a completion to the
+ -- function specification above.
+
+ pragma Import (Convention => C,
+ Entity => Char_Gen,
+ External_Name => Impdef.CXB30060_External_Name);
+
+ begin
+
+ -- Check that the functions To_C and To_Ada map between the Ada type
+ -- Wide_Character and the C type wchar_t.
+
+ if To_C(To_Wide_Character(Ada.Characters.Latin_1.NUL)) /=
+ Interfaces.C.wide_nul
+ then
+ Report.Failed("Incorrect result from To_C with NUL character input");
+ end if;
+
+ First_Character := Report.Ident_Char('k');
+ Last_Character := Report.Ident_Char('t');
+ for i in First_Character..Last_Character loop
+ if To_C(Item => To_Wide_Character(i)) /=
+ Char_Gen(Character'Pos(i) - Character'Pos('k') + 20)
+ then
+ Report.Failed("Incorrect result from To_C with lower case " &
+ "alphabetic wide character input");
+ end if;
+ end loop;
+
+ First_Character := Report.Ident_Char('A');
+ Last_Character := Report.Ident_Char('J');
+ for i in First_Character..Last_Character loop
+ if To_C(Item => To_Wide_Character(i)) /=
+ Char_Gen(Character'Pos(i) - Character'Pos('A') + 10)
+ then
+ Report.Failed("Incorrect result from To_C with upper case " &
+ "alphabetic wide character input");
+ end if;
+ end loop;
+
+ First_Character := Report.Ident_Char('0');
+ Last_Character := Report.Ident_Char('9');
+ for i in First_Character..Last_Character loop
+ if To_C(Item => To_Wide_Character(i)) /=
+ Char_Gen(Character'Pos(i) - Character'Pos('0'))
+ then
+ Report.Failed("Incorrect result from To_C with digit " &
+ "wide character input");
+ end if;
+ end loop;
+
+ if To_C(Item => To_Wide_Character(' ')) /= Char_Gen(30)
+ then
+ Report.Failed("Incorrect result from To_C with space " &
+ "wide character input");
+ end if;
+
+ if To_C(Item => To_Wide_Character('.')) /= Char_Gen(31)
+ then
+ Report.Failed("Incorrect result from To_C with dot " &
+ "wide character input");
+ end if;
+
+ if To_C(Item => To_Wide_Character(',')) /= Char_Gen(32)
+ then
+ Report.Failed("Incorrect result from To_C with comma " &
+ "wide character input");
+ end if;
+
+ if To_Ada(Interfaces.C.wide_nul) /=
+ To_Wide_Character(Ada.Characters.Latin_1.NUL)
+ then
+ Report.Failed("Incorrect result from To_Ada with wide_nul " &
+ "wchar_t input");
+ end if;
+
+ for Code in int range
+ int(Report.Ident_Int(20)) .. int(Report.Ident_Int(29)) loop
+ -- 'k' .. 't'
+ if To_Ada(Item => Char_Gen(Code)) /=
+ To_Wide_Character(Character'Val (Character'Pos('k') + (Code - 20)))
+ then
+ Report.Failed("Incorrect result from To_Ada with lower case " &
+ "alphabetic wchar_t input");
+ end if;
+ end loop;
+
+ for Code in int range
+ int(Report.Ident_Int(10)) .. int(Report.Ident_Int(19)) loop
+ -- 'A' .. 'J'
+ if To_Ada(Item => Char_Gen(Code)) /=
+ To_Wide_Character(Character'Val (Character'Pos('A') + (Code - 10)))
+ then
+ Report.Failed("Incorrect result from To_Ada with upper case " &
+ "alphabetic wchar_t input");
+ end if;
+ end loop;
+
+ for Code in int range
+ int(Report.Ident_Int(0)) .. int(Report.Ident_Int(9)) loop
+ -- '0' .. '9'
+ if To_Ada(Item => Char_Gen(Code)) /=
+ To_Wide_Character(Character'Val (Character'Pos('0') + (Code)))
+ then
+ Report.Failed("Incorrect result from To_Ada with digit " &
+ "wchar_t input");
+ end if;
+ end loop;
+
+ if To_Ada(Item => Char_Gen(30)) /= ' ' then
+ Report.Failed("Incorrect result from To_Ada with space " &
+ "char input");
+ end if;
+ if To_Ada(Item => Char_Gen(31)) /= '.' then
+ Report.Failed("Incorrect result from To_Ada with dot " &
+ "char input");
+ end if;
+ if To_Ada(Item => Char_Gen(32)) /= ',' then
+ Report.Failed("Incorrect result from To_Ada with comma " &
+ "char input");
+ end if;
+
+ -- Check that the function Is_Nul_Terminated produces correct results
+ -- whether or not the wchar_array argument contains the
+ -- Ada.Interfaces.C.wide_nul character.
+
+ TC_Wide_String := "abcdefgh";
+ if Is_Nul_Terminated(Item => To_C(TC_Wide_String, Append_Nul => False))
+ then
+ Report.Failed("Incorrect result from Is_Nul_Terminated when no " &
+ "wide_nul wchar_t is present");
+ end if;
+
+ if not Is_Nul_Terminated(To_C(TC_Wide_String, Append_Nul => True)) then
+ Report.Failed("Incorrect result from Is_Nul_Terminated when the " &
+ "wide_nul wchar_t is present");
+ end if;
+
+
+
+ -- Now that we've tested the character/char versions of To_Ada and To_C,
+ -- use them to test the string versions.
+
+ declare
+ i : size_t := 0;
+ j : integer := 1;
+ Incorrect_Conversion : Boolean := False;
+
+ TC_No_wide_nul : constant wchar_array := To_C(TC_Wide_String,
+ False);
+ TC_wide_nul_Appended : constant wchar_array := To_C(TC_Wide_String,
+ True);
+ begin
+
+ -- Check that the function To_C produces a wchar_array result with
+ -- lower bound of 0, and length dependent upon the Item and
+ -- Append_Nul parameters (if Append_Nul is True, length is
+ -- Item'Length + 1; if False, length is Item'Length).
+
+ if TC_No_wide_nul'First /= 0 or TC_wide_nul_Appended'First /= 0 then
+ Report.Failed("Incorrect lower bound from Function To_C");
+ end if;
+
+ if TC_No_wide_nul'Length /= TC_Wide_String'Length then
+ Report.Failed("Incorrect length returned from Function To_C " &
+ "when Append_Nul => False");
+ end if;
+
+ if TC_wide_nul_Appended'Length /= TC_Wide_String'Length + 1 then
+ Report.Failed("Incorrect length returned from Function To_C " &
+ "when Append_Nul => True");
+ end if;
+
+ if not Is_Nul_Terminated(TC_wide_nul_Appended) then
+ Report.Failed("No wide_nul appended to the wide_string " &
+ "parameter during conversion to wchar_array " &
+ "by function To_C");
+ end if;
+
+ for TC_char in Report.Ident_Char('a')..Report.Ident_Char('h') loop
+ if TC_No_wide_nul(i) /= To_C(To_Wide_Character(TC_char)) or
+ TC_wide_nul_Appended(i) /= To_C(To_Wide_Character(TC_char)) then
+ -- Use single character To_C.
+ Incorrect_Conversion := True;
+ end if;
+ i := i + 1;
+ end loop;
+
+ if Incorrect_Conversion then
+ Report.Failed("Incorrect result from To_C with wide_string input " &
+ "and wchar_array result");
+ end if;
+
+
+ -- Check that the function To_Ada produces a wide_string result with
+ -- lower bound of 1, and length dependent upon the Item and
+ -- Trim_Nul parameters (if Trim_Nul is False, length is Item'Length;
+ -- if False, length will be the length of the slice of Item prior to
+ -- the first wide_nul).
+
+ declare
+ TC_No_NUL_Wide_String : constant Wide_String :=
+ To_Ada(Item => TC_wide_nul_Appended, Trim_Nul => True);
+
+ TC_NUL_Appended_Wide_String : constant Wide_String :=
+ To_Ada(TC_wide_nul_Appended, False);
+
+ begin
+
+ if TC_No_NUL_Wide_String'First /= 1 or
+ TC_NUL_Appended_Wide_String'First /= 1
+ then
+ Report.Failed("Incorrect lower bound from Function To_Ada");
+ end if;
+
+ if TC_No_NUL_Wide_String'Length /= TC_Wide_String'Length then
+ Report.Failed("Incorrect length returned from Function " &
+ "To_Ada when Trim_Nul => True");
+ end if;
+
+ if TC_NUL_Appended_Wide_String'Length /=
+ TC_Wide_String'Length + 1
+ then
+ Report.Failed("Incorrect length returned from Function " &
+ "To_Ada when Trim_Nul => False");
+ end if;
+
+ for TC_Character in Wide_Character'('a') .. Wide_Character'('h') loop
+ if TC_No_NUL_Wide_String(j) /= TC_Character or
+ TC_NUL_Appended_Wide_String(j) /= TC_Character
+ then
+ Report.Failed("Incorrect result from To_Ada with " &
+ "char_array input, index = " &
+ Integer'Image(j));
+ end if;
+ j := j + 1;
+ end loop;
+
+ end;
+
+
+ -- Check that the function To_Ada raises Terminator_Error if the
+ -- parameter Trim_Nul is set to True, but the actual Item parameter
+ -- does not contain the wide_nul wchar_t.
+
+ begin
+ TC_Wide_String := To_Ada(TC_No_wide_nul, Trim_Nul => True);
+ Report.Failed("Terminator_Error not raised when Item " &
+ "parameter of To_Ada does not contain the " &
+ "wide_nul wchar_t, but parameter Trim_Nul " &
+ "=> True");
+ Report.Comment
+ (To_String(TC_Wide_String) & " printed to defeat optimization");
+ exception
+ when Terminator_Error => null; -- OK, expected exception.
+ when others =>
+ Report.Failed("Incorrect exception raised by function " &
+ "To_Ada when the Item parameter does not " &
+ "contain the wide_nul wchar_t, but " &
+ "parameter Trim_Nul => True");
+ end;
+
+ end;
+
+ exception
+ when The_Error : others =>
+ Report.Failed
+ ("The following exception was raised in the Test_Block: " &
+ Ada.Exceptions.Exception_Name(The_Error));
+ end Test_Block;
+
+ Report.Result;
+
+end CXB30061;
-- 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
+-- 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
+-- 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
+-- 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
+-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- TEST DESCRIPTION:
-- This test is designed to test the generic procedure Divide found in
--- package Ada.Decimal.
+-- package Ada.Decimal.
--
--- The table below attempts to portray the design approach used in this
+-- The table below attempts to portray the design approach used in this
-- test. There are three "dimensions" of concern:
-- 1) the delta value of the Quotient and Remainder types, shown as
-- column headers,
-- 2) specific choices for the Dividend and Divisor numerical values
-- (i.e., whether they yielded a repeating/non-terminating result,
--- or a terminating result ["exact"]), displayed on the left side
+-- or a terminating result ["exact"]), displayed on the left side
-- of the tables, and
-- 3) the delta for the Dividend and Divisor.
---
+--
-- Each row in the tables indicates a specific test case, showing the
-- specific quotient and remainder (under the appropriate Delta column)
-- for each combination of dividend and divisor values. Test cases
-- follow the top-to-bottom sequence shown in the tables.
---
+--
-- Most of the test case sets (same dividend/divisor combinations -
--- indicated by dashed horizontal lines in the tables) vary the
--- delta of the quotient and remainder types between test cases. This
+-- indicated by dashed horizontal lines in the tables) vary the
+-- delta of the quotient and remainder types between test cases. This
-- allows for an examination of how different deltas for a quotient
-- and/or remainder type can influence the results of a division with
-- identical dividend and divisor.
---
+--
-- Note: Test cases are performed for both Radix 10 and Radix 2 types.
---
---
+--
+--
-- Divid Divis Delta Delta Delta Delta Delta
-- (Delta)(Delta)| .1 | .01 | .001 | .0001 | .00001 |Test
-- |---|---|-----|-----|-----|-----|-----|-----|-----|-----|Case
-- ---------------------------------------------------------------------------
-- Divide by Zero| Raise Constraint_Error 41
-- ---------------------------------------------------------------------------
---
---
+--
+--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 29 Dec 94 SAIC Modified Radix 2 cases to match Radix 10 cases.
--- 03 Oct 95 RBKD Modified to fix incorrect remainder results
+-- 03 Oct 95 RBKD Modified to fix incorrect remainder results.
-- 15 Nov 95 SAIC Incorporated reviewer fixes for ACVC 2.0.1.
---
+-- 18 Dec 06 RLB Fixed failure message to have correct block name.
--!
with Report;
-- Declare all types and variables used in the various blocks below
-- for all Radix 10 evaluations.
- type DT_1 is delta 1.0 digits 5;
- type DT_0_1 is delta 0.1 digits 10;
- type DT_0_01 is delta 0.01 digits 10;
- type DT_0_001 is delta 0.001 digits 10;
- type DT_0_0001 is delta 0.0001 digits 10;
- type DT_0_00001 is delta 0.00001 digits 10;
+ type DT_1 is delta 1.0 digits 5;
+ type DT_0_1 is delta 0.1 digits 10;
+ type DT_0_01 is delta 0.01 digits 10;
+ type DT_0_001 is delta 0.001 digits 10;
+ type DT_0_0001 is delta 0.0001 digits 10;
+ type DT_0_00001 is delta 0.00001 digits 10;
for DT_1'Machine_Radix use 10;
for DT_0_1'Machine_Radix use 10;
Dd_0_0001, Dv_0_0001, Quot_0_0001, Rem_0_0001 : DT_0_0001 := 0.0;
Dd_0_00001, Dv_0_00001, Quot_0_00001, Rem_0_00001 : DT_0_00001 := 0.0;
- begin
+ begin
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(Dividend_Type => DT_0_01,
Divisor_Type => DT_0_1,
Quotient_Type => DT_0_1,
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_1, DT_0_1);
begin
if TC_Verbose then Report.Comment("Case 2"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_01, DT_0_001);
begin
if TC_Verbose then Report.Comment("Case 3"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_01, DT_0_01);
begin
if TC_Verbose then Report.Comment("Case 4"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_001, DT_0_0001);
begin
if TC_Verbose then Report.Comment("Case 5"); end if;
Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3);
Div(Dd_0_01, Dv_0_1, Quot_0_001, Rem_0_0001);
- if Quot_0_001 /= DT_0_001(0.166) or
- Rem_0_0001 /= DT_0_0001(0.0002)
+ if Quot_0_001 /= DT_0_001(0.166) or
+ Rem_0_0001 /= DT_0_0001(0.0002)
then
Report.Failed("Incorrect values returned, Case 5");
end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_0001);
begin
if TC_Verbose then Report.Comment("Case 6"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_001);
begin
if TC_Verbose then Report.Comment("Case 7"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_01);
begin
if TC_Verbose then Report.Comment("Case 8"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_001, DT_0_001);
begin
if TC_Verbose then Report.Comment("Case 9"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_001, DT_0_01);
begin
if TC_Verbose then Report.Comment("Case 10"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_0001, DT_0_0001);
begin
if TC_Verbose then Report.Comment("Case 11"); end if;
Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
Div(Dd_0_01, Dv_1, Quot_0_0001, Rem_0_0001);
- if Quot_0_0001 /= DT_0_0001(0.0075) or
- Rem_0_0001 /= DT_0_0001(0.0)
+ if Quot_0_0001 /= DT_0_0001(0.0075) or
+ Rem_0_0001 /= DT_0_0001(0.0)
then
Report.Failed("Incorrect values returned, Case 11");
end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_0001, DT_0_0001);
begin
if TC_Verbose then Report.Comment("Case 12"); end if;
Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
Div(Dd_0_00001, Dv_0_1, Quot_0_0001, Rem_0_0001);
- if Quot_0_0001 /= DT_0_0001(0.0625) or
- Rem_0_0001 /= DT_0_0001(0.0)
+ if Quot_0_0001 /= DT_0_0001(0.0625) or
+ Rem_0_0001 /= DT_0_0001(0.0)
then
Report.Failed("Incorrect values returned, Case 12");
end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_00001);
begin
if TC_Verbose then Report.Comment("Case 13"); end if;
Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_00001);
- if Quot_0_001 /= DT_0_001(0.062) or
+ if Quot_0_001 /= DT_0_001(0.062) or
Rem_0_00001 /= DT_0_00001(0.00025)
then
Report.Failed("Incorrect values returned, Case 13");
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_0001);
begin
if TC_Verbose then Report.Comment("Case 14"); end if;
Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_0001);
- if Quot_0_001 /= DT_0_001(0.062) or
+ if Quot_0_001 /= DT_0_001(0.062) or
Rem_0_0001 /= DT_0_0001(0.0002)
then
Report.Failed("Incorrect values returned, Case 14");
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_001);
begin
if TC_Verbose then Report.Comment("Case 15"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_01);
begin
if TC_Verbose then Report.Comment("Case 16"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_00001);
begin
if TC_Verbose then Report.Comment("Case 17"); end if;
Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_00001);
- if Quot_0_01 /= DT_0_01(0.06) or Rem_0_00001 /= DT_0_00001(0.00125)
+ if Quot_0_01 /= DT_0_01(0.06) or Rem_0_00001 /= DT_0_00001(0.00125)
then
Report.Failed("Incorrect values returned, Case 17");
end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_0001);
begin
if TC_Verbose then Report.Comment("Case 18"); end if;
Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_0001);
- if Quot_0_01 /= DT_0_01(0.06) or Rem_0_0001 /= DT_0_0001(0.0012)
+ if Quot_0_01 /= DT_0_01(0.06) or Rem_0_0001 /= DT_0_0001(0.0012)
then
Report.Failed("Incorrect values returned, Case 18");
end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_001);
begin
if TC_Verbose then Report.Comment("Case 19"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_01);
begin
if TC_Verbose then Report.Comment("Case 20"); end if;
-- Declare all types and variables used in the various blocks below
-- for all Radix 2 evaluations.
- type DT_1 is delta 1.0 digits 5;
- type DT_0_1 is delta 0.1 digits 10;
- type DT_0_01 is delta 0.01 digits 10;
- type DT_0_001 is delta 0.001 digits 10;
- type DT_0_0001 is delta 0.0001 digits 10;
- type DT_0_00001 is delta 0.00001 digits 10;
+ type DT_1 is delta 1.0 digits 5;
+ type DT_0_1 is delta 0.1 digits 10;
+ type DT_0_01 is delta 0.01 digits 10;
+ type DT_0_001 is delta 0.001 digits 10;
+ type DT_0_0001 is delta 0.0001 digits 10;
+ type DT_0_00001 is delta 0.00001 digits 10;
for DT_1'Machine_Radix use 2;
for DT_0_1'Machine_Radix use 2;
Dd_0_0001, Dv_0_0001, Quot_0_0001, Rem_0_0001 : DT_0_0001 := 0.0;
Dd_0_00001, Dv_0_00001, Quot_0_00001, Rem_0_00001 : DT_0_00001 := 0.0;
- begin
+ begin
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(Dividend_Type => DT_0_01,
Divisor_Type => DT_0_1,
Quotient_Type => DT_0_1,
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_1, DT_0_1);
begin
if TC_Verbose then Report.Comment("Case 22"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_01, DT_0_001);
begin
if TC_Verbose then Report.Comment("Case 23"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_01, DT_0_01);
begin
if TC_Verbose then Report.Comment("Case 24"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_001, DT_0_0001);
begin
if TC_Verbose then Report.Comment("Case 25"); end if;
Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3);
Div(Dd_0_01, Dv_0_1, Quot_0_001, Rem_0_0001);
- if Quot_0_001 /= DT_0_001(0.166) or
- Rem_0_0001 /= DT_0_0001(0.0002)
+ if Quot_0_001 /= DT_0_001(0.166) or
+ Rem_0_0001 /= DT_0_0001(0.0002)
then
Report.Failed("Incorrect values returned, Case 25");
end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_0001);
begin
if TC_Verbose then Report.Comment("Case 26"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_001);
begin
if TC_Verbose then Report.Comment("Case 27"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_01);
begin
if TC_Verbose then Report.Comment("Case 28"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_001, DT_0_001);
begin
if TC_Verbose then Report.Comment("Case 29"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_001, DT_0_01);
begin
if TC_Verbose then Report.Comment("Case 30"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_0001, DT_0_0001);
begin
if TC_Verbose then Report.Comment("Case 31"); end if;
Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
Div(Dd_0_01, Dv_1, Quot_0_0001, Rem_0_0001);
- if Quot_0_0001 /= DT_0_0001(0.0075) or
- Rem_0_0001 /= DT_0_0001(0.0)
+ if Quot_0_0001 /= DT_0_0001(0.0075) or
+ Rem_0_0001 /= DT_0_0001(0.0)
then
Report.Failed("Incorrect values returned, Case 31");
end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_0001, DT_0_0001);
begin
if TC_Verbose then Report.Comment("Case 32"); end if;
Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
Div(Dd_0_00001, Dv_0_1, Quot_0_0001, Rem_0_0001);
- if Quot_0_0001 /= DT_0_0001(0.0625) or
- Rem_0_0001 /= DT_0_0001(0.0)
+ if Quot_0_0001 /= DT_0_0001(0.0625) or
+ Rem_0_0001 /= DT_0_0001(0.0)
then
Report.Failed("Incorrect values returned, Case 32");
end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_00001);
begin
if TC_Verbose then Report.Comment("Case 33"); end if;
Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_00001);
- if Quot_0_001 /= DT_0_001(0.062) or
+ if Quot_0_001 /= DT_0_001(0.062) or
Rem_0_00001 /= DT_0_00001(0.00025)
then
Report.Failed("Incorrect values returned, Case 33");
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_0001);
begin
if TC_Verbose then Report.Comment("Case 34"); end if;
Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_0001);
- if Quot_0_001 /= DT_0_001(0.062) or
+ if Quot_0_001 /= DT_0_001(0.062) or
Rem_0_0001 /= DT_0_0001(0.0002)
then
Report.Failed("Incorrect values returned, Case 34");
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_001);
begin
if TC_Verbose then Report.Comment("Case 35"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_01);
begin
if TC_Verbose then Report.Comment("Case 36"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_00001);
begin
if TC_Verbose then Report.Comment("Case 37"); end if;
Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_00001);
- if Quot_0_01 /= DT_0_01(0.06) or Rem_0_00001 /= DT_0_00001(0.00125)
+ if Quot_0_01 /= DT_0_01(0.06) or Rem_0_00001 /= DT_0_00001(0.00125)
then
Report.Failed("Incorrect values returned, Case 37");
end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_0001);
begin
if TC_Verbose then Report.Comment("Case 38"); end if;
Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_0001);
- if Quot_0_01 /= DT_0_01(0.06) or Rem_0_0001 /= DT_0_0001(0.0012)
+ if Quot_0_01 /= DT_0_01(0.06) or Rem_0_0001 /= DT_0_0001(0.0012)
then
Report.Failed("Incorrect values returned, Case 38");
end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_001);
begin
if TC_Verbose then Report.Comment("Case 39"); end if;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_01);
begin
if TC_Verbose then Report.Comment("Case 40"); end if;
end;
declare
- procedure Div is
+ procedure Div is
new Ada.Decimal.Divide(DT_0_0001, DT_1, DT_0_0001, DT_0_0001);
begin
if TC_Verbose then Report.Comment("Case 41"); end if;
- Dd_0_0001 := (DT_0_0001(6062.0) / DT_0_0001(16384.0));
+ Dd_0_0001 := (DT_0_0001(6062.0) / DT_0_0001(16384.0));
Dv_1 := DT_1(0.0);
Div(Dd_0_0001, Dv_1, Quot_0_0001, Rem_0_0001);
Report.Failed("Divide by Zero didn't raise Constraint_Error, " &
"Case 41");
exception
when Constraint_Error => null; -- OK, expected exception.
- when others =>
+ when others =>
Report.Failed("Unexpected exception raised by Divide by Zero," &
"Case 41");
end;
exception
- when others => Report.Failed("Exception raised in Radix_10_Block");
+ when others => Report.Failed("Exception raised in Radix_2_Block");
end Radix_2_Block;
projects / thirdparty / gcc.git / commitdiff
