From: Eric Botcazou Date: Wed, 2 Dec 2020 15:40:32 +0000 (+0100) Subject: Upgrade ACATS testsuite to latest ACATS 2.6 X-Git-Tag: basepoints/gcc-12~2592 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=f0a2d11f8ad85bfdedb79bc47bd34bd08e38f81f;p=thirdparty%2Fgcc.git Upgrade ACATS testsuite to latest ACATS 2.6 This upgrades the ACATS tesuite present in ada/acats from 2.5 to latest 2.6, removing 3 tests and adding 11 tests, some of them written very recently. gcc/testsuite/ChangeLog: * ada/acats/support/acats25.lst: Delete. * ada/acats/support/acats26.lst: New file. * ada/acats/support/fcndecl.ada: Minor tweak. * ada/acats/support/impdef.a: Add commentary. * ada/acats/support/impdefg.a (Negative_Zero return): Simplify. * ada/acats/support/macro.dfs (TASK_STORAGE_SIZE): Bump. * ada/acats/support/repbody.ada: Upgrade to ACATS 2.6. * ada/acats/support/tctouch.ada: Likewise. * ada/acats/tests/c3/c352001.a: New file. * ada/acats/tests/c4/c433001.a: Correct error messages. * ada/acats/tests/c4/c453001.a: New file. * ada/acats/tests/c4/c45622a.ada: Delete. * ada/acats/tests/c4/c45624a.ada: Likewise. * ada/acats/tests/c4/c45624b.ada: Likewise. * ada/acats/tests/c4/c460013.a: New file. * ada/acats/tests/c4/c460014.a: Likewise. * ada/acats/tests/c6/c620001.a: Likewise. * ada/acats/tests/c6/c620002.a: Likewise. * ada/acats/tests/c7/c761006.a: Redo Unchecked_Deallocation case. * ada/acats/tests/c9/c96004a.ada: Adjust for Ada 2005. * ada/acats/tests/c9/c96007a.ada: Likewise. * ada/acats/tests/cb/cb41004.a: Adjust for AI95-0044. * ada/acats/tests/cc/cc3016f.ada: Minor tweak. * ada/acats/tests/cd/cd30011.a: New file. * ada/acats/tests/cd/cd30012.a: Likewise. * ada/acats/tests/cd/cd90001.a: Fix comparison. * ada/acats/tests/cxa/cxa3004.a: New file. * ada/acats/tests/cxa/cxa5013.a: Likewise. * ada/acats/tests/cxa/cxac005.a: Adjust for return-by-reference. * ada/acats/tests/cxb/cxb30061.am: New file. * ada/acats/tests/cxf/cxf2001.a: Fix failure message. --- diff --git a/gcc/testsuite/ada/acats/support/acats25.lst b/gcc/testsuite/ada/acats/support/acats26.lst similarity index 99% rename from gcc/testsuite/ada/acats/support/acats25.lst rename to gcc/testsuite/ada/acats/support/acats26.lst index 0133ed378a23..d99145eb5afc 100644 --- a/gcc/testsuite/ada/acats/support/acats25.lst +++ b/gcc/testsuite/ada/acats/support/acats26.lst @@ -462,6 +462,7 @@ b460001.a b460002.a b460004.a b460005.a +b460006.a b46002a.ada b46003a.ada b46004a.ada @@ -846,6 +847,7 @@ b85015a.ada b8510010.a b8510011.a b8510012.am +b854001.a b86001a0.ada b86001a1.ada b87b23b.ada @@ -1517,6 +1519,7 @@ bd8004b.tst bd8004c.tst bdb0a01.a bdd2001.a +bdd2002.a bde0001.a bde0002.a bde0003.a @@ -1525,6 +1528,8 @@ bde0005.a bde0006.a bde0007.a bde0008.a +bde0009.a +bde0010.a be2101e.ada be2101j.ada be2114a.ada @@ -1876,6 +1881,10 @@ c37404a.ada c37404b.ada c37405a.ada c37411a.ada +c380001.a +c380002.a +c380003.a +c380004.a c38002a.ada c38002b.ada c38005a.ada @@ -2218,6 +2227,7 @@ c45532o.dep c45532p.dep c45534b.ada c45536a.dep +c456001.a c45611a.ada c45611b.dep c45611c.dep @@ -2227,9 +2237,6 @@ c45613c.dep c45614a.ada c45614b.dep c45614c.dep -c45622a.ada -c45624a.ada -c45624b.ada c45631a.ada c45631b.dep c45631c.dep @@ -2563,6 +2570,7 @@ c761006.a c761007.a c761010.a c761011.a +c761012.a c83007a.ada c83012d.ada c83022a.ada @@ -2639,6 +2647,7 @@ c85018b.ada c85019a.ada c854001.a c854002.a +c854003.a c86003a.ada c86004a.ada c86004b0.ada @@ -3275,6 +3284,7 @@ cc51003.a cc51004.a cc51006.a cc51007.a +cc51008.a cc51a01.a cc51b03.a cc51d01.a @@ -3293,6 +3303,7 @@ cc70b02.a cc70c01.a cc70c02.a cd10001.a +cd10002.a cd1009a.ada cd1009b.ada cd1009d.ada @@ -3466,6 +3477,9 @@ cdb0a01.a cdb0a02.a cdd1001.a cdd2001.a +cdd2a01.a +cdd2a02.a +cdd2a03.a cde0001.a ce2102a.ada ce2102b.ada @@ -4049,6 +4063,7 @@ fc70c00.a fcndecl.ada fd72a00.a fdb0a00.a +fdd2a00.a fxa5a00.a fxaca00.a fxacb00.a @@ -4200,6 +4215,15 @@ la5008f0.ada 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 diff --git a/gcc/testsuite/ada/acats/support/fcndecl.ada b/gcc/testsuite/ada/acats/support/fcndecl.ada index 53347a4ac850..eddc13743fd4 100644 --- a/gcc/testsuite/ada/acats/support/fcndecl.ada +++ b/gcc/testsuite/ada/acats/support/fcndecl.ada @@ -3,22 +3,22 @@ -- 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. --* diff --git a/gcc/testsuite/ada/acats/support/impdef.a b/gcc/testsuite/ada/acats/support/impdef.a index 9c23d0b7f767..ca02a7ae2fa1 100644 --- a/gcc/testsuite/ada/acats/support/impdef.a +++ b/gcc/testsuite/ada/acats/support/impdef.a @@ -105,6 +105,9 @@ package ImpDef is 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; --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- @@ -119,6 +122,9 @@ package ImpDef is 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; --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- @@ -208,7 +214,7 @@ package ImpDef is -- CD30005_1_Foreign_Address : constant System.Address:= -- System.Storage_Elements.To_Address ( 16#0000_0000# ) - -- --MODIFY HERE AS REQUIRED --- ^^^^^^^^^^^^^ + -- MODIFY HERE AS REQUIRED --- ^^^^^^^^^^^^^ --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- @@ -337,11 +343,14 @@ package ImpDef is -- 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; diff --git a/gcc/testsuite/ada/acats/support/impdefg.a b/gcc/testsuite/ada/acats/support/impdefg.a index 459ba9c9462a..6afc7cd3ca7c 100644 --- a/gcc/testsuite/ada/acats/support/impdefg.a +++ b/gcc/testsuite/ada/acats/support/impdefg.a @@ -60,24 +60,31 @@ end ImpDef.Annex_G; 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; - diff --git a/gcc/testsuite/ada/acats/support/macro.dfs b/gcc/testsuite/ada/acats/support/macro.dfs index e3c55596f259..c0acaf104b14 100644 --- a/gcc/testsuite/ada/acats/support/macro.dfs +++ b/gcc/testsuite/ada/acats/support/macro.dfs @@ -244,7 +244,7 @@ MIN_INT ACATS4GNATMININT -- 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 @@ -277,7 +277,7 @@ TASK_SIZE ACATS4GNATBIT -- 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 @@ -298,4 +298,3 @@ VARIABLE_ADDRESS1 VAR_ADDR1 -- THE MACROS $VARIABLE_ADDRESS AND $VARIABLE_ADDRESS1. -- USED IN: SPPRT13SP VARIABLE_ADDRESS2 VAR_ADDR2 - diff --git a/gcc/testsuite/ada/acats/support/repbody.ada b/gcc/testsuite/ada/acats/support/repbody.ada index dd5c53b900fa..d7b9fe022cba 100644 --- a/gcc/testsuite/ada/acats/support/repbody.ada +++ b/gcc/testsuite/ada/acats/support/repbody.ada @@ -57,7 +57,8 @@ -- 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; @@ -80,7 +81,7 @@ PACKAGE BODY REPORT IS - 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 diff --git a/gcc/testsuite/ada/acats/support/tctouch.ada b/gcc/testsuite/ada/acats/support/tctouch.ada index 8fd4f001400c..83f12543e0a0 100644 --- a/gcc/testsuite/ada/acats/support/tctouch.ada +++ b/gcc/testsuite/ada/acats/support/tctouch.ada @@ -93,11 +93,12 @@ -- 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 ); diff --git a/gcc/testsuite/ada/acats/tests/c3/c352001.a b/gcc/testsuite/ada/acats/tests/c3/c352001.a new file mode 100644 index 000000000000..04b094f1ff36 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c352001.a @@ -0,0 +1,270 @@ +-- +-- 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; diff --git a/gcc/testsuite/ada/acats/tests/c4/c433001.a b/gcc/testsuite/ada/acats/tests/c4/c433001.a index 613b688c8ca2..305e010b930f 100644 --- a/gcc/testsuite/ada/acats/tests/c4/c433001.a +++ b/gcc/testsuite/ada/acats/tests/c4/c433001.a @@ -36,6 +36,7 @@ -- -- HISTORY: -- 16 DEC 1999 RLB Initial Version. +-- 20 JAN 2009 RLB Corrected error messages. with Report; procedure C433001 is @@ -82,10 +83,10 @@ 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; @@ -104,10 +105,10 @@ procedure C433001 is 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; diff --git a/gcc/testsuite/ada/acats/tests/c4/c453001.a b/gcc/testsuite/ada/acats/tests/c4/c453001.a new file mode 100644 index 000000000000..53f458464c50 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c453001.a @@ -0,0 +1,236 @@ +-- 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; + diff --git a/gcc/testsuite/ada/acats/tests/c4/c45622a.ada b/gcc/testsuite/ada/acats/tests/c4/c45622a.ada deleted file mode 100644 index 42f02045f178..000000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c45622a.ada +++ /dev/null @@ -1,83 +0,0 @@ --- 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; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45624a.ada b/gcc/testsuite/ada/acats/tests/c4/c45624a.ada deleted file mode 100644 index 32ba4c07a697..000000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c45624a.ada +++ /dev/null @@ -1,86 +0,0 @@ --- 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; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45624b.ada b/gcc/testsuite/ada/acats/tests/c4/c45624b.ada deleted file mode 100644 index c7bd592d6f6c..000000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c45624b.ada +++ /dev/null @@ -1,81 +0,0 @@ --- 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; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460013.a b/gcc/testsuite/ada/acats/tests/c4/c460013.a new file mode 100644 index 000000000000..7644f88594d4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460013.a @@ -0,0 +1,188 @@ +-- 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; + diff --git a/gcc/testsuite/ada/acats/tests/c4/c460014.a b/gcc/testsuite/ada/acats/tests/c4/c460014.a new file mode 100644 index 000000000000..59a95d95873a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460014.a @@ -0,0 +1,289 @@ +-- 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; diff --git a/gcc/testsuite/ada/acats/tests/c6/c620001.a b/gcc/testsuite/ada/acats/tests/c6/c620001.a new file mode 100644 index 000000000000..0f854d198c76 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c620001.a @@ -0,0 +1,340 @@ +-- 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; diff --git a/gcc/testsuite/ada/acats/tests/c6/c620002.a b/gcc/testsuite/ada/acats/tests/c6/c620002.a new file mode 100644 index 000000000000..b46a04ecb801 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c620002.a @@ -0,0 +1,509 @@ +-- 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; diff --git a/gcc/testsuite/ada/acats/tests/c7/c761006.a b/gcc/testsuite/ada/acats/tests/c7/c761006.a index 771e625d10f6..5cf4d8995368 100644 --- a/gcc/testsuite/ada/acats/tests/c7/c761006.a +++ b/gcc/testsuite/ada/acats/tests/c7/c761006.a @@ -55,6 +55,9 @@ -- 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. -- --! @@ -346,23 +349,39 @@ procedure C761006 is -- 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 @@ -373,10 +392,12 @@ procedure C761006 is 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; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96004a.ada b/gcc/testsuite/ada/acats/tests/c9/c96004a.ada index f5357fc5130e..b1f769b3375a 100644 --- a/gcc/testsuite/ada/acats/tests/c9/c96004a.ada +++ b/gcc/testsuite/ada/acats/tests/c9/c96004a.ada @@ -3,22 +3,22 @@ -- 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. --* @@ -35,6 +35,8 @@ -- 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; @@ -92,15 +94,35 @@ BEGIN 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; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96007a.ada b/gcc/testsuite/ada/acats/tests/c9/c96007a.ada index beda25fd5e83..15ac5e9b7ed3 100644 --- a/gcc/testsuite/ada/acats/tests/c9/c96007a.ada +++ b/gcc/testsuite/ada/acats/tests/c9/c96007a.ada @@ -3,22 +3,22 @@ -- 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. --* @@ -27,7 +27,9 @@ -- (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; @@ -136,13 +138,13 @@ BEGIN 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 diff --git a/gcc/testsuite/ada/acats/tests/cb/cb41004.a b/gcc/testsuite/ada/acats/tests/cb/cb41004.a index 5a7b704949ff..b73ed8fcf148 100644 --- a/gcc/testsuite/ada/acats/tests/cb/cb41004.a +++ b/gcc/testsuite/ada/acats/tests/cb/cb41004.a @@ -56,10 +56,8 @@ -- 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; @@ -96,6 +94,29 @@ begin 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 @@ -135,26 +156,30 @@ 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 diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada b/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada index 9a1f099c1c92..ef94672086d3 100644 --- a/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada +++ b/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada @@ -3,26 +3,25 @@ -- 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 diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30011.a b/gcc/testsuite/ada/acats/tests/cd/cd30011.a new file mode 100644 index 000000000000..2cd96a44b71a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd30011.a @@ -0,0 +1,155 @@ +-- 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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30012.a b/gcc/testsuite/ada/acats/tests/cd/cd30012.a new file mode 100644 index 000000000000..a55dfbd47a2a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd30012.a @@ -0,0 +1,173 @@ +-- 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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd90001.a b/gcc/testsuite/ada/acats/tests/cd/cd90001.a index bd5c070a6228..3f3bd8901528 100644 --- a/gcc/testsuite/ada/acats/tests/cd/cd90001.a +++ b/gcc/testsuite/ada/acats/tests/cd/cd90001.a @@ -3,22 +3,22 @@ -- 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. --* @@ -26,11 +26,11 @@ -- 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 @@ -61,6 +61,7 @@ -- 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 @@ -136,7 +137,7 @@ package body CD90001_0 is Report.Failed ("EU => EB conversion failed"); end if; - end loop; + end loop; end TC_Check_Case_1; procedure TC_Check_Case_2 is @@ -209,7 +210,7 @@ begin -- Main test procedure. 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; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a new file mode 100644 index 000000000000..ed2023e37e53 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a @@ -0,0 +1,235 @@ +-- 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; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5013.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5013.a new file mode 100644 index 000000000000..fe5b6e2ab936 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5013.a @@ -0,0 +1,326 @@ +-- 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; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac005.a b/gcc/testsuite/ada/acats/tests/cxa/cxac005.a index 34a971f7a513..50323576ac6a 100644 --- a/gcc/testsuite/ada/acats/tests/cxa/cxac005.a +++ b/gcc/testsuite/ada/acats/tests/cxa/cxac005.a @@ -31,6 +31,7 @@ -- 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; @@ -53,7 +54,6 @@ procedure CXAC005 is 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; @@ -93,6 +93,8 @@ procedure CXAC005 is 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); @@ -111,11 +113,6 @@ procedure CXAC005 is 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 := ""; @@ -244,6 +241,13 @@ procedure CXAC005 is 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; @@ -268,7 +272,8 @@ procedure CXAC005 is 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; @@ -320,8 +325,7 @@ begin -- 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); @@ -330,7 +334,7 @@ begin Csio.Delete (F); end; - Result; + Report.Result; exception when Incomplete => Report.Result; diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30061.am b/gcc/testsuite/ada/acats/tests/cxb/cxb30061.am new file mode 100644 index 000000000000..d31345a8eb12 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb30061.am @@ -0,0 +1,404 @@ +-- 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; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a index 96d0a0a17d3e..a9f4bb21e300 100644 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a @@ -3,22 +3,22 @@ -- 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. --* @@ -31,33 +31,33 @@ -- -- 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 @@ -88,14 +88,14 @@ -- --------------------------------------------------------------------------- -- 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; @@ -117,12 +117,12 @@ begin -- 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; @@ -138,11 +138,11 @@ begin 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, @@ -158,7 +158,7 @@ begin 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; @@ -171,7 +171,7 @@ begin 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; @@ -184,7 +184,7 @@ begin 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; @@ -197,14 +197,14 @@ begin 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; @@ -212,7 +212,7 @@ begin 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; @@ -225,7 +225,7 @@ begin 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; @@ -238,7 +238,7 @@ begin 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; @@ -251,7 +251,7 @@ begin 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; @@ -264,7 +264,7 @@ begin 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; @@ -277,14 +277,14 @@ begin 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; @@ -292,14 +292,14 @@ begin 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; @@ -307,13 +307,13 @@ begin 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"); @@ -322,13 +322,13 @@ begin 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"); @@ -337,7 +337,7 @@ begin 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; @@ -351,7 +351,7 @@ begin 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; @@ -364,13 +364,13 @@ begin 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; @@ -378,13 +378,13 @@ begin 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; @@ -392,7 +392,7 @@ begin 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; @@ -405,7 +405,7 @@ begin 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; @@ -429,12 +429,12 @@ begin -- 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; @@ -450,11 +450,11 @@ begin 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, @@ -470,7 +470,7 @@ begin 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; @@ -483,7 +483,7 @@ begin 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; @@ -496,7 +496,7 @@ begin 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; @@ -509,14 +509,14 @@ begin 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; @@ -524,7 +524,7 @@ begin 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; @@ -537,7 +537,7 @@ begin 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; @@ -550,7 +550,7 @@ begin 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; @@ -563,7 +563,7 @@ begin 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; @@ -576,7 +576,7 @@ begin 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; @@ -589,14 +589,14 @@ begin 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; @@ -604,14 +604,14 @@ begin 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; @@ -619,13 +619,13 @@ begin 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"); @@ -634,13 +634,13 @@ begin 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"); @@ -649,7 +649,7 @@ begin 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; @@ -663,7 +663,7 @@ begin 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; @@ -676,13 +676,13 @@ begin 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; @@ -690,13 +690,13 @@ begin 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; @@ -704,7 +704,7 @@ begin 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; @@ -717,7 +717,7 @@ begin 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; @@ -729,24 +729,24 @@ begin 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;