diff options
Diffstat (limited to 'gcc/testsuite')
467 files changed, 12775 insertions, 51221 deletions
diff --git a/gcc/testsuite/ChangeLog.apple-ppc b/gcc/testsuite/ChangeLog.apple-ppc new file mode 100644 index 00000000000..bdf1208eeff --- /dev/null +++ b/gcc/testsuite/ChangeLog.apple-ppc @@ -0,0 +1,10 @@ +2004-05-10 Ziemowit Laski <zlaski@apple.com> + + * g++.dg/ext/altivec-8.C: Brought over from mainline. + * gcc.apple/altivec-2.c: Remove, superceded by... + * gcc.dg/altivec-13.c: ...this, brought over from mainline. + +2004-04-29 Devang Patel <dpatel@apple.com> + + * gcc.dg/tree-ssa/copy-headers.c : Merge from lno-branch as of + 2004:04:19 00:00. diff --git a/gcc/testsuite/ChangeLog.lno b/gcc/testsuite/ChangeLog.lno new file mode 100644 index 00000000000..ae14c0750a2 --- /dev/null +++ b/gcc/testsuite/ChangeLog.lno @@ -0,0 +1,121 @@ +2004-04-15 Dorit Naishlos <dorit@il.ibm.com> + + * gcc.dg/tree-ssa-vect/tree-ssa-vect-26.c: New test. + * gcc.dg/tree-ssa-vect/tree-ssa-vect-27.c: New test. + * gcc.dg/tree-ssa-vect/tree-ssa-vect-28.c: New test. + * gcc.dg/tree-ssa-vect/tree-ssa-vect-29.c: New test. + * gcc.dg/tree-ssa-vect/tree-ssa-vect-*.c: Use -msse2 instead of -msse. + * gcc.dg/tree-ssa-vect/tree-ssa-vect-*.c: Temporarily change i*86 'run' + tests to 'compile' tests. + +2004-03-25 Sebastian Pop <sebastian.pop@ensmp.fr> + + * ssa-chrec-10.c.ddall: Classify more access tuples as + independent. + * ssa-chrec-36.c.ddall: Same. + +2004-03-11 Andrew Pinski <pinskia@physics.uc.edu> + + * gcc.dg/tree-ssa/20040308-2.c: UnXFAIL. + +2004-03-11 Andrew Pinski <apinski@apple.com> + + * gcc.dg/tree-ssa/20040308-2.c: Fix dg-final. + * gcc.dg/tree-ssa/20040308-1.c: XFAIL as the + optimizer for this testcase is disabled. + +2004-03-08 Andrew Pinski <pinskia@physics.uc.edu> + + * gcc.dg/tree-ssa/20040308-1.c: New test. + * gcc.dg/tree-ssa/20040308-2.c: New test. + * gcc.dg/tree-ssa/20040308-3.c: New test. + * gcc.dg/tree-ssa/20040308-4.c: New test. + +2004-03-03 Sebastian Pop <sebastian.pop@ensmp.fr> + + * ssa-chrec-*.c.scev: Removed. + * ssa-chrec-[54..60].c: New. + * ssa-chrec-{59, 60}.c.ddall: New. + * ssa-chrec-*.c.ddall: The analyzer don't print the array + discovery information, and this information has to go away + from the ddall files. This was one of the most varying part + of the ddall files. Maybe the base_name of the arrays has to + be removed in the same way. + * ssa-chrec-*.c: Don't scan the output for scev. Some cases + are adapted for using the elimination of checks. + +2004-02-20 Devang Patel <dpatel@apple.com> + + * testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-3.c: New test. + +2004-02-16 Devang Patel <dpatel@apple.com> + + * gcc.dg/tree-ssa-chrec/20040216-1.c: New test. + +2004-01-29 Sebastian Pop <sebastian.pop@ensmp.fr> + + * ssa-chrec-{01, 10, 30, 31, 32, 33, 34, 35, 36, 52, 53}.c: Update + comments. + * ssa-chrec-{13, 14}.c: Use call functions for avoid optimisations + touching the condition. + * ssa-chrec-{01, 06, 09, 10, 13, 14, 17, 24, 25, 26, 27, 28, 30, 33, + 36, 38, 39, 41, 43, 46, 47, 51, 52, 53}.c.scev: Adjusted. + + * ssa-chrec-10.c.ddall ssa-chrec-30.c.ddall + ssa-chrec-31.c.ddall ssa-chrec-32.c.ddall ssa-chrec-33.c.ddall + ssa-chrec-34.c.ddall ssa-chrec-35.c.ddall ssa-chrec-36.c.ddall + ssa-chrec-52.c.ddall: New files. + * ssa-chrec-10.c.alldd ssa-chrec-30.c.alldd + ssa-chrec-31.c.alldd ssa-chrec-32.c.alldd ssa-chrec-33.c.alldd + ssa-chrec-34.c.alldd ssa-chrec-35.c.alldd ssa-chrec-36.c.alldd + ssa-chrec-52.c.alldd ssa-chrec-53.c.alldd: Removed. + +2004-01-21 Sebastian Pop <s.pop@laposte.net> + + * ssa-chrec-*: Replace -fdump-scalar-evolutions with + -fdump-tree-scev. Replace -fdump-all-data-deps with + -fdump-tree-alldd. + * tree-ssa-vect-*: Use -fdump-tree-vect instead of + -fdump-tree-vect-stats. + +2004-01-15 Sebastian Pop <s.pop@laposte.net> + + * ssa-chrec-{06, 38, 42, 43}.c: Modify comments. + * ssa-chrec-{06, 07, 08, 09, 11, 12, 13, 14, 16, 18, 20, + 21, 37, 38, 39, 42, 43, 44, 45, 53}.c.scev: Adjusted. + * ssa-chrec-53.c.alldd: Adjusted. + +2004-01-12 Sebastian Pop <s.pop@laposte.net> + + * gcc.dg/tree-ssa-chrec/ssa-chrec-51.c.scev: Adjusted. + +2004-01-12 Sebastian Pop <s.pop@laposte.net> + Dorit Naishlos <dorit@il.ibm.com> + + * gcc.dg/tree-ssa-chrec/ssa-chrec-53.c: New test. + * gcc.dg/tree-ssa-chrec/ssa-chrec-53.c.scev: New. + * gcc.dg/tree-ssa-chrec/ssa-chrec-53.c.alldd: New. + +2004-01-09 Sebastian Pop <s.pop@laposte.net> + + * gcc.dg/tree-ssa-chrec/ssa-chrec-{01, 04, 06, 07, 09, 10, 17, + 18, 27, 28, 32, 33, 34, 35, 39, 41, 45, 47, 48}.c: Update comments. + * gcc.dg/tree-ssa-chrec/ssa-chrec-{01, 02, 03, 04, 05, 06, 09, + 10, 11, 17, 18, 27, 28, 30, 32, 33, 34, 35, 36, 37, 38, 39, 41, + 42, 43, 44, 45, 46, 47, 48, 49, 50}.c.scev: Adjusted. + * gcc.dg/tree-ssa-chrec/ssa-chrec-{10, 30, 31, 32, 33, 34, 35, + 36}.c.alldd: Adjusted. + * gcc.dg/tree-ssa-chrec/ssa-chrec-{51, 52}.c: New files. + * gcc.dg/tree-ssa-chrec/ssa-chrec-{51, 52}.c.scev: New. + * gcc.dg/tree-ssa-chrec/ssa-chrec-52.alldd: New. + * ChangeLog.lno: New file. + +2003-12-27 Sebastian Pop <s.pop@laposte.net> + + * gcc.dg/tree-ssa-chrec/ssa-chrec-[01..50].c : New testcases. + * gcc.dg/tree-ssa-chrec/ssa-chrec-[01..50].c.scev: Expected + outputs for the scalar evolution analyzer. + * gcc.dg/tree-ssa-chrec/ssa-chrec-{10, 30, 31, 32, 33, 34, + 35, 36}.c.alldd: Expected outputs for the data dependence analyzer. + * gcc.dg/tree-ssa-chrec/tree-ssa-scev.exp: New file. + * lib/scantree.exp (diff-tree-dumps): New procedure. diff --git a/gcc/testsuite/UNTESTABLE b/gcc/testsuite/UNTESTABLE new file mode 100644 index 00000000000..aa6053a4372 --- /dev/null +++ b/gcc/testsuite/UNTESTABLE @@ -0,0 +1,57 @@ +APPLE LOCAL file testsuite + +This file lists the markers for local changes that are by their nature +not testable, such as source code tweaks that don't directly affect +compiler behavior. Every other local change must have at least one +test case. + +Note that if a local change fixes a bug that is exposed by an existing +test, then by definition the local change should go into FSF GCC +instead of being listed here. + +APPLE LOCAL MW compatibility +APPLE LOCAL Mach time +APPLE LOCAL OS pragma hook +APPLE LOCAL RTX_COST for multiply +APPLE LOCAL Stripped encodings ('!T_' and '!t_') should match. +APPLE LOCAL branch cost +APPLE LOCAL code size reduction / performance enhancement +APPLE LOCAL combine hoisted consts +APPLE LOCAL compare >= 0, not > 0. +APPLE LOCAL darwin host +APPLE LOCAL darwin mmap bug workaround +APPLE LOCAL darwin_set_section_for_var_p +APPLE LOCAL debugging +APPLE LOCAL default to ppro +APPLE LOCAL do not extern fp save/restore +APPLE LOCAL don't define SAVE_FP_PREFIX and friends +APPLE LOCAL fat builds readability +APPLE LOCAL finish file hook +APPLE LOCAL fix prototypes +APPLE LOCAL fix redundant add? +APPLE LOCAL flag_objc +APPLE LOCAL include guard for darwin.h +APPLE LOCAL interrupt signal handler (radar 2941633) +APPLE LOCAL keep tables in sync comment +APPLE LOCAL make easy_vector_constant globally visible (rs6000-protos.h) +APPLE LOCAL manual +APPLE LOCAL more orphaned code +APPLE LOCAL move is_class_name to stub-objc.c +APPLE LOCAL move lookup_interface to stub-objc.c +APPLE LOCAL move lookup_objc_ivar to stub-objc.c +APPLE LOCAL multiply cost pulled into function +APPLE LOCAL objc finish file +APPLE LOCAL order files +APPLE LOCAL parsedir +APPLE LOCAL prototypes +APPLE LOCAL prune man page +APPLE LOCAL reduce code size +APPLE LOCAL remove a stub tweak +APPLE LOCAL remove machopic_output_possible_stub_label +APPLE LOCAL rename for HFS +APPLE LOCAL separate outputdir +APPLE LOCAL setrlimit +APPLE LOCAL time formatting +APPLE LOCAL try to improve ggc +APPLE LOCAL work around a makeinfo complaint +APPLE LOCAL cp_binding_level diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a deleted file mode 100644 index 9c7e25b977c..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a +++ /dev/null @@ -1,507 +0,0 @@ --- CXA3001.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 character classification functions defined in --- package Ada.Characters.Handling produce correct results when provided --- constant arguments from package Ada.Characters.Latin_1. --- --- TEST DESCRIPTION: --- This test checks the character classification functions of package --- Ada.Characters.Handling. In the evaluation of each function, loops --- are constructed to examine the function with as many values of type --- Character (Ada.Characters.Latin_1 constants) as possible in an --- amount of code that is about equal to the amount of code required --- to examine the function with a few representative input values and --- endpoint values. --- The usage paradigm being demonstrated by this test is that of the --- functions being used to assign to boolean variables, as well as --- serving as boolean conditions. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 29 Apr 95 SAIC Fixed subtest checking Is_Graphic function. --- ---! - -with Ada.Characters.Latin_1; -with Ada.Characters.Handling; -with Report; - -procedure CXA3001 is - -begin - - Report.Test ("CXA3001", "Check that the character classification " & - "functions defined in package " & - "Ada.Characters.Handling produce " & - "correct results when provided constant " & - "arguments from package Ada.Characters.Latin_1"); - - Test_Block: - declare - - package AC renames Ada.Characters; - package ACH renames Ada.Characters.Handling; - - TC_Boolean : Boolean := False; - - begin - - -- Over the next six statements/blocks of code, evaluate functions - -- Is_Control and Is_Graphic with control character and non-control - -- character values. - - for i in Character'Pos(AC.Latin_1.NUL) .. - Character'Pos(AC.Latin_1.US) loop - if not ACH.Is_Control(Character'Val(i)) then - Report.Failed ("Incorrect result from function Is_Control - 1"); - end if; - if ACH.Is_Graphic(Character'Val(i)) then - Report.Failed ("Incorrect result from function Is_Graphic - 1"); - end if; - end loop; - - - for i in Character'Pos(AC.Latin_1.Space) .. - Character'Pos(AC.Latin_1.Tilde) loop - if not ACH.Is_Graphic(Character'Val(i)) then - Report.Failed ("Incorrect result from function Is_Graphic - 2"); - end if; - if ACH.Is_Control(Character'Val(i)) then - Report.Failed ("Incorrect result from function Is_Control - 2"); - end if; - end loop; - - - for i in Character'Pos(AC.Latin_1.Reserved_128) .. - Character'Pos(AC.Latin_1.APC) loop - if not ACH.Is_Control(Character'Val(i)) then - Report.Failed ("Incorrect result from function Is_Control - 3"); - end if; - TC_Boolean := ACH.Is_Graphic(Character'Val(i)); - if TC_Boolean then - Report.Failed ("Incorrect result from function Is_Graphic - 3"); - TC_Boolean := False; - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.No_Break_Space) .. - Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop - TC_Boolean := ACH.Is_Control(Character'Val(i)); - if TC_Boolean then - Report.Failed ("Incorrect result from function Is_Control - 4"); - TC_Boolean := False; - end if; - if not ACH.Is_Graphic(Character'Val(i)) then - Report.Failed ("Incorrect result from function Is_Graphic - 4"); - end if; - end loop; - - -- Check renamed constants. - - if not (ACH.Is_Control(AC.Latin_1.IS4) and - ACH.Is_Control(AC.Latin_1.IS3) and - ACH.Is_Control(AC.Latin_1.IS2) and - ACH.Is_Control(AC.Latin_1.IS1)) or - (ACH.Is_Control(AC.Latin_1.NBSP) or - ACH.Is_Control(AC.Latin_1.Paragraph_Sign) or - ACH.Is_Control(AC.Latin_1.Minus_Sign) or - ACH.Is_Control(AC.Latin_1.Ring_Above)) - then - Report.Failed ("Incorrect result from function Is_Control - 5"); - end if; - - if (ACH.Is_Graphic(AC.Latin_1.IS4) or - ACH.Is_Graphic(AC.Latin_1.IS3) or - ACH.Is_Graphic(AC.Latin_1.IS2) or - ACH.Is_Graphic(AC.Latin_1.IS1)) or - not (ACH.Is_Graphic(AC.Latin_1.NBSP) and - ACH.Is_Graphic(AC.Latin_1.Paragraph_Sign) and - ACH.Is_Graphic(AC.Latin_1.Minus_Sign) and - ACH.Is_Graphic(AC.Latin_1.Ring_Above)) - then - Report.Failed ("Incorrect result from function Is_Graphic - 5"); - end if; - - - -- Evaluate function Is_Letter with letter/non-letter inputs. - - for i in Character'Pos('A') .. Character'Pos('Z') loop - if not ACH.Is_Letter(Character'Val(i)) then - Report.Failed ("Incorrect Is_Letter result - 1"); - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.LC_A) .. - Character'Pos(AC.Latin_1.LC_Z) loop - if not ACH.Is_Letter(Character'Val(i)) then - Report.Failed ("Incorrect Is_Letter result - 2"); - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.UC_A_Grave) .. - Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop - if not ACH.Is_Letter(Character'Val(i)) then - Report.Failed ("Incorrect Is_Letter result - 3"); - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) .. - Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop - if not ACH.Is_Letter(Character'Val(i)) then - Report.Failed ("Incorrect Is_Letter result - 4"); - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) .. - Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop - if not ACH.Is_Letter(Character'Val(i)) then - Report.Failed ("Incorrect Is_Letter result - 5"); - end if; - end loop; - - -- Check for rejection of non-letters. - for i in Character'Pos(AC.Latin_1.NUL) .. - Character'Pos(AC.Latin_1.Commercial_At) loop - if ACH.Is_Letter(Character'Val(i)) then - Report.Failed ("Incorrect Is_Letter result - 6"); - end if; - end loop; - - - -- Evaluate function Is_Lower with lower case/non-lower case inputs. - - for i in Character'Pos(AC.Latin_1.LC_A) .. - Character'Pos(AC.Latin_1.LC_Z) loop - if not ACH.Is_Lower(Character'Val(i)) then - Report.Failed ("Incorrect Is_Lower result - 1"); - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.LC_A_Grave) .. - Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop - if not ACH.Is_Lower(Character'Val(i)) then - Report.Failed ("Incorrect Is_Lower result - 2"); - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) .. - Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop - if not ACH.Is_Lower(Character'Val(i)) then - Report.Failed ("Incorrect Is_Lower result - 3"); - end if; - end loop; - - if ACH.Is_Lower('A') or - ACH.Is_Lower(AC.Latin_1.UC_Icelandic_Eth) or - ACH.Is_Lower(AC.Latin_1.Number_Sign) or - ACH.Is_Lower(AC.Latin_1.Cedilla) or - ACH.Is_Lower(AC.Latin_1.SYN) or - ACH.Is_Lower(AC.Latin_1.ESA) - then - Report.Failed ("Incorrect Is_Lower result - 4"); - end if; - - - -- Evaluate function Is_Upper with upper case/non-upper case inputs. - - for i in Character'Pos('A') .. Character'Pos('Z') loop - if not ACH.Is_Upper(Character'Val(i)) then - Report.Failed ("Incorrect Is_Upper result - 1"); - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.UC_A_Grave) .. - Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop - if not ACH.Is_Upper(Character'Val(i)) then - Report.Failed ("Incorrect Is_Upper result - 2"); - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) .. - Character'Pos(AC.Latin_1.UC_Icelandic_Thorn) loop - if not ACH.Is_Upper(Character'Val(i)) then - Report.Failed ("Incorrect Is_Upper result - 3"); - end if; - end loop; - - if ACH.Is_Upper('8') or - ACH.Is_Upper(AC.Latin_1.LC_A_Ring ) or - ACH.Is_Upper(AC.Latin_1.Dollar_Sign) or - ACH.Is_Upper(AC.Latin_1.Broken_Bar) or - ACH.Is_Upper(AC.Latin_1.ETB) or - ACH.Is_Upper(AC.Latin_1.VTS) - then - Report.Failed ("Incorrect Is_Upper result - 4"); - end if; - - - for i in Character'Pos('a') .. Character'Pos('z') loop - if ACH.Is_Upper(Character'Val(i)) then - Report.Failed ("Incorrect Is_Upper result - 5"); - end if; - end loop; - - - -- Evaluate function Is_Basic with basic/non-basic inputs. - -- (Note: Basic letters are those without diacritical marks.) - - for i in Character'Pos('A') .. Character'Pos('Z') loop - if not ACH.Is_Basic(Character'Val(i)) then - Report.Failed ("Incorrect Is_Basic result - 1"); - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.LC_A) .. - Character'Pos(AC.Latin_1.LC_Z) loop - if not ACH.Is_Basic(Character'Val(i)) then - Report.Failed ("Incorrect Is_Basic result - 2"); - end if; - end loop; - - - if not (ACH.Is_Basic(AC.Latin_1.UC_AE_Diphthong) and - ACH.Is_Basic(AC.Latin_1.LC_AE_Diphthong) and - ACH.Is_Basic(AC.Latin_1.LC_German_Sharp_S) and - ACH.Is_Basic(AC.Latin_1.LC_Icelandic_Eth) and - ACH.Is_Basic(AC.Latin_1.LC_Icelandic_Thorn) and - ACH.Is_Basic(AC.Latin_1.UC_Icelandic_Eth) and - ACH.Is_Basic(AC.Latin_1.UC_Icelandic_Thorn)) - then - Report.Failed ("Incorrect Is_Basic result - 3"); - end if; - - -- Check for rejection of non-basics. - if ACH.Is_Basic(AC.Latin_1.UC_A_Tilde) or - ACH.Is_Basic(AC.Latin_1.LC_A_Grave) or - ACH.Is_Basic(AC.Latin_1.Ampersand) or - ACH.Is_Basic(AC.Latin_1.Yen_Sign) or - ACH.Is_Basic(AC.Latin_1.NAK) or - ACH.Is_Basic(AC.Latin_1.SS2) - then - Report.Failed ("Incorrect Is_Basic result - 4"); - end if; - - - - for i in Character'Pos(AC.Latin_1.NUL) .. - Character'Pos(AC.Latin_1.Commercial_At) loop - if ACH.Is_Basic(Character'Val(i)) then - Report.Failed ("Incorrect Is_Basic result - 5"); - end if; - end loop; - - - -- Evaluate functions Is_Digit and Is_Decimal_Digit (a rename of - -- Is_Digit) with decimal digit/non-digit inputs. - - - if not (ACH.Is_Digit('0') and - ACH.Is_Decimal_Digit('9')) or - ACH.Is_Digit ('a') or -- Hex digits. - ACH.Is_Decimal_Digit ('f') or - ACH.Is_Decimal_Digit ('A') or - ACH.Is_Digit ('F') - then - Report.Failed ("Incorrect Is_Digit/Is_Decimal_Digit result - 1"); - end if; - - if ACH.Is_Digit (AC.Latin_1.Full_Stop) or - ACH.Is_Decimal_Digit (AC.Latin_1.Dollar_Sign) or - ACH.Is_Digit (AC.Latin_1.Number_Sign) or - ACH.Is_Decimal_Digit (AC.Latin_1.Left_Parenthesis) or - ACH.Is_Digit (AC.Latin_1.Right_Parenthesis) - then - Report.Failed ("Incorrect Is_Digit/Is_Decimal_Digit result - 2"); - end if; - - - -- Evaluate functions Is_Hexadecimal_Digit with hexadecimal digit and - -- non-hexadecimal digit inputs. - - for i in Character'Pos('0') .. Character'Pos('9') loop - if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then - Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 1"); - end if; - end loop; - - for i in Character'Pos('A') .. Character'Pos('F') loop - if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then - Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 2"); - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.LC_A) .. - Character'Pos(AC.Latin_1.LC_F) loop - if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then - Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 3"); - end if; - end loop; - - - if ACH.Is_Hexadecimal_Digit (AC.Latin_1.Minus_Sign) or - ACH.Is_Hexadecimal_Digit (AC.Latin_1.Hyphen) or - ACH.Is_Hexadecimal_Digit (AC.Latin_1.LC_G) or - ACH.Is_Hexadecimal_Digit (AC.Latin_1.LC_Z) or - ACH.Is_Hexadecimal_Digit ('G') or - ACH.Is_Hexadecimal_Digit (AC.Latin_1.Cent_Sign) or - ACH.Is_Hexadecimal_Digit (AC.Latin_1.Pound_Sign) - then - Report.Failed ("Incorrect Is_HexaDecimal_Digit result - 4"); - end if; - - - -- Evaluate functions Is_Alphanumeric and Is_Special with - -- letters, digits, and non-alphanumeric inputs. - - for i in Character'Pos(AC.Latin_1.NUL) .. - Character'Pos(AC.Latin_1.US) loop - if ACH.Is_Alphanumeric(Character'Val(i)) then - Report.Failed ("Incorrect Is_Alphanumeric result - 1"); - end if; - TC_Boolean := ACH.Is_Special(Character'Val(i)); - if TC_Boolean then - Report.Failed ("Incorrect Is_Special result - 1"); - TC_Boolean := False; - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.Reserved_128) .. - Character'Pos(AC.Latin_1.APC) loop - TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i)); - if TC_Boolean then - Report.Failed ("Incorrect Is_Alphanumeric result - 2"); - TC_Boolean := False; - end if; - if ACH.Is_Special(Character'Val(i)) then - Report.Failed ("Incorrect Is_Special result - 2"); - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.Space) .. - Character'Pos(AC.Latin_1.Solidus) loop - TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i)); - if TC_Boolean then - Report.Failed ("Incorrect Is_Alphanumeric result - 3"); - TC_Boolean := False; - end if; - if not ACH.Is_Special(Character'Val(i)) then - Report.Failed ("Incorrect Is_Special result - 3"); - end if; - end loop; - - for i in Character'Pos('A') .. Character'Pos('Z') loop - if not ACH.Is_Alphanumeric(Character'Val(i)) then - Report.Failed ("Incorrect Is_Alphanumeric result - 4"); - end if; - TC_Boolean := ACH.Is_Special(Character'Val(i)); - if TC_Boolean then - Report.Failed ("Incorrect Is_Special result - 4"); - TC_Boolean := False; - end if; - end loop; - - for i in Character'Pos('0') .. Character'Pos('9') loop - if not ACH.Is_Alphanumeric(Character'Val(i)) then - Report.Failed ("Incorrect Is_Alphanumeric result - 5"); - end if; - TC_Boolean := ACH.Is_Special(Character'Val(i)); - if TC_Boolean then - Report.Failed ("Incorrect Is_Special result - 5"); - TC_Boolean := False; - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.LC_A) .. - Character'Pos(AC.Latin_1.LC_Z) loop - if not ACH.Is_Alphanumeric(Character'Val(i)) then - Report.Failed ("Incorrect Is_Alphanumeric result - 6"); - end if; - TC_Boolean := ACH.Is_Special(Character'Val(i)); - if TC_Boolean then - Report.Failed ("Incorrect Is_Special result - 6"); - TC_Boolean := False; - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.No_Break_Space) .. - Character'Pos(AC.Latin_1.Inverted_Question) loop - TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i)); - if TC_Boolean then - Report.Failed ("Incorrect Is_Alphanumeric result - 7"); - TC_Boolean := False; - end if; - if not ACH.Is_Special(Character'Val(i)) then - Report.Failed ("Incorrect Is_Special result - 7"); - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.UC_A_Grave) .. - Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop - if not ACH.Is_Alphanumeric(Character'Val(i)) then - Report.Failed ("Incorrect Is_Alphanumeric result - 8"); - end if; - TC_Boolean := ACH.Is_Special(Character'Val(i)); - if TC_Boolean then - Report.Failed ("Incorrect Is_Special result - 8"); - TC_Boolean := False; - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) .. - Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop - if not ACH.Is_Alphanumeric(Character'Val(i)) then - Report.Failed ("Incorrect Is_Alphanumeric result - 9"); - end if; - TC_Boolean := ACH.Is_Special(Character'Val(i)); - if TC_Boolean then - Report.Failed ("Incorrect Is_Special result - 9"); - TC_Boolean := False; - end if; - end loop; - - for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) .. - Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop - if not ACH.Is_Alphanumeric(Character'Val(i)) then - Report.Failed ("Incorrect Is_Alphanumeric result - 10"); - end if; - TC_Boolean := ACH.Is_Special(Character'Val(i)); - if TC_Boolean then - Report.Failed ("Incorrect Is_Special result - 10"); - TC_Boolean := False; - end if; - end loop; - - - exception - when others => Report.Failed ("Exception raised during processing"); - end Test_Block; - - - Report.Result; - -end CXA3001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a deleted file mode 100644 index 12d98fdfe70..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a +++ /dev/null @@ -1,318 +0,0 @@ --- CXA3002.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 conversion functions for Characters and Strings --- defined in package Ada.Characters.Handling provide correct results --- when given character/string input parameters. --- --- TEST DESCRIPTION: --- This test checks the output of the To_Lower, To_Upper, and --- To_Basic functions for both Characters and Strings. Each function --- is called with input parameters that are within the appropriate --- range of values, and also with values outside the specified --- range (i.e., lower case 'a' to To_Lower). The functions are also --- used in combination with one another, with the result of one function --- providing the actual input parameter value to another. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 22 Dec 94 SAIC Corrected evaluations of Functions In Combination. --- ---! - -with Ada.Characters.Latin_1; -with Ada.Characters.Handling; -with Report; - -procedure CXA3002 is - - package AC renames Ada.Characters; - package ACH renames Ada.Characters.Handling; - -begin - - Report.Test ("CXA3002", "Check that the conversion functions for " & - "Characters and Strings defined in package " & - "Ada.Characters.Handling provide correct " & - "results when given character/string input " & - "parameters"); - - - Character_Block: - declare - Offset : constant Integer := Character'Pos('a') - Character'Pos('A'); - begin - - -- Function To_Lower for Characters - - if ACH.To_Lower('A') /= 'a' or ACH.To_Lower('Z') /= 'z' then - Report.Failed ("Incorrect operation of function To_Lower - 1"); - end if; - - - for i in Character'Pos('A') .. Character'Pos('Z') loop - if ACH.To_Lower(Character'Val(i)) /= Character'Val(i + Offset) then - Report.Failed ("Incorrect operation of function To_Lower - 2"); - end if; - end loop; - - - if (ACH.To_Lower(AC.Latin_1.UC_A_Grave) /= - AC.Latin_1.LC_A_Grave) or - (ACH.To_Lower(AC.Latin_1.UC_Icelandic_Thorn) /= - AC.Latin_1.LC_Icelandic_Thorn) - then - Report.Failed ("Incorrect operation of function To_Lower - 3"); - end if; - - - if ACH.To_Lower('c') /= 'c' or - ACH.To_Lower('w') /= 'w' or - ACH.To_Lower(AC.Latin_1.CR) /= AC.Latin_1.CR or - ACH.To_Lower(AC.Latin_1.LF) /= AC.Latin_1.LF or - ACH.To_Lower(AC.Latin_1.Comma) /= AC.Latin_1.Comma or - ACH.To_Lower(AC.Latin_1.Question) /= AC.Latin_1.Question or - ACH.To_Lower('0') /= '0' or - ACH.To_Lower('9') /= '9' - then - Report.Failed ("Incorrect operation of function To_Lower - 4"); - end if; - - - --- Function To_Upper for Characters - - - if not (ACH.To_Upper('b') = 'B') and (ACH.To_Upper('y') = 'Y') then - Report.Failed ("Incorrect operation of function To_Upper - 1"); - end if; - - - for i in Character'Pos(AC.Latin_1.LC_A) .. - Character'Pos(AC.Latin_1.LC_Z) loop - if ACH.To_Upper(Character'Val(i)) /= Character'Val(i - Offset) then - Report.Failed ("Incorrect operation of function To_Upper - 2"); - end if; - end loop; - - - if (ACH.To_Upper(AC.Latin_1.LC_U_Diaeresis) /= - AC.Latin_1.UC_U_Diaeresis) or - (ACH.To_Upper(AC.Latin_1.LC_A_Ring) /= - AC.Latin_1.UC_A_Ring) - then - Report.Failed ("Incorrect operation of function To_Upper - 3"); - end if; - - - if not (ACH.To_Upper('F') = 'F' and - ACH.To_Upper('U') = 'U' and - ACH.To_Upper(AC.Latin_1.LC_German_Sharp_S) = - AC.Latin_1.LC_German_Sharp_S and - ACH.To_Upper(AC.Latin_1.LC_Y_Diaeresis) = - AC.Latin_1.LC_Y_Diaeresis) - then - Report.Failed ("Incorrect operation of function To_Upper - 4"); - end if; - - - --- Function To_Basic for Characters - - - if ACH.To_Basic(AC.Latin_1.LC_A_Circumflex) /= - ACH.To_Basic(AC.Latin_1.LC_A_Tilde) or - ACH.To_Basic(AC.Latin_1.LC_E_Grave) /= - ACH.To_Basic(AC.Latin_1.LC_E_Acute) or - ACH.To_Basic(AC.Latin_1.LC_I_Circumflex) /= - ACH.To_Basic(AC.Latin_1.LC_I_Diaeresis) or - ACH.To_Basic(AC.Latin_1.UC_O_Tilde) /= - ACH.To_Basic(AC.Latin_1.UC_O_Acute) or - ACH.To_Basic(AC.Latin_1.UC_U_Grave) /= - ACH.To_Basic(AC.Latin_1.UC_U_Acute) or - ACH.To_Basic(AC.Latin_1.LC_Y_Acute) /= - ACH.To_Basic(AC.Latin_1.LC_Y_Diaeresis) - then - Report.Failed ("Incorrect operation of function To_Basic - 1"); - end if; - - - if ACH.To_Basic('Y') /= 'Y' or - ACH.To_Basic(AC.Latin_1.LC_E_Acute) /= 'e' or - ACH.To_Basic('6') /= '6' or - ACH.To_Basic(AC.Latin_1.LC_R) /= 'r' - then - Report.Failed ("Incorrect operation of function To_Basic - 2"); - end if; - - - -- Using Functions (for Characters) in Combination - - - if (ACH.To_Upper(ACH.To_Lower('A')) /= 'A' ) or - (ACH.To_Upper(ACH.To_Lower(AC.Latin_1.UC_A_Acute)) /= - AC.Latin_1.UC_A_Acute ) - then - Report.Failed("Incorrect operation of functions in combination - 1"); - end if; - - - if ACH.To_Basic(ACH.To_Lower(ACH.To_Upper(AC.Latin_1.LC_U_Grave))) /= - 'u' - then - Report.Failed("Incorrect operation of functions in combination - 2"); - end if; - - - if ACH.To_Lower (ACH.To_Basic - (ACH.To_Upper(AC.Latin_1.LC_O_Diaeresis))) /= 'o' - then - Report.Failed("Incorrect operation of functions in combination - 3"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Character_Block"); - end Character_Block; - - - String_Block: - declare - - LC_String : constant String := "az" & - AC.Latin_1.LC_A_Grave & - AC.Latin_1.LC_C_Cedilla; - - UC_String : constant String := "AZ" & - AC.Latin_1.UC_A_Grave & - AC.Latin_1.UC_C_Cedilla; - - LC_Basic_String : constant String := "aei" & 'o' & 'u'; - - LC_NonBasic_String : constant String := AC.Latin_1.LC_A_Diaeresis & - AC.Latin_1.LC_E_Circumflex & - AC.Latin_1.LC_I_Acute & - AC.Latin_1.LC_O_Tilde & - AC.Latin_1.LC_U_Grave; - - UC_Basic_String : constant String := "AEIOU"; - - UC_NonBasic_String : constant String := AC.Latin_1.UC_A_Tilde & - AC.Latin_1.UC_E_Acute & - AC.Latin_1.UC_I_Grave & - AC.Latin_1.UC_O_Diaeresis & - AC.Latin_1.UC_U_Circumflex; - - LC_Special_String : constant String := "ab" & - AC.Latin_1.LC_German_Sharp_S & - AC.Latin_1.LC_Y_Diaeresis; - - UC_Special_String : constant String := "AB" & - AC.Latin_1.LC_German_Sharp_S & - AC.Latin_1.LC_Y_Diaeresis; - - begin - - -- Function To_Lower for Strings - - - if ACH.To_Lower (UC_String) /= LC_String or - ACH.To_Lower (LC_String) /= LC_String - then - Report.Failed ("Incorrect result from To_Lower for strings - 1"); - end if; - - - if ACH.To_Lower (UC_Basic_String) /= LC_Basic_String then - Report.Failed ("Incorrect result from To_Lower for strings - 2"); - end if; - - - -- Function To_Upper for Strings - - - if not (ACH.To_Upper (LC_String) = UC_String) then - Report.Failed ("Incorrect result from To_Upper for strings - 1"); - end if; - - - if ACH.To_Upper (LC_Basic_String) /= UC_Basic_String or - ACH.To_Upper (UC_String) /= UC_String - then - Report.Failed ("Incorrect result from To_Upper for strings - 2"); - end if; - - - if ACH.To_Upper (LC_Special_String) /= UC_Special_String then - Report.Failed ("Incorrect result from To_Upper for strings - 3"); - end if; - - - - -- Function To_Basic for Strings - - - if (ACH.To_Basic (LC_String) /= "azac") or - (ACH.To_Basic (UC_String) /= "AZAC") - then - Report.Failed ("Incorrect result from To_Basic for Strings - 1"); - end if; - - - if ACH.To_Basic (LC_NonBasic_String) /= LC_Basic_String then - Report.Failed ("Incorrect result from To_Basic for Strings - 2"); - end if; - - - if ACH.To_Basic (UC_NonBasic_String) /= UC_Basic_String then - Report.Failed ("Incorrect result from To_Basic for Strings - 3"); - end if; - - - -- Using Functions (for Strings) in Combination - - - if ACH.To_Upper(ACH.To_Lower(UC_Basic_String)) /= UC_Basic_String or - ACH.To_Lower(ACH.To_Upper(LC_Basic_String)) /= LC_Basic_String - then - Report.Failed ("Incorrect operation of functions in combination - 4"); - end if; - - - if (ACH.To_Basic(ACH.To_Lower(UC_NonBasic_String)) /= LC_Basic_String) or - (ACH.To_Basic(ACH.To_Upper(LC_NonBasic_String)) /= UC_Basic_String) - then - Report.Failed ("Incorrect operation of functions in combination - 5"); - end if; - - - exception - when others => Report.Failed ("Exception raised in String_Block"); - end String_Block; - - - Report.Result; - -end CXA3002; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a deleted file mode 100644 index f469ef8b539..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a +++ /dev/null @@ -1,243 +0,0 @@ --- CXA3003.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 use in classifying and converting characters between the ISO 646 --- and type Character sets produce the correct results with both --- Character and String input values. --- --- TEST DESCRIPTION: --- This test is designed to exercise the classification and conversion --- functions (between Character and ISO_646 types) found in package --- Ada.Characters.Handling. Two subprograms are defined, a procedure for --- characters, a function for strings, that will utilize these functions --- to validate and change characters in variables. In the procedure, if --- a character argument is found to be outside the subtype ISO_646, this --- character is evaluated to determine whether it is also a letter. --- If it is a letter, the character is converted to a basic character and --- returned. If it is not a letter, the character is exchanged with an --- asterisk. In the case of the function subprogram designed for strings, --- if a character component of a string argument is outside the subtype --- ISO_646, that character is substituted with an asterisk. --- --- Arguments for the defined subprograms consist of ISO_646 characters, --- non-ISO_646 characters, strings with only ISO_646 characters, and --- strings with non-ISO_646 characters. The character and string values --- are then validated to determine that the expected results were --- obtained. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 29 Apr 95 SAIC Modified identifier string lengths. --- 31 Oct 95 SAIC Update and repair for ACVC 2.0.1. --- ---! - -with Ada.Characters.Latin_1; -with Ada.Characters.Handling; -with Report; - -procedure CXA3003 is - -begin - - Report.Test ("CXA3003", "Check that the functions defined in package " & - "Ada.Characters.Handling for use in " & - "classifying and converting characters " & - "between the ISO 646 and type Character sets " & - "produce the correct results with both " & - "Character and String input values" ); - - Test_Block: - declare - - -- ISO_646 Characters - - Char_1, - TC_Char_1 : Character := Ada.Characters.Latin_1.NUL; -- Control Char - Char_2, - TC_Char_2 : Character := Ada.Characters.Latin_1.Colon; -- Graphic Char - Char_3, - TC_Char_3 : Character := '4'; - Char_4, - TC_Char_4 : Character := 'Z'; - Char_5, - TC_Char_5 : Character := Ada.Characters.Latin_1.LC_W; -- w - - New_ISO_646_Char : Character := '*'; - - - -- Non-ISO_646 Characters - - Char_Array : array (6..10) of Character := - (Ada.Characters.Latin_1.SSA, - Ada.Characters.Latin_1.Cent_Sign, - Ada.Characters.Latin_1.Cedilla, - Ada.Characters.Latin_1.UC_A_Ring, - Ada.Characters.Latin_1.LC_A_Ring); - - TC_Char : constant Character := '*'; - - -- ISO_646 Strings - - Str_1, - TC_Str_1 : String (1..5) := "ABCDE"; - - Str_2, - TC_Str_2 : String (1..5) := "#$%^&"; - - - -- Non-ISO_646 Strings - - Str_3 : String (1..8) := "$123.45" & - Ada.Characters.Latin_1.Cent_Sign; - TC_Str_3 : String (1..8) := "$123.45*"; - - Str_4 : String (1..7) := "abc" & - Ada.Characters.Latin_1.Cedilla & - "efg"; - TC_Str_4 : String (1..7) := "abc*efg"; - - Str_5 : String (1..3) := Ada.Characters.Latin_1.LC_E_Grave & - Ada.Characters.Latin_1.LC_T & - Ada.Characters.Latin_1.LC_E_Acute; - TC_Str_5 : String (1..3) := "*t*"; - - --- - - procedure Validate_Character (Char : in out Character) is - -- If parameter Char is an ISO_646 character, Char will be returned, - -- otherwise the following constant will be returned. - Star : constant Ada.Characters.Handling.ISO_646 := - Ada.Characters.Latin_1.Asterisk; - begin - if Ada.Characters.Handling.Is_ISO_646(Char) then - -- Check that the Is_ISO_646 function provide a correct result. - if Character'Pos(Char) > 127 then - Report.Failed("Is_ISO_646 returns a false positive result"); - end if; - else - if Character'Pos(Char) < 128 then - Report.Failed("Is_ISO_646 returns a false negative result"); - end if; - end if; - -- Cross-check Is_ISO_646 with To_ISO_646. '*' will be returned - -- if Char is not in the ISO_646 set. - Char := Ada.Characters.Handling.To_ISO_646(Char, Star); - exception - when others => Report.Failed ("Exception in Validate_Character"); - end Validate_Character; - - --- - - function Validate_String (Str : String) return String is - New_ISO_646_Char : constant Ada.Characters.Handling.ISO_646 := - Ada.Characters.Latin_1.Asterisk; - begin - -- Checking that the string contains non-ISO_646 characters at this - -- point is not strictly necessary, since the function To_ISO_646 - -- will perform that check as part of its processing, and would - -- return the original string if no modification were necessary. - -- However, this format allows for the testing of both functions. - - if not Ada.Characters.Handling.Is_ISO_646(Str) then - return Ada.Characters.Handling.To_ISO_646 - (Item => Str, Substitute => New_ISO_646_Char); - else - return Str; - end if; - exception - when others => Report.Failed ("Exception in Validate_String"); - return Str; - end Validate_String; - - - begin - - -- Check each character in turn, and if the character does not belong - -- to the ISO_646 subset of type Character, replace it with an - -- asterisk. If the character is a member of the subset, the character - -- should be returned unchanged. - - Validate_Character (Char_1); - Validate_Character (Char_2); - Validate_Character (Char_3); - Validate_Character (Char_4); - Validate_Character (Char_5); - - if Char_1 /= TC_Char_1 or Char_2 /= TC_Char_2 or - Char_3 /= TC_Char_3 or Char_4 /= TC_Char_4 or - Char_5 /= TC_Char_5 - then - Report.Failed ("Incorrect ISO_646 character substitution"); - end if; - - -- Non-ISO_646 characters - - for i in 6..10 loop - Validate_Character (Char_Array(i)); - end loop; - - for i in 6..10 loop - if Char_Array(i) /= TC_Char then - Report.Failed ("Character position " & Integer'Image(i) & - " not replaced correctly"); - end if; - end loop; - - - - -- Check each string, and if the string contains characters that do not - -- belong to the ISO_646 subset of type Character, replace that character - -- in the string with an asterisk. If the string is comprised of only - -- ISO_646 characters, the string should be returned unchanged. - - - Str_1 := Validate_String (Str_1); - Str_2 := Validate_String (Str_2); - Str_3 := Validate_String (Str_3); - Str_4 := Validate_String (Str_4); - Str_5 := Validate_String (Str_5); - - - if Str_1 /= TC_Str_1 or - Str_2 /= TC_Str_2 or - Str_3 /= TC_Str_3 or - Str_4 /= TC_Str_4 or - Str_5 /= TC_Str_5 - then - Report.Failed ("Incorrect ISO_646 character substitution in string"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA3003; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a deleted file mode 100644 index ed2023e37e5..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a +++ /dev/null @@ -1,235 +0,0 @@ --- 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/cxa4001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a deleted file mode 100644 index d850acd4a72..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a +++ /dev/null @@ -1,218 +0,0 @@ --- CXA4001.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 types, operations, and other entities defined within --- the package Ada.Strings.Maps are available and/or produce correct --- results. --- --- TEST DESCRIPTION: --- This test demonstrates the availability and function of the types and --- operations defined in package Ada.Strings.Maps. It demonstrates the --- use of these types and functions as they would be used in common --- programming practice. --- Character set creation, assignment, and comparison are evaluated --- in this test. Each of the functions provided in package --- Ada.Strings.Maps is utilized in creating or manipulating set objects, --- and the function results are evaluated for correctness. --- Character sequences are examined using the functions provided for --- manipulating objects of this type. Likewise, character maps are --- created, and their contents evaluated. Exception raising conditions --- from the function To_Mapping are also created. --- Note: Throughout this test, the set logical operators are printed in --- capital letters to enhance their visibility. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with Ada.Strings.Maps; -with Report; - -procedure CXA4001 is - - use Ada.Strings; - use type Maps.Character_Set; - -begin - - Report.Test ("CXA4001", "Check that the types, operations, and other " & - "entities defined within the package " & - "Ada.Strings.Maps are available and/or produce " & - "correct results"); - - Test_Block: - declare - - MidPoint_Letter : constant := 13; - Last_Letter : constant := 26; - - Vowels : constant Maps.Character_Sequence := "aeiou"; - Quasi_Vowel : constant Character := 'y'; - - Alphabet : Maps.Character_Sequence (1..Last_Letter); - Half_Alphabet : Maps.Character_Sequence (1..MidPoint_Letter); - Inverse_Alphabet : Maps.Character_Sequence (1..Last_Letter); - - Alphabet_Set, - Consonant_Set, - Vowel_Set, - Full_Vowel_Set, - First_Half_Set, - Second_Half_Set : Maps.Character_Set; - - begin - - -- Load the alphabet string for use in creating sets. - - - for i in 0..12 loop - Half_Alphabet(i+1) := Character'Val(Character'Pos('a') + i); - end loop; - - for i in 0..25 loop - Alphabet(i+1) := Character'Val(Character'Pos('a') + i); - end loop; - - - -- Initialize a series of Character_Set objects. - - Alphabet_Set := Maps.To_Set(Alphabet); - Vowel_Set := Maps.To_Set(Vowels); - Full_Vowel_Set := Vowel_Set OR Maps.To_Set(Quasi_Vowel); - Consonant_Set := Vowel_Set XOR Alphabet_Set; - - First_Half_Set := Maps.To_Set(Half_Alphabet); - Second_Half_Set := Alphabet_Set XOR First_Half_Set; - - - -- Evaluation of Set objects, operators, and functions. - - if Alphabet_Set /= (Vowel_Set OR Consonant_Set) then - Report.Failed("Incorrect set combinations using OR operator"); - end if; - - - for i in 1..5 loop - if not Maps.Is_In(Vowels(i), Vowel_Set) or - not Maps.Is_In(Vowels(i), Alphabet_Set) or - Maps.Is_In(Vowels(i), Consonant_Set) - then - Report.Failed("Incorrect function Is_In use with set " & - "combinations - " & Integer'Image(i)); - end if; - end loop; - - - if Maps.Is_Subset(Vowel_Set, First_Half_Set) or - Maps."<="(Vowel_Set, Second_Half_Set) or - not Maps.Is_Subset(Vowel_Set, Alphabet_Set) - then - Report.Failed("Incorrect set evaluation using Is_Subset function"); - end if; - - - if not (Full_Vowel_Set = Maps.To_Set("aeiouy")) then - Report.Failed("Incorrect result for ""="" set operator"); - end if; - - - if not ((Vowel_Set AND First_Half_Set) OR - (Full_Vowel_Set AND Second_Half_Set)) = Full_Vowel_Set then - Report.Failed - ("Incorrect result for AND, OR, or ""="" set operators"); - end if; - - - if (Alphabet_Set AND Maps.Null_Set) /= Maps.Null_Set or - (Alphabet_Set OR Maps.Null_Set) /= Alphabet_Set - then - Report.Failed("Incorrect result for AND or OR set operators"); - end if; - - - Vowel_Set := Full_Vowel_Set; - Vowel_Set := Vowel_Set AND (NOT Maps.To_Set(Quasi_Vowel)); - - if not (Vowels = Maps.To_Sequence(Vowel_Set)) then - Report.Failed("Incorrect Set to Sequence translation"); - end if; - - - for i in 1..26 loop - Inverse_Alphabet(i) := Alphabet(27-i); - end loop; - - declare - Inverse_Map : Maps.Character_Mapping := - Maps.To_Mapping(Alphabet, Inverse_Alphabet); - begin - if Maps.Value(Maps.Identity, 'b') /= Maps.Value(Inverse_Map,'y') - then - Report.Failed("Incorrect Inverse mapping"); - end if; - end; - - - -- Check that Translation_Error is raised when a character is - -- repeated in the parameter "From" string. - declare - Bad_Map : Maps.Character_Mapping; - begin - Bad_Map := Maps.To_Mapping(From => "aa", To => "yz"); - Report.Failed("Exception not raised with repeated character"); - exception - when Translation_Error => null; -- OK - when others => - Report.Failed("Incorrect exception raised in To_Mapping with " & - "a repeated character"); - end; - - - -- Check that Translation_Error is raised when the parameters of the - -- function To_Mapping are of unequal lengths. - declare - Bad_Map : Maps.Character_Mapping; - begin - Bad_Map := Maps.To_Mapping("abc", "yz"); - Report.Failed("Exception not raised with unequal parameter lengths"); - exception - when Translation_Error => null; -- OK - when others => - Report.Failed("Incorrect exception raised in To_Mapping with " & - "unequal parameter lengths"); - end; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a deleted file mode 100644 index 583621ab4d9..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a +++ /dev/null @@ -1,182 +0,0 @@ --- CXA4002.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 subprograms defined in package Ada.Strings.Fixed are --- available, and that they produce correct results. Specifically, --- check the subprograms Index, "*" (string constructor function), --- Count, Trim, and Replace_Slice. --- --- TEST DESCRIPTION: --- This test demonstrates how certain Fixed string functions are used --- to eliminate specific substrings from portions of text. A procedure --- is defined that will take as parameters a source string along with --- a substring that is to be completely removed from the source string. --- The source string is parsed using the Index function, and any substring --- slices are replaced in the source string by a series of X's (based on --- the length of the substring.) --- Three lines of text are provided to this procedure, and the resulting --- substitutions are compared with expected results to validate the --- string processing. --- A global accumulator is updated with the number of occurrences of the --- substring in the source string. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with Ada.Strings; -with Ada.Strings.Fixed; -with Ada.Strings.Maps; -with Report; - -procedure CXA4002 is - -begin - - Report.Test ("CXA4002", "Check that the subprograms defined in package " & - "Ada.Strings.Fixed are available, and that " & - "they produce correct results"); - - Test_Block: - declare - - TC_Total : Natural := 0; - Number_Of_Lines : constant := 3; - - type Restricted_Words_Array_Type is array (1..10) of String (1..10); - - Restricted_Words : Restricted_Words_Array_Type := - (" platoon", " marines ", " Marines ", - "north ", "south ", " east", - " beach ", " airport", "airfield ", - " road "); - - subtype Line_Of_Text_Type is String(1..25); - type Page_Of_Text_Type is array (1..Number_Of_Lines) - of Line_Of_Text_Type; - - Text_Page : Page_Of_Text_Type := ("The platoon of Marines ", - "moved south on the south ", - "road to the airfield. "); - - TC_Revised_Line_1 : constant String := "The XXXXXXX of XXXXXXX "; - TC_Revised_Line_2 : constant String := "moved XXXXX on the XXXXX "; - TC_Revised_Line_3 : constant String := "XXXX to the XXXXXXXX. "; - - --- - - procedure Censor (Source_String : in out String; - Pattern_String : in String) is - - -- Create a replacement string that is the same length as the - -- pattern string being removed. - Replacement : constant String := -- "*" - Ada.Strings.Fixed."*"(Pattern_String'Length, 'X'); - - Going : Ada.Strings.Direction := Ada.Strings.Forward; - Map : constant Ada.Strings.Maps.Character_Mapping := - Ada.Strings.Maps.Identity; - Start_Pos, - Index : Natural := Source_String'First; - - - begin -- Censor - - -- Accumulate count of total replacement operations. - - TC_Total := TC_Total + -- Count - Ada.Strings.Fixed.Count (Source => Source_String, - Pattern => Pattern_String, - Mapping => Map); - loop - - Index := Ada.Strings.Fixed.Index -- Index - (Source_String(Start_Pos..Source_String'Last), - Pattern_String, - Going, - Map); - - exit when Index = 0; -- No matches, exit loop. - - -- if a match was found, modify the substring. - Ada.Strings.Fixed.Replace_Slice -- Replace_Slice - (Source_String, - Index, - Index + Pattern_String'Length - 1, - Replacement); - Start_Pos := Index + Pattern_String'Length; - - end loop; - - end Censor; - - - begin - - -- Invoke Censor subprogram to cleanse text. - -- Loop through each line of text, and check for the presence of each - -- restricted word. - -- Use the Trim function to eliminate leading or trailing blanks from - -- the restricted word parameters. - - for Line in 1..Number_Of_Lines loop - for Word in Restricted_Words'Range loop - Censor (Text_Page(Line), - Ada.Strings.Fixed.Trim(Restricted_Words(Word), -- Trim - Ada.Strings.Both)); - end loop; - end loop; - - - -- Validate results. - - if TC_Total /= 6 then - Report.Failed ("Incorrect number of substitutions performed"); - end if; - - if Text_Page(1) /= TC_Revised_Line_1 then - Report.Failed ("Incorrect substitutions on Line 1"); - end if; - - if Text_Page(2) /= TC_Revised_Line_2 then - Report.Failed ("Incorrect substitutions on Line 2"); - end if; - - if Text_Page(3) /= TC_Revised_Line_3 then - Report.Failed ("Incorrect substitutions on Line 3"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4002; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a deleted file mode 100644 index cd57a929616..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a +++ /dev/null @@ -1,326 +0,0 @@ --- CXA4003.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 subprograms defined in package Ada.Strings.Fixed are --- available, and that they produce correct results. Specifically, --- check the subprograms Index, Index_Non_Blank, Head, Tail, Translate, --- Find_Token, Move, Overwrite, and Replace_Slice. --- --- TEST DESCRIPTION: --- This test demonstrates how certain fixed string operations could be --- used in string information processing. A procedure is defined that --- will extract portions of a 50 character string that correspond to --- certain data items (i.e., name, address, state, zip code). These --- parsed items will then be added to the appropriate fields of data --- base elements. These data base elements are then compared for --- accuracy against a similar set of predefined data base elements. --- --- A variety of fixed string processing subprograms are used in this --- test. Each parsing operation uses a different combination --- of the available subprograms to accomplish the same goal, therefore --- continuity of approach to string parsing is not seen in this test. --- However, a wide variety of possible approaches are demonstrated, while --- exercising a large number of the total predefined subprograms of --- package Ada.Strings.Fixed. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with Ada.Strings.Fixed; -with Ada.Strings.Maps; -with Report; - -procedure CXA4003 is - -begin - - Report.Test ("CXA4003", "Check that the subprograms defined in package " & - "Ada.Strings.Fixed are available, and that they " & - "produce correct results"); - - Test_Block: - declare - - Number_Of_Info_Strings : constant Natural := 3; - DB_Size : constant Natural := Number_Of_Info_Strings; - Count : Natural := 0; - Finished_Processing : Boolean := False; - Blank_String : constant String := " "; - - subtype Info_String_Type is String (1..50); - type Info_String_Storage_Type is - array (1..Number_Of_Info_Strings) of Info_String_Type; - - - subtype Name_Type is String (1..10); - subtype Street_Number_Type is String (1..5); - subtype Street_Name_Type is String (1..10); - subtype City_Type is String (1..10); - subtype State_Type is String (1..2); - subtype Zip_Code_Type is String (1..5); - - type Data_Base_Element_Type is - record - Name : Name_Type := (others => ' '); - Street_Number : Street_Number_Type := (others => ' '); - Street_Name : Street_Name_Type := (others => ' '); - City : City_Type := (others => ' '); - State : State_Type := (others => ' '); - Zip_Code : Zip_Code_Type := (others => ' '); - end record; - - type Data_Base_Type is array (1..DB_Size) of Data_Base_Element_Type; - - Data_Base : Data_Base_Type; - - --- - - Info_String_1 : Info_String_Type := - "Joe_Jones 123 Sixth_St San_Diego CA 98765"; - - Info_String_2 : Info_String_Type := - "Sam_Smith 56789 S._Seventh Carlsbad CA 92177"; - - Info_String_3 : Info_String_Type := - "Jane_Brown 1219 Info_Lane Tuscon AZ 85643"; - - - Info_Strings : Info_String_Storage_Type := (1 => Info_String_1, - 2 => Info_String_2, - 3 => Info_String_3); - - - - TC_DB_Element_1 : Data_Base_Element_Type := - ("Joe Jones ", "123 ", "Sixth St ", "San Diego ", "CA", "98765"); - - TC_DB_Element_2 : Data_Base_Element_Type := - ("Sam Smith ", "56789", "S. Seventh", "Carlsbad ", "CA", "92177"); - - TC_DB_Element_3 : Data_Base_Element_Type := - ("Jane Brown", "1219 ", "Info Lane ", "Tuscon ", "AZ", "85643"); - - TC_Data_Base : Data_Base_Type := (TC_DB_Element_1, - TC_DB_Element_2, - TC_DB_Element_3); - - --- - - - procedure Store_Information - (Info_String : in Info_String_Type; - DB_Record : in out Data_Base_Element_Type) is - - package AS renames Ada.Strings; - use type AS.Maps.Character_Set; - - UnderScore : AS.Maps.Character_Sequence := "_"; - Blank : AS.Maps.Character_Sequence := " "; - - Start, - Stop : Natural := 0; - - Underscore_to_Blank_Map : constant AS.Maps.Character_Mapping := - AS.Maps.To_Mapping(From => UnderScore, - To => Blank); - - Numeric_Set : constant AS.Maps.Character_Set := - AS.Maps.To_Set("0123456789"); - - Cal : constant AS.Maps.Character_Sequence := "CA"; - California_Set : constant AS.Maps.Character_Set := - AS.Maps.To_Set(Cal); - Arizona_Set : constant AS.Maps.Character_Set := - AS.Maps.To_Set("AZ"); - Nevada_Set : constant AS.Maps.Character_Set := - AS.Maps.To_Set("NV"); - - begin - - -- Find the starting position of the name field (first non-blank), - -- then, from that position, find the end of the name field (first - -- blank). - - Start := AS.Fixed.Index_Non_Blank(Info_String); - Stop := AS.Fixed.Index (Info_String(Start..Info_String'Length), - AS.Maps.To_Set(' '), - AS.Inside, - AS.Forward) - 1 ; - - -- Store the name field in the data base element field for "Name". - - DB_Record.Name := AS.Fixed.Head(Info_String(1..Stop), - DB_Record.Name'Length); - - -- Replace any underscore characters in the name field - -- that were used to separate first/middle/last names. - - AS.Fixed.Translate (DB_Record.Name, Underscore_to_Blank_Map); - - - -- Continue the extraction process; now find the position of - -- the street number in the string. - - Start := Stop + 1; - - AS.Fixed.Find_Token(Info_String(Start..Info_String'Length), - Numeric_Set, - AS.Inside, - Start, - Stop); - - -- Store the street number field in the appropriate data base - -- element. - -- No modification of the default parameters of procedure Move - -- is required. - - AS.Fixed.Move(Source => Info_String(Start..Stop), - Target => DB_Record.Street_Number); - - - -- Continue the extraction process; find the street name in the - -- info string. Skip blanks to the start of the street name, then - -- search for the index of the next blank character in the string. - - Start := - AS.Fixed.Index_Non_Blank(Info_String(Stop+1..Info_String'Length)); - - Stop := - AS.Fixed.Index(Info_String(Start..Info_String'Length), - Blank_String) - 1; - - -- Store the street name in the appropriate data base element field. - - AS.Fixed.Overwrite(DB_Record.Street_Name, - 1, - Info_String(Start..Stop)); - - -- Replace any underscore characters in the street name field - -- that were used as word separation. - - DB_Record.Street_Name := AS.Fixed.Translate(DB_Record.Street_Name, - Underscore_to_Blank_Map); - - - -- Continue the extraction; remove the city name from the string. - - Start := - AS.Fixed.Index_Non_Blank(Info_String(Stop+1..Info_String'Length)); - - Stop := - AS.Fixed.Index(Info_String(Start..Info_String'Length), - Blank_String) - 1; - - -- Store the city name field in the appropriate data base element. - - AS.Fixed.Replace_Slice(DB_Record.City, - 1, - DB_Record.City'Length, - Info_String(Start..Stop)); - - -- Replace any underscore characters in the city name field - -- that were used as word separation. - - AS.Fixed.Translate (DB_Record.City, Underscore_to_Blank_Map); - - - -- Continue the extraction; remove the state identifier from the - -- info string. - - Start := Stop + 1; - - AS.Fixed.Find_Token(Info_String(Start..Info_String'Length), - AS.Maps."OR"(California_Set, - AS.Maps."OR"(Nevada_Set, Arizona_Set)), - AS.Inside, - Start, - Stop); - - -- Store the state indicator into the data base element. - - AS.Fixed.Move(Source => Info_String(Start..Stop), - Target => DB_Record.State, - Drop => Ada.Strings.Right, - Justify => Ada.Strings.Left, - Pad => AS.Space); - - - -- Continue the extraction process; remove the final data item in - -- the info string, the zip code, and place it into the - -- corresponding data base element. - - DB_Record.Zip_Code := AS.Fixed.Tail(Info_String, - DB_Record.Zip_Code'Length); - - exception - when AS.Length_Error => - Report.Failed ("Length_Error raised in procedure"); - when AS.Pattern_Error => - Report.Failed ("Pattern_Error raised in procedure"); - when AS.Translation_Error => - Report.Failed ("Translation_Error raised in procedure"); - when others => - Report.Failed ("Exception raised in procedure"); - end Store_Information; - - - begin - - -- Loop thru the information strings, extract the name and address - -- information, place this info into elements of the data base. - - while not Finished_Processing loop - - Count := Count + 1; - - Store_Information (Info_Strings(Count), Data_Base(Count)); - - Finished_Processing := (Count = Number_Of_Info_Strings); - - end loop; - - - -- Verify that the string processing was successful. - - for i in 1..DB_Size loop - if Data_Base(i) /= TC_Data_Base(i) then - Report.Failed - ("Data processing error on record " & Integer'Image(i)); - end if; - end loop; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4003; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a deleted file mode 100644 index ec11f7d50f9..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a +++ /dev/null @@ -1,431 +0,0 @@ --- CXA4004.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 subprograms defined in package Ada.Strings.Fixed are --- available, and that they produce correct results. Specifically, check --- the subprograms Count, Find_Token, Index, Index_Non_Blank, and Move. --- --- TEST DESCRIPTION: --- This test, when combined with tests CXA4002,3, and 5 will provide --- thorough coverage of the functionality found in Ada.Strings.Fixed. --- This test contains many small, specific test cases, situations that --- although common in user environments, are often difficult to generate --- in large numbers in a application-based test. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 10 Apr 95 SAIC Corrected subtest for Move, Drop=Right. --- ---! - -with Report; -with Ada.Strings; -with Ada.Strings.Fixed; -with Ada.Strings.Maps; - -procedure CXA4004 is -begin - - Report.Test("CXA4004", "Check that the subprograms defined in " & - "package Ada.Strings.Fixed are available, " & - "and that they produce correct results"); - - Test_Block: - declare - - package ASF renames Ada.Strings.Fixed; - package Maps renames Ada.Strings.Maps; - - Result_String : String(1..10) := (others => Ada.Strings.Space); - - Source_String1 : String(1..5) := "abcde"; -- odd length string - Source_String2 : String(1..6) := "abcdef"; -- even length string - Source_String3 : String(1..12) := "abcdefghijkl"; - Source_String4 : String(1..12) := "abcdefghij "; -- last two ch pad - Source_String5 : String(1..12) := " cdefghijkl"; -- first two ch pad - Source_String6 : String(1..12) := "abcdefabcdef"; - - Location : Natural := 0; - Slice_Start : Positive; - Slice_End, - Slice_Count : Natural := 0; - - CD_Set : Maps.Character_Set := Maps.To_Set("cd"); - ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd"); - A_to_F_Set : Maps.Character_Set := Maps.To_Set("abcdef"); - - CD_to_XY_Map : Maps.Character_Mapping := - Maps.To_Mapping(From => "cd", To => "xy"); - - begin - - -- Procedure Move - - -- Evaluate the Procedure Move with various combinations of - -- parameters. - - -- Justify = Left (default case) - - ASF.Move(Source => Source_String1, -- "abcde" - Target => Result_String); - - if Result_String /= "abcde " then - Report.Failed("Incorrect result from Move with Justify = Left"); - end if; - - -- Justify = Right - - ASF.Move(Source => Source_String2, -- "abcdef" - Target => Result_String, - Drop => Ada.Strings.Error, - Justify => Ada.Strings.Right); - - if Result_String /= " abcdef" then - Report.Failed("Incorrect result from Move with Justify = Right"); - end if; - - -- Justify = Center (two cases, odd and even pad lengths) - - ASF.Move(Source_String1, -- "abcde" - Result_String, - Ada.Strings.Error, - Ada.Strings.Center, - 'x'); -- non-default padding. - - if Result_String /= "xxabcdexxx" then -- Unequal padding added right - Report.Failed("Incorrect result from Move with Justify = Center-1"); - end if; - - ASF.Move(Source_String2, -- "abcdef" - Result_String, - Ada.Strings.Error, - Ada.Strings.Center); - - if Result_String /= " abcdef " then -- Equal padding added on L/R. - Report.Failed("Incorrect result from Move with Justify = Center-2"); - end if; - - -- When the source string is longer than the target string, several - -- cases can be examined, with the results depending on the value of - -- the Drop parameter. - - -- Drop = Left - - ASF.Move(Source => Source_String3, -- "abcdefghijkl" - Target => Result_String, - Drop => Ada.Strings.Left); - - if Result_String /= "cdefghijkl" then - Report.Failed("Incorrect result from Move with Drop = Left"); - end if; - - -- Drop = Right - - ASF.Move(Source_String3, Result_String, Ada.Strings.Right); - - if Result_String /= "abcdefghij" then - Report.Failed("Incorrect result from Move with Drop = Right"); - end if; - - -- Drop = Error - -- The effect in this case depends on the value of the justify - -- parameter, and on whether any characters in Source other than - -- Pad would fail to be copied. - - -- Drop = Error, Justify = Left, right overflow characters are pad. - - ASF.Move(Source => Source_String4, -- "abcdefghij " - Target => Result_String, - Drop => Ada.Strings.Error, - Justify => Ada.Strings.Left); - - if not(Result_String = "abcdefghij") then -- leftmost 10 characters - Report.Failed("Incorrect result from Move with Drop = Error - 1"); - end if; - - -- Drop = Error, Justify = Right, left overflow characters are pad. - - ASF.Move(Source_String5, -- " cdefghijkl" - Result_String, - Ada.Strings.Error, - Ada.Strings.Right); - - if Result_String /= "cdefghijkl" then -- rightmost 10 characters - Report.Failed("Incorrect result from Move with Drop = Error - 2"); - end if; - - -- In other cases of Drop=Error, Length_Error is propagated, such as: - - begin - - ASF.Move(Source_String3, -- 12 characters, no Pad. - Result_String, -- 10 characters - Ada.Strings.Error, - Ada.Strings.Left); - - Report.Failed("Length_Error not raised by Move - 1"); - - exception - when Ada.Strings.Length_Error => null; -- OK - when others => - Report.Failed("Incorrect exception raised by Move - 1"); - end; - - - - -- Function Index - -- (Other usage examples of this function found in CXA4002-3.) - -- Check when the pattern is not found in the source. - - if ASF.Index("abcdef", "gh") /= 0 or - ASF.Index("abcde", "abcdef") /= 0 or -- pattern > source - ASF.Index("xyz", - "abcde", - Ada.Strings.Backward) /= 0 or - ASF.Index("", "ab") /= 0 or -- null source string. - ASF.Index("abcde", " ") /= 0 -- blank pattern. - then - Report.Failed("Incorrect result from Index, no pattern match"); - end if; - - -- Check that Pattern_Error is raised when the pattern is the - -- null string. - begin - Location := ASF.Index(Source_String6, -- "abcdefabcdef" - "", -- null pattern string. - Ada.Strings.Forward); - Report.Failed("Pattern_Error not raised by Index"); - exception - when Ada.Strings.Pattern_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by Index, null pattern"); - end; - - -- Use the search direction "backward" to locate the particular - -- pattern within the source string. - - Location := ASF.Index(Source_String6, -- "abcdefabcdef" - "de", -- slice 4..5, 10..11 - Ada.Strings.Backward); -- search from right end. - - if Location /= 10 then - Report.Failed("Incorrect result from Index going Backward"); - end if; - - -- Using the version of Index testing character set membership, - -- check combinations of forward/backward, inside/outside parameter - -- configurations. - - if ASF.Index(Source => Source_String1, -- "abcde" - Set => CD_Set, - Test => Ada.Strings.Inside, - Going => Ada.Strings.Forward) /= 3 or -- 'c' at pos 3. - ASF.Index(Source_String6, -- "abcdefabcdef" - CD_Set, - Ada.Strings.Outside, - Ada.Strings.Backward) /= 12 or -- 'f' at position 12 - ASF.Index(Source_String6, -- "abcdefabcdef" - CD_Set, - Ada.Strings.Inside, - Ada.Strings.Backward) /= 10 or -- 'd' at position 10 - ASF.Index("cdcdcdcdacdcdcdcd", - CD_Set, - Ada.Strings.Outside, - Ada.Strings.Forward) /= 9 -- 'a' at position 9 - then - Report.Failed("Incorrect result from function Index for sets - 1"); - end if; - - -- Additional interesting uses/combinations using Index for sets. - - if ASF.Index("cd", -- same size, str-set - CD_Set, - Ada.Strings.Inside, - Ada.Strings.Forward) /= 1 or -- 'c' at position 1 - ASF.Index("abcd", -- same size, str-set, - Maps.To_Set("efgh"), -- different contents. - Ada.Strings.Outside, - Ada.Strings.Forward) /= 1 or - ASF.Index("abccd", -- set > string - Maps.To_Set("acegik"), - Ada.Strings.Inside, - Ada.Strings.Backward) /= 4 or -- 'c' at position 4 - ASF.Index("abcde", - Maps.Null_Set) /= 0 or - ASF.Index("", -- Null string. - CD_Set) /= 0 or - ASF.Index("abc ab", -- blank included - Maps.To_Set("e "), -- in string and set. - Ada.Strings.Inside, - Ada.Strings.Backward) /= 4 -- blank in string. - then - Report.Failed("Incorrect result from function Index for sets - 2"); - end if; - - - - -- Function Index_Non_Blank. - -- (Other usage examples of this function found in CXA4002-3.) - - - if ASF.Index_Non_Blank(Source => Source_String4, -- "abcdefghij " - Going => Ada.Strings.Backward) /= 10 or - ASF.Index_Non_Blank("abc def ghi jkl ", - Ada.Strings.Backward) /= 15 or - ASF.Index_Non_Blank(" abcdef") /= 3 or - ASF.Index_Non_Blank(" ") /= 0 - then - Report.Failed("Incorrect result from Index_Non_Blank"); - end if; - - - - -- Function Count - -- (Other usage examples of this function found in CXA4002-3.) - - if ASF.Count("abababa", "aba") /= 2 or - ASF.Count("abababa", "ab" ) /= 3 or - ASF.Count("babababa", "ab") /= 3 or - ASF.Count("abaabaaba", "aba") /= 3 or - ASF.Count("xxxxxxxxxxxxxxxxxxxy", "xy") /= 1 or - ASF.Count("xxxxxxxxxxxxxxxxxxxx", "x") /= 20 - then - Report.Failed("Incorrect result from Function Count"); - end if; - - -- Determine the number of slices of Source that when mapped to a - -- non-identity map, match the pattern string. - - Slice_Count := ASF.Count(Source_String6, -- "abcdefabcdef" - "xy", - CD_to_XY_Map); -- maps 'c' to 'x', 'd' to 'y' - - if Slice_Count /= 2 then -- two slices "xy" in "mapped" Source_String6 - Report.Failed("Incorrect result from Count with non-identity map"); - end if; - - -- If the pattern supplied to Function Count is the null string, then - -- Pattern_Error is propagated. - - declare - The_Null_String : constant String := ""; - begin - Slice_Count := ASF.Count(Source_String6, The_Null_String); - Report.Failed("Pattern_Error not raised by Function Count"); - exception - when Ada.Strings.Pattern_Error => null; -- OK - when others => - Report.Failed("Incorrect exception from Count with null pattern"); - end; - - - -- Function Count returning the number of characters in a particular - -- set that are found in source string. - - if ASF.Count(Source_String6, CD_Set) /= 4 then -- 2 'c' and 'd' chars. - Report.Failed("Incorrect result from Count with set"); - end if; - - - - -- Function Find_Token. - -- (Other usage examples of this function found in CXA4002-3.) - - ASF.Find_Token(Source => Source_String6, -- First slice with no - Set => ABCD_Set, -- 'a', 'b', 'c', or 'd' - Test => Ada.Strings.Outside, -- is "ef" at 5..6. - First => Slice_Start, - Last => Slice_End); - - if Slice_Start /= 5 or Slice_End /= 6 then - Report.Failed("Incorrect result from Find_Token - 1"); - end if; - - -- If no appropriate slice is contained by the source string, then the - -- value returned in Last is zero, and the value in First is - -- Source'First. - - ASF.Find_Token(Source_String6, -- "abcdefabcdef" - A_to_F_Set, -- Set of characters 'a' thru 'f'. - Ada.Strings.Outside, -- No characters outside this set. - Slice_Start, - Slice_End); - - if Slice_Start /= Source_String6'First or Slice_End /= 0 then - Report.Failed("Incorrect result from Find_Token - 2"); - end if; - - -- Additional testing of Find_Token. - - ASF.Find_Token("eabcdabcddcab", - ABCD_Set, - Ada.Strings.Inside, - Slice_Start, - Slice_End); - - if Slice_Start /= 2 or Slice_End /= 13 then - Report.Failed("Incorrect result from Find_Token - 3"); - end if; - - ASF.Find_Token("efghijklabcdabcd", - ABCD_Set, - Ada.Strings.Outside, - Slice_Start, - Slice_End); - - if Slice_Start /= 1 or Slice_End /= 8 then - Report.Failed("Incorrect result from Find_Token - 4"); - end if; - - ASF.Find_Token("abcdefgabcdabcd", - ABCD_Set, - Ada.Strings.Outside, - Slice_Start, - Slice_End); - - if Slice_Start /= 5 or Slice_End /= 7 then - Report.Failed("Incorrect result from Find_Token - 5"); - end if; - - ASF.Find_Token("abcdcbabcdcba", - ABCD_Set, - Ada.Strings.Inside, - Slice_Start, - Slice_End); - - if Slice_Start /= 1 or Slice_End /= 13 then - Report.Failed("Incorrect result from Find_Token - 6"); - end if; - - - exception - when others => Report.Failed("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA4004; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a deleted file mode 100644 index d61f853ca0e..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a +++ /dev/null @@ -1,683 +0,0 @@ --- CXA4005.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 subprograms defined in package Ada.Strings.Fixed are --- available, and that they produce correct results. Specifically, --- check the subprograms Delete, Head, Insert, Overwrite, Replace_Slice, --- Tail, Trim, and "*". --- --- TEST DESCRIPTION: --- This test, when combined with tests CXA4002-4 will provide coverage --- of the functionality found in Ada.Strings.Fixed. --- This test contains many small, specific test cases, situations that --- although common in user environments, are often difficult to generate --- in large numbers in a application-based test. They represent --- individual usage paradigms in-the-small. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 11 Apr 95 SAIC Corrected acceptance conditions of certain --- subtests. --- 06 Nov 95 SAIC Fixed bugs for ACVC 2.0.1. --- 22 Feb 01 PHL Check that the lower bound of the result is 1. --- 13 Mar 01 RLB Fixed a couple of ACATS style violations; --- removed pointless checks of procedures. --- Added checks of other functions. These changes --- were made to test Defect Report 8652/0049, as --- reflected in Technical Corrigendum 1. --- ---! - -with Report; -with Ada.Strings; -with Ada.Strings.Fixed; -with Ada.Strings.Maps; - -procedure CXA4005 is - - type TC_Name_Holder is access String; - Name : TC_Name_Holder; - - function TC_Check (S : String) return String is - begin - if S'First /= 1 then - Report.Failed ("Lower bound of result of function " & Name.all & - " is" & Integer'Image (S'First)); - end if; - return S; - end TC_Check; - - procedure TC_Set_Name (N : String) is - begin - Name := new String'(N); - end TC_Set_Name; - -begin - - Report.Test("CXA4005", "Check that the subprograms defined in " & - "package Ada.Strings.Fixed are available, " & - "and that they produce correct results"); - - Test_Block: - declare - - package ASF renames Ada.Strings.Fixed; - package Maps renames Ada.Strings.Maps; - - Result_String, - Delete_String, - Insert_String, - Trim_String, - Overwrite_String : String(1..10) := (others => Ada.Strings.Space); - - Source_String1 : String(1..5) := "abcde"; -- odd length string - Source_String2 : String(1..6) := "abcdef"; -- even length string - Source_String3 : String(1..12) := "abcdefghijkl"; - Source_String4 : String(1..12) := "abcdefghij "; -- last two ch pad - Source_String5 : String(1..12) := " cdefghijkl"; -- first two ch pad - Source_String6 : String(1..12) := "abcdefabcdef"; - - Location : Natural := 0; - Slice_Start : Positive; - Slice_End, - Slice_Count : Natural := 0; - - CD_Set : Maps.Character_Set := Maps.To_Set("cd"); - X_Set : Maps.Character_Set := Maps.To_Set('x'); - ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd"); - A_to_F_Set : Maps.Character_Set := Maps.To_Set("abcdef"); - - CD_to_XY_Map : Maps.Character_Mapping := - Maps.To_Mapping(From => "cd", To => "xy"); - - begin - - -- Procedure Replace_Slice - -- The functionality of this procedure - -- is similar to procedure Move, and - -- is tested here in the same manner, evaluated - -- with various combinations of parameters. - - -- Index_Error propagation when Low > Source'Last + 1 - - begin - ASF.Replace_Slice(Result_String, - Result_String'Last + 2, -- should raise exception - Result_String'Last, - "xxxxxxx"); - Report.Failed("Index_Error not raised by Replace_Slice - 1"); - exception - when Ada.Strings.Index_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception from Replace_Slice - 1"); - end; - - -- Index_Error propagation when High < Source'First - 1 - - begin - ASF.Replace_Slice(Result_String(5..10), - 5, - 3, -- should raise exception since < 'First - 1. - "xxxxxxx"); - Report.Failed("Index_Error not raised by Replace_Slice - 2"); - exception - when Ada.Strings.Index_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception from Replace_Slice - 2"); - end; - - -- Justify = Left (default case) - - Result_String := "XXXXXXXXXX"; - - ASF.Replace_Slice(Source => Result_String, - Low => 1, - High => 10, - By => Source_String1); -- "abcde" - - if Result_String /= "abcde " then - Report.Failed("Incorrect result from Replace_Slice - Justify = Left"); - end if; - - -- Justify = Right - - ASF.Replace_Slice(Source => Result_String, - Low => 1, - High => Result_String'Last, - By => Source_String2, -- "abcdef" - Drop => Ada.Strings.Error, - Justify => Ada.Strings.Right); - - if Result_String /= " abcdef" then - Report.Failed("Incorrect result from Replace_Slice - Justify=Right"); - end if; - - -- Justify = Center (two cases, odd and even pad lengths) - - ASF.Replace_Slice(Result_String, - 1, - Result_String'Last, - Source_String1, -- "abcde" - Ada.Strings.Error, - Ada.Strings.Center, - 'x'); -- non-default padding. - - if Result_String /= "xxabcdexxx" then -- Unequal padding added right - Report.Failed("Incorrect result, Replace_Slice - Justify=Center - 1"); - end if; - - ASF.Replace_Slice(Result_String, - 1, - Result_String'Last, - Source_String2, -- "abcdef" - Ada.Strings.Error, - Ada.Strings.Center); - - if Result_String /= " abcdef " then -- Equal padding added on L/R. - Report.Failed("Incorrect result from Replace_Slice with " & - "Justify = Center - 2"); - end if; - - -- When the source string is longer than the target string, several - -- cases can be examined, with the results depending on the value of - -- the Drop parameter. - - -- Drop = Left - - ASF.Replace_Slice(Result_String, - 1, - Result_String'Last, - Source_String3, -- "abcdefghijkl" - Drop => Ada.Strings.Left); - - if Result_String /= "cdefghijkl" then - Report.Failed("Incorrect result from Replace_Slice - Drop=Left"); - end if; - - -- Drop = Right - - ASF.Replace_Slice(Result_String, - 1, - Result_String'Last, - Source_String3, -- "abcdefghijkl" - Ada.Strings.Right); - - if Result_String /= "abcdefghij" then - Report.Failed("Incorrect result, Replace_Slice with Drop=Right"); - end if; - - -- Drop = Error - - -- The effect in this case depends on the value of the justify - -- parameter, and on whether any characters in Source other than - -- Pad would fail to be copied. - - -- Drop = Error, Justify = Left, right overflow characters are pad. - - ASF.Replace_Slice(Result_String, - 1, - Result_String'Last, - Source_String4, -- "abcdefghij " - Drop => Ada.Strings.Error, - Justify => Ada.Strings.Left); - - if not(Result_String = "abcdefghij") then -- leftmost 10 characters - Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 1"); - end if; - - -- Drop = Error, Justify = Right, left overflow characters are pad. - - ASF.Replace_Slice(Source => Result_String, - Low => 1, - High => Result_String'Last, - By => Source_String5, -- " cdefghijkl" - Drop => Ada.Strings.Error, - Justify => Ada.Strings.Right); - - if Result_String /= "cdefghijkl" then -- rightmost 10 characters - Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 2"); - end if; - - -- In other cases of Drop=Error, Length_Error is propagated, such as: - - begin - - ASF.Replace_Slice(Source => Result_String, - Low => 1, - High => Result_String'Last, - By => Source_String3, -- "abcdefghijkl" - Drop => Ada.Strings.Error); - - Report.Failed("Length_Error not raised by Replace_Slice - 1"); - - exception - when Ada.Strings.Length_Error => null; -- OK - when others => - Report.Failed("Incorrect exception from Replace_Slice - 3"); - end; - - - -- Function Replace_Slice - - TC_Set_Name ("Replace_Slice"); - - if TC_Check (ASF.Replace_Slice("abcde", 3, 3, "x")) - /= "abxde" or -- High = Low - TC_Check (ASF.Replace_Slice("abc", 2, 3, "xyz")) /= "axyz" or - TC_Check (ASF.Replace_Slice("abcd", 4, 1, "xy")) - /= "abcxyd" or -- High < Low - TC_Check (ASF.Replace_Slice("abc", 2, 3, "x")) /= "ax" or - TC_Check (ASF.Replace_Slice("a", 1, 1, "z")) /= "z" - then - Report.Failed("Incorrect result from Function Replace_Slice - 1"); - end if; - - if TC_Check (ASF.Replace_Slice("abcde", 5, 5, "z")) - /= "abcdz" or -- By length 1 - TC_Check (ASF.Replace_Slice("abc", 1, 3, "xyz")) - /= "xyz" or -- High > Low - TC_Check (ASF.Replace_Slice("abc", 3, 2, "xy")) - /= "abxyc" or -- insert - TC_Check (ASF.Replace_Slice("a", 1, 1, "xyz")) /= "xyz" - then - Report.Failed("Incorrect result from Function Replace_Slice - 2"); - end if; - - - - -- Function Insert. - - TC_Set_Name ("Insert"); - - declare - New_String : constant String := - TC_Check ( - ASF.Insert(Source => Source_String1(2..5), -- "bcde" - Before => 3, - New_Item => Source_String2)); -- "abcdef" - begin - if New_String /= "babcdefcde" then - Report.Failed("Incorrect result from Function Insert - 1"); - end if; - end; - - if TC_Check (ASF.Insert("a", 1, "z")) /= "za" or - TC_Check (ASF.Insert("abc", 3, "")) /= "abc" or - TC_Check (ASF.Insert("abc", 1, "z")) /= "zabc" - then - Report.Failed("Incorrect result from Function Insert - 2"); - end if; - - begin - if TC_Check (ASF.Insert(Source => Source_String1(2..5), -- "bcde" - Before => Report.Ident_Int(7), - New_Item => Source_String2)) -- "abcdef" - /= "babcdefcde" then - Report.Failed("Index_Error not raised by Insert - 3A"); - else - Report.Failed("Index_Error not raised by Insert - 3B"); - end if; - exception - when Ada.Strings.Index_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception from Insert - 3"); - end; - - - -- Procedure Insert - - -- Drop = Right - - ASF.Insert(Source => Insert_String, - Before => 6, - New_Item => Source_String2, -- "abcdef" - Drop => Ada.Strings.Right); - - if Insert_String /= " abcde" then -- last char of New_Item dropped. - Report.Failed("Incorrect result from Insert with Drop = Right"); - end if; - - -- Drop = Left - - ASF.Insert(Source => Insert_String, -- 10 char string - Before => 2, -- 9 chars, 2..10 available - New_Item => Source_String3, -- 12 characters long. - Drop => Ada.Strings.Left); -- truncate from Left. - - if Insert_String /= "l abcde" then -- 10 chars, leading blank. - Report.Failed("Incorrect result from Insert with Drop=Left"); - end if; - - -- Drop = Error - - begin - ASF.Insert(Source => Result_String, -- 10 chars - Before => Result_String'Last, - New_Item => "abcdefghijk", - Drop => Ada.Strings.Error); - Report.Failed("Exception not raised by Procedure Insert"); - exception - when Ada.Strings.Length_Error => null; -- OK, expected exception - when others => - Report.Failed("Incorrect exception raised by Procedure Insert"); - end; - - - - -- Function Overwrite - - TC_Set_Name ("Overwrite"); - - Overwrite_String := TC_Check ( - ASF.Overwrite(Result_String, -- 10 chars - 1, -- starting at pos=1 - Source_String3(1..10))); - - if Overwrite_String /= Source_String3(1..10) then - Report.Failed("Incorrect result from Function Overwrite - 1"); - end if; - - - if TC_Check (ASF.Overwrite("abcdef", 4, "xyz")) /= "abcxyz" or - TC_Check (ASF.Overwrite("a", 1, "xyz")) - /= "xyz" or -- chars appended - TC_Check (ASF.Overwrite("abc", 3, " ")) - /= "ab " or -- blanks appended - TC_Check (ASF.Overwrite("abcde", 1, "z" )) /= "zbcde" - then - Report.Failed("Incorrect result from Function Overwrite - 2"); - end if; - - - - -- Procedure Overwrite, with truncation. - - ASF.Overwrite(Source => Overwrite_String, -- 10 characters. - Position => 1, - New_Item => Source_String3, -- 12 characters. - Drop => Ada.Strings.Left); - - if Overwrite_String /= "cdefghijkl" then - Report.Failed("Incorrect result from Overwrite with Drop=Left"); - end if; - - -- The default drop value is Right, used here. - - ASF.Overwrite(Source => Overwrite_String, -- 10 characters. - Position => 1, - New_Item => Source_String3); -- 12 characters. - - if Overwrite_String /= "abcdefghij" then - Report.Failed("Incorrect result from Overwrite with Drop=Right"); - end if; - - -- Drop = Error - - begin - ASF.Overwrite(Source => Overwrite_String, -- 10 characters. - Position => 1, - New_Item => Source_String3, -- 12 characters. - Drop => Ada.Strings.Error); - Report.Failed("Exception not raised by Procedure Overwrite"); - exception - when Ada.Strings.Length_Error => null; -- OK, expected exception. - when others => - Report.Failed - ("Incorrect exception raised by Procedure Overwrite"); - end; - - Overwrite_String := "ababababab"; - ASF.Overwrite(Overwrite_String, Overwrite_String'Last, "z"); - ASF.Overwrite(Overwrite_String, Overwrite_String'First,"z"); - ASF.Overwrite(Overwrite_String, 5, "zz"); - - if Overwrite_String /= "zbabzzabaz" then - Report.Failed("Incorrect result from Procedure Overwrite"); - end if; - - - - -- Function Delete - - TC_Set_Name ("Delete"); - - declare - New_String1 : constant String := -- This returns a 4 char string. - TC_Check (ASF.Delete(Source => Source_String3, - From => 3, - Through => 10)); - New_String2 : constant String := -- This returns Source. - TC_Check (ASF.Delete(Source_String3, 10, 3)); - begin - if New_String1 /= "abkl" or - New_String2 /= Source_String3 - then - Report.Failed("Incorrect result from Function Delete - 1"); - end if; - end; - - if TC_Check (ASF.Delete("a", 1, 1)) - /= "" or -- Source length = 1 - TC_Check (ASF.Delete("abc", 1, 2)) - /= "c" or -- From = Source'First - TC_Check (ASF.Delete("abc", 3, 3)) - /= "ab" or -- From = Source'Last - TC_Check (ASF.Delete("abc", 3, 1)) - /= "abc" -- From > Through - then - Report.Failed("Incorrect result from Function Delete - 2"); - end if; - - - - -- Procedure Delete - - -- Justify = Left - - Delete_String := Source_String3(1..10); -- Initialize to "abcdefghij" - - ASF.Delete(Source => Delete_String, - From => 6, - Through => Delete_String'Last, - Justify => Ada.Strings.Left, - Pad => 'x'); -- pad with char 'x' - - if Delete_String /= "abcdexxxxx" then - Report.Failed("Incorrect result from Delete - Justify = Left"); - end if; - - -- Justify = Right - - ASF.Delete(Source => Delete_String, -- Remove x"s from end and - From => 6, -- shift right. - Through => Delete_String'Last, - Justify => Ada.Strings.Right, - Pad => 'x'); -- pad with char 'x' on left. - - if Delete_String /= "xxxxxabcde" then - Report.Failed("Incorrect result from Delete - Justify = Right"); - end if; - - -- Justify = Center - - ASF.Delete(Source => Delete_String, - From => 1, - Through => 5, - Justify => Ada.Strings.Center, - Pad => 'z'); - - if Delete_String /= "zzabcdezzz" then -- extra pad char on right side. - Report.Failed("Incorrect result from Delete - Justify = Center"); - end if; - - - - -- Function Trim - -- Use non-identity character sets to perform the trim operation. - - TC_Set_Name ("Trim"); - - Trim_String := "cdabcdefcd"; - - -- Remove the "cd" from each end of the string. This will not effect - -- the "cd" slice at 5..6. - - declare - New_String : constant String := - TC_Check (ASF.Trim(Source => Trim_String, - Left => CD_Set, Right => CD_Set)); - begin - if New_String /= Source_String2 then -- string "abcdef" - Report.Failed("Incorrect result from Trim with character sets"); - end if; - end; - - if TC_Check (ASF.Trim("abcdef", Maps.Null_Set, Maps.Null_Set)) - /= "abcdef" then - Report.Failed("Incorrect result from Trim with Null sets"); - end if; - - if TC_Check (ASF.Trim("cdxx", CD_Set, X_Set)) /= "" then - Report.Failed("Incorrect result from Trim, string removal"); - end if; - - - -- Procedure Trim - - -- Justify = Right - - ASF.Trim(Source => Trim_String, - Left => CD_Set, - Right => CD_Set, - Justify => Ada.Strings.Right, - Pad => 'x'); - - if Trim_String /= "xxxxabcdef" then - Report.Failed("Incorrect result from Trim with Justify = Right"); - end if; - - -- Justify = Left - - ASF.Trim(Source => Trim_String, - Left => X_Set, - Right => Maps.Null_Set, - Justify => Ada.Strings.Left, - Pad => Ada.Strings.Space); - - if Trim_String /= "abcdef " then -- Padded with 4 blanks on right. - Report.Failed("Incorrect result from Trim with Justify = Left"); - end if; - - -- Justify = Center - - ASF.Trim(Source => Trim_String, - Left => ABCD_Set, - Right => CD_Set, - Justify => Ada.Strings.Center, - Pad => 'x'); - - if Trim_String /= "xxef xx" then -- Padded with 2 pad chars on L/R - Report.Failed("Incorrect result from Trim with Justify = Center"); - end if; - - - - -- Function Head, demonstrating use of padding. - - TC_Set_Name ("Head"); - - -- Use the characters of Source_String1 ("abcde") and pad the - -- last five characters of Result_String with 'x' characters. - - - Result_String := TC_CHeck (ASF.Head(Source_String1, 10, 'x')); - - if Result_String /= "abcdexxxxx" then - Report.Failed("Incorrect result from Function Head with padding"); - end if; - - if TC_Check (ASF.Head(" ab ", 2)) /= " " or - TC_Check (ASF.Head("a", 6, 'A')) /= "aAAAAA" or - TC_Check (ASF.Head("abcdefgh", 3, 'x')) /= "abc" or - TC_Check (ASF.Head(ASF.Head("abc ", 7, 'x'), 10, 'X')) - /= "abc xxXXX" - then - Report.Failed("Incorrect result from Function Head"); - end if; - - - - -- Function Tail, demonstrating use of padding. - - TC_Set_Name ("Tail"); - - -- Use the characters of Source_String1 ("abcde") and pad the - -- first five characters of Result_String with 'x' characters. - - Result_String := TC_Check (ASF.Tail(Source_String1, 10, 'x')); - - if Result_String /= "xxxxxabcde" then - Report.Failed("Incorrect result from Function Tail with padding"); - end if; - - if TC_Check (ASF.Tail("abcde ", 5)) - /= "cde " or -- blanks, back - TC_Check (ASF.Tail(" abc ", 8, ' ')) - /= " abc " or -- blanks, front/back - TC_Check (ASF.Tail("", 5, 'Z')) - /= "ZZZZZ" or -- pad characters only - TC_Check (ASF.Tail("abc", 0)) - /= "" or -- null result - TC_Check (ASF.Tail("abcdefgh", 3)) - /= "fgh" or - TC_Check (ASF.Tail(ASF.Tail(" abc ", 6, 'x'), - 10, - 'X')) /= "XXXXx abc " - then - Report.Failed("Incorrect result from Function Tail"); - end if; - - - -- Function "*" - with (Natural, String) parameters - - TC_Set_Name ("""*"""); - - if TC_Check (ASF."*"(3, Source_String1)) /= "abcdeabcdeabcde" or - TC_Check (ASF."*"(2, Source_String2)) /= Source_String6 or - TC_Check (ASF."*"(4, Source_String1(1..2))) /= "abababab" or - TC_Check (ASF."*"(0, Source_String1)) /= "" - then - Report.Failed("Incorrect result from Function ""*"" with strings"); - end if; - - exception - when others => Report.Failed("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA4005; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a deleted file mode 100644 index e1d7f46f5ae..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a +++ /dev/null @@ -1,319 +0,0 @@ --- CXA4006.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 subprograms defined in package Ada.Strings.Bounded are --- available, and that they produce correct results. Specifically, check --- the subprograms Length, Slice, "&", To_Bounded_String, Append, Index, --- To_String, Replace_Slice, Trim, Overwrite, Delete, Insert, and --- Translate. --- --- TEST DESCRIPTION: --- This test demonstrates the uses of a variety of the string functions --- found in the package Ada.Strings.Bounded, simulating the operations --- found in a text processing package. --- With bounded strings, the length of each "line" of text can vary up --- to the instantiated maximum, allowing one to view a page of text as --- a series of expandable lines. This provides flexibility in text --- formatting of individual lines (strings). --- Several subprograms are defined, all of which attempt to take advantage --- of as many different bounded string utilities as possible. Often, --- an operation that is being performed in a subprogram using a certain --- bounded string utility could more efficiently be performed using a --- a different utility. However, in the interest of including as broad --- coverage as possible, a mixture of utilities is invoked in this test. --- A simulated page of text is provided as a parameter to the test --- defined subprograms, and the appropriate processing performed. The --- processed page of text is then compared to a predefined "finished" --- page, and test passage/failure is based on the results of this --- comparison. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with Ada.Strings; -with Ada.Strings.Bounded; -with Ada.Strings.Maps; -with Report; - -procedure CXA4006 is - -begin - - Report.Test ("CXA4006", "Check that the subprograms defined in package " & - "Ada.Strings.Bounded are available, and that " & - "they produce correct results"); - - Test_Block: - declare - - Characters_Per_Line : constant Positive := 40; - Lines_Per_Page : constant Natural := 4; - - package BS_40 is new - Ada.Strings.Bounded.Generic_Bounded_Length(Characters_Per_Line); - use type BS_40.Bounded_String; - - type Page_Type is array (1..Lines_Per_Page) of BS_40.Bounded_String; - - -- Note: Misspellings below are intentional. - - Line1 : BS_40.Bounded_String := - BS_40.To_Bounded_String("ada is a progrraming language designed"); - Line2 : BS_40.Bounded_String := - BS_40.To_Bounded_String("to support the construction of long-"); - Line3 : BS_40.Bounded_String := - BS_40.To_Bounded_String("lived, highly reliabel software "); - Line4 : BS_40.Bounded_String := - BS_40.To_Bounded_String("systems"); - - Page : Page_Type := (1 => Line1, 2 => Line2, 3 => Line3, 4 => Line4); - - Finished_Page : Page_Type := - (BS_40.To_Bounded_String("Ada is a programming language designed"), - BS_40.To_Bounded_String("to support the construction of long-"), - BS_40.To_Bounded_String("lived, HIGHLY RELIABLE software systems."), - BS_40.To_Bounded_String("")); - - --- - - procedure Compress (Page : in out Page_Type) is - Clear_Line : Natural := Lines_Per_Page; - begin - -- If two consecutive lines on the page are together less than the - -- maximum line length, then append those two lines, move up all - -- lower lines on the page, and blank out the last line. - for i in 1..Lines_Per_Page - 1 loop - if BS_40.Length(Page(i)) + BS_40.Length(Page(i+1)) <= - BS_40.Max_Length - then - Page(i) := BS_40."&"(Page(i), - Page(i+1)); -- "&" (bounded, bounded) - - for j in i+1..Lines_Per_Page - 1 loop - Page(j) := - BS_40.To_Bounded_String - (BS_40.Slice(Page(j+1), - 1, - BS_40.Length(Page(j+1)))); - Clear_Line := j + 1; - end loop; - Page(Clear_Line) := BS_40.Null_Bounded_String; - end if; - end loop; - end Compress; - - --- - - procedure Format (Page : in out Page_Type) is - Sm_Ada : BS_40.Bounded_String := BS_40.To_Bounded_String("ada"); - Cap_Ada : constant String := "Ada"; - Char_Pos : Natural := 0; - Finished : Boolean := False; - Line : Natural := Page_Type'Last; - begin - - -- Add a period to the end of the last line. - while Line >= Page_Type'First and not Finished loop - if Page(Line) /= BS_40.Null_Bounded_String and - BS_40.Length(Page(Line)) <= BS_40.Max_Length - then - Page(Line) := BS_40.Append(Page(Line), '.'); - Finished := True; - end if; - Line := Line - 1; - end loop; - - -- Replace all occurrences of "ada" with "Ada". - for Line in Page_Type'First .. Page_Type'Last loop - Finished := False; - while not Finished loop - Char_Pos := BS_40.Index(Source => Page(Line), - Pattern => BS_40.To_String(Sm_Ada), - Going => Ada.Strings.Backward); - -- A zero is returned by function Index if no occurrences of - -- the pattern string are found. - Finished := (Char_Pos = 0); - if not Finished then - BS_40.Replace_Slice - (Source => Page(Line), - Low => Char_Pos, - High => Char_Pos + BS_40.Length(Sm_Ada) - 1, - By => Cap_Ada); - end if; - end loop; -- while loop - end loop; -- for loop - - end Format; - - --- - - procedure Spell_Check (Page : in out Page_Type) is - type Spelling_Type is (Incorrect, Correct); - type Word_Array_Type is array (Spelling_Type) - of BS_40.Bounded_String; - type Dictionary_Type is array (1..2) of Word_Array_Type; - - -- Note that the "words" in the dictionary will require various - -- amounts of Trimming prior to their use in the string functions. - Dictionary : Dictionary_Type := - (1 => (BS_40.To_Bounded_String(" reliabel "), - BS_40.To_Bounded_String(" reliable ")), - 2 => (BS_40.To_Bounded_String(" progrraming "), - BS_40.To_Bounded_String(" programming "))); - - Pos : Natural := Natural'First; - Finished : Boolean := False; - - begin - - for Line in Page_Type'Range loop - - -- Search for the first incorrectly spelled word in the Dictionary, - -- if it is found, replace it with the correctly spelled word, - -- using the Overwrite function. - - while not Finished loop - Pos := - BS_40.Index(Page(Line), - BS_40.To_String( - BS_40.Trim(Dictionary(1)(Incorrect), - Ada.Strings.Both)), - Ada.Strings.Forward); - Finished := (Pos = 0); - if not Finished then - Page(Line) := - BS_40.Overwrite(Page(Line), - Pos, - BS_40.To_String - (BS_40.Trim(Dictionary(1)(Correct), - Ada.Strings.Both))); - end if; - end loop; - - Finished := False; - - -- Search for the second incorrectly spelled word in the - -- Dictionary, if it is found, replace it with the correctly - -- spelled word, using the Delete procedure and Insert function. - - while not Finished loop - Pos := - BS_40.Index(Page(Line), - BS_40.To_String( - BS_40.Trim(Dictionary(2)(Incorrect), - Ada.Strings.Both)), - Ada.Strings.Forward); - - Finished := (Pos = 0); - - if not Finished then - BS_40.Delete - (Page(Line), - Pos, - Pos + BS_40.To_String - (BS_40.Trim(Dictionary(2)(Incorrect), - Ada.Strings.Both))'Length-1); - Page(Line) := - BS_40.Insert(Page(Line), - Pos, - BS_40.To_String - (BS_40.Trim(Dictionary(2)(Correct), - Ada.Strings.Both))); - end if; - end loop; - - Finished := False; - - end loop; - end Spell_Check; - - --- - - procedure Bold (Page : in out Page_Type) is - Key_Word : constant String := "highly reliable"; - Bold_Mapping : constant Ada.Strings.Maps.Character_Mapping := - Ada.Strings.Maps.To_Mapping(From => " abcdefghijklmnopqrstuvwxyz", - To => " ABCDEFGHIJKLMNOPQRSTUVWXYZ"); - Pos : Natural := Natural'First; - Finished : Boolean := False; - begin - -- This procedure is designed to change the case of the phrase - -- "highly reliable" into upper case (a type of "Bolding"). - -- All instances of the phrase on all lines of the page will be - -- modified. - - for Line in Page_Type'First .. Page_Type'Last loop - while not Finished loop - Pos := BS_40.Index(Page(Line), Key_Word); - Finished := (Pos = 0); - if not Finished then - - BS_40.Overwrite - (Page(Line), - Pos, - BS_40.To_String - (BS_40.Translate - (BS_40.To_Bounded_String - (BS_40.Slice(Page(Line), - Pos, - Pos + Key_Word'Length - 1)), - Bold_Mapping))); - - end if; - end loop; - Finished := False; - end loop; - end Bold; - - - begin - - Compress(Page); - Format(Page); - Spell_Check(Page); - Bold(Page); - - for i in 1..Lines_Per_Page loop - if BS_40.To_String(Page(i)) /= BS_40.To_String(Finished_Page(i)) or - BS_40.Length(Page(i)) /= BS_40.Length(Finished_Page(i)) - then - Report.Failed("Incorrect modification of Page, Line " & - Integer'Image(i)); - end if; - end loop; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4006; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a deleted file mode 100644 index fca15d367b5..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a +++ /dev/null @@ -1,334 +0,0 @@ --- CXA4007.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 subprograms defined in package Ada.Strings.Bounded are --- available, and that they produce correct results. Specifically, check --- the subprograms Append, Count, Element, Find_Token, Head, --- Index_Non_Blank, Replace_Element, Replicate, Tail, To_Bounded_String, --- "&", ">", "<", ">=", "<=", and "*". --- --- TEST DESCRIPTION: --- This test, when taken in conjunction with tests CXA400[6,8,9], will --- constitute a test of all the functionality contained in package --- Ada.Strings.Bounded. This test uses a variety of the --- subprograms defined in the bounded string package in ways typical --- of common usage. Different combinations of available subprograms --- are used to accomplish similar bounded string processing goals. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 22 Dec 94 SAIC Changed obsolete constant to Ada.Strings.Space. --- ---! - -with Ada.Strings; -with Ada.Strings.Bounded; -with Ada.Strings.Maps; -with Report; - -procedure CXA4007 is - -begin - - Report.Test ("CXA4007", "Check that the subprograms defined in package " & - "Ada.Strings.Bounded are available, and that " & - "they produce correct results"); - - Test_Block: - declare - - package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80); - use type BS80.Bounded_String; - - Part1 : constant String := "Rum"; - Part2 : Character := 'p'; - Part3 : BS80.Bounded_String := BS80.To_Bounded_String("el"); - Part4 : Character := 's'; - Part5 : BS80.Bounded_String := BS80.To_Bounded_String("tilt"); - Part6 : String(1..3) := "ski"; - - Full_Catenate_String, - Full_Append_String, - Constructed_String, - Drop_String, - Replicated_String, - Token_String : BS80.Bounded_String; - - CharA : Character := 'A'; - CharB : Character := 'B'; - CharC : Character := 'C'; - CharD : Character := 'D'; - CharE : Character := 'E'; - CharF : Character := 'F'; - - ABStr : String(1..15) := "AAAAABBBBBBBBBB"; - StrB : String(1..2) := "BB"; - StrE : String(1..2) := "EE"; - - - begin - - -- Evaluation of the overloaded forms of the "&" operator defined - -- for instantiations of Bounded Strings. - - Full_Catenate_String := - BS80."&"(Part2, -- Char & Bnd Str - BS80."&"(Part3, -- Bnd Str & Bnd Str - BS80."&"(Part4, -- Char & Bnd Str - BS80."&"(Part5, -- Bnd Str & Bnd Str - BS80.To_Bounded_String(Part6))))); - - Full_Catenate_String := - Part1 & Full_Catenate_String; -- Str & Bnd Str - Full_Catenate_String := - Full_Catenate_String & 'n'; -- Bnd Str & Char - - - -- Evaluation of the overloaded forms of function Append. - - Full_Append_String := - BS80.Append(Part2, -- Char,Bnd - BS80.Append(Part3, -- Bnd, Bnd - BS80.Append(Part4, -- Char,Bnd - BS80.Append(BS80.To_String(Part5), -- Str,Bnd - BS80.To_Bounded_String(Part6))))); - - Full_Append_String := - BS80.Append(BS80.To_Bounded_String(Part1), -- Bnd , Str - BS80.To_String(Full_Append_String)); - - Full_Append_String := - BS80.Append(Left => Full_Append_String, - Right => 'n'); -- Bnd, Char - - - -- Validate the resulting bounded strings. - - if Full_Catenate_String < Full_Append_String or - Full_Catenate_String > Full_Append_String or - not (Full_Catenate_String = Full_Append_String and - Full_Catenate_String <= Full_Append_String and - Full_Catenate_String >= Full_Append_String) - then - Report.Failed("Incorrect results from bounded string catenation" & - " and comparison"); - end if; - - - -- Evaluate the overloaded forms of the Constructor function "*" and - -- the Replicate function. - - Constructed_String := - (2 * CharA) & -- "AA" - (2 * StrB) & -- "AABBBB" - (3 * BS80."*"(2, CharC)) & -- "AABBBBCCCCCC" - BS80.Replicate(3, - BS80.Replicate(2, CharD)) & -- "AABBBBCCCCCCDDDDDD" - BS80.Replicate(2, StrE) & -- "AABBBBCCCCCCDDDDDDEEEE" - BS80.Replicate(2, CharF); -- "AABBBBCCCCCCDDDDDDEEEEFF" - - - -- Use of Function Replicate that involves dropping characters. The - -- attempt to replicate the 15 character string six times will exceed - -- the 80 character bound of the string. Therefore, the result should - -- be the catenation of 5 copies of the 15 character string, followed - -- by 5 'A' characters (the first five characters of the 6th - -- replication) with the remaining characters of the 6th replication - -- dropped. - - Drop_String := - BS80.Replicate(Count => 6, - Item => ABStr, -- "AAAAABBBBBBBBBB" - Drop => Ada.Strings.Right); - - if BS80.Element(Drop_String, 1) /= 'A' or - BS80.Element(Drop_String, 6) /= 'B' or - BS80.Element(Drop_String, 76) /= 'A' or - BS80.Element(Drop_String, 80) /= 'A' - then - Report.Failed("Incorrect result from Replicate with Drop"); - end if; - - - -- Use function Index_Non_Blank in the evaluation of the - -- Constructed_String. - - if BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Forward) /= - BS80.To_String(Constructed_String)'First or - BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Backward) /= - BS80.Length(Constructed_String) - then - Report.Failed("Incorrect results from constructor functions"); - end if; - - - - declare - - -- Define character set objects for use with the Count function. - -- Constructed_String = "AABBBBCCCCCCDDDDDDEEEEFF" from above. - - A_Set : Ada.Strings.Maps.Character_Set := - Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,1)); - B_Set : Ada.Strings.Maps.Character_Set := - Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,3)); - C_Set : Ada.Strings.Maps.Character_Set := - Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,7)); - D_Set : Ada.Strings.Maps.Character_Set := - Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,13)); - E_Set : Ada.Strings.Maps.Character_Set := - Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,19)); - F_Set : Ada.Strings.Maps.Character_Set := - Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,23)); - - - Start : Positive; - Stop : Natural := 0; - - begin - - -- Evaluate the results from function Count by comparing the number - -- of A's to the number of F's, B's to E's, and C's to D's in the - -- Constructed_String. - -- There should be an equal number of each of the characters that - -- are being compared (i.e., 2 A's and F's, 4 B's and E's, etc) - - if BS80.Count(Constructed_String, A_Set) /= - BS80.Count(Constructed_String, F_Set) or - BS80.Count(Constructed_String, B_Set) /= - BS80.Count(Constructed_String, E_Set) or - not (BS80.Count(Constructed_String, C_Set) = - BS80.Count(Constructed_String, D_Set)) - then - Report.Failed("Incorrect result from function Count"); - end if; - - - -- Evaluate the functions Head, Tail, and Find_Token. - -- Create the Token_String from the Constructed_String above. - - Token_String := - BS80.Tail(BS80.Head(Constructed_String, 3), 2) & -- "AB" & - BS80.Head(BS80.Tail(Constructed_String, 13), 2) & -- "CD" & - BS80.Head(BS80.Tail(Constructed_String, 3), 2); -- "EF" - - if Token_String /= BS80.To_Bounded_String("ABCDEF") then - Report.Failed("Incorrect result from Catenation of Token_String"); - end if; - - - -- Find the starting/ending position of the first A in the - -- Token_String (both should be 1, only one A appears in string). - -- The Function Head uses the default pad character to return a - -- bounded string longer than its input parameter bounded string. - - BS80.Find_Token(BS80.Head(Token_String, 10), -- Default pad. - A_Set, - Ada.Strings.Inside, - Start, - Stop); - - if Start /= 1 and Stop /= 1 then - Report.Failed("Incorrect result from Find_Token - 1"); - end if; - - - -- Find the starting/ending position of the first non-AB slice in - -- the "head" five characters of Token_String (slice CDE at - -- positions 3-5) - - BS80.Find_Token(BS80.Head(Token_String, 5), -- "ABCDE" - Ada.Strings.Maps."OR"(A_Set, B_Set), -- Set (AB) - Ada.Strings.Outside, - Start, - Stop); - - if Start /= 3 and Stop /= 5 then - Report.Failed("Incorrect result from Find_Token - 2"); - end if; - - - -- Find the starting/ending position of the first CD slice in - -- the "tail" eight characters (including two pad characters) - -- of Token_String (slice CD at positions 5-6 of the tail - -- portion specified) - - BS80.Find_Token(BS80.Tail(Token_String, 8, - Ada.Strings.Space), -- " ABCDEF" - Ada.Strings.Maps."OR"(C_Set, D_Set), -- Set (CD) - Ada.Strings.Inside, - Start, - Stop); - - if Start /= 5 and Stop /= 6 then - Report.Failed("Incorrect result from Find_Token - 3"); - end if; - - - -- Evaluate the Replace_Element procedure. - - -- Token_String = "ABCDEF" - - BS80.Replace_Element(Token_String, 3, BS80.Element(Token_String,4)); - - -- Token_String = "ABDDEF" - - BS80.Replace_Element(Source => Token_String, - Index => 2, - By => BS80.Element(Token_String, 5)); - - -- Token_String = "AEDDEF" - - BS80.Replace_Element(Token_String, - 1, - BS80.Element(BS80.Tail(Token_String, 2), 2)); - - -- Token_String = "FEDDEF" - -- Evaluate this result. - - if BS80.Element(Token_String, BS80.To_String(Token_String)'First) /= - BS80.Element(Token_String, BS80.To_String(Token_String)'Last) or - BS80.Count(Token_String, D_Set) /= - BS80.Count(Token_String, E_Set) or - BS80.Index_Non_Blank(BS80.Head(Token_String,6)) /= - BS80.Index_Non_Blank(BS80.Tail(Token_String,6)) or - BS80.Head(Token_String, 1) /= - BS80.Tail(Token_String, 1) - then - Report.Failed("Incorrect result from operations in combination"); - end if; - - end; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4007; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a deleted file mode 100644 index 629305f767a..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a +++ /dev/null @@ -1,662 +0,0 @@ --- CXA4008.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 subprograms defined in package Ada.Strings.Bounded are --- available, and that they produce correct results, especially under --- conditions where truncation of the result is required. Specifically, --- check the subprograms Append, Count with non-Identity maps, Index with --- non-Identity maps, Index with Set parameters, Insert (function and --- procedure), Replace_Slice (function and procedure), To_Bounded_String, --- and Translate. --- --- TEST DESCRIPTION: --- This test, in conjunction with tests CXA4006, CXA4007, and CXA4009, --- will provide coverage of the most common usages of the functionality --- found in the Ada.Strings.Bounded package. It deals in large part --- with truncation effects and options. This test contains many small, --- specific test cases, situations that are often difficult to generate --- in large numbers in an application-based test. These cases represent --- specific usage paradigms in-the-small. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 10 Apr 95 SAIC Corrected acceptance condition of subtest for --- Function Append with Truncation = Left. --- 31 Oct 95 SAIC Update and repair for ACVC 2.0.1. --- ---! - -with Report; -with Ada.Strings.Maps.Constants; -with Ada.Strings.Bounded; -with Ada.Strings.Maps; - -procedure CXA4008 is - -begin - - Report.Test("CXA4008", "Check that the subprograms defined in " & - "package Ada.Strings.Bounded are available, " & - "and that they produce correct results, " & - "especially under conditions where " & - "truncation of the result is required"); - - Test_Block: - declare - - package AS renames Ada.Strings; - package ASB renames Ada.Strings.Bounded; - package ASC renames Ada.Strings.Maps.Constants; - package Maps renames Ada.Strings.Maps; - - package B10 is new ASB.Generic_Bounded_Length(Max => 10); - use type B10.Bounded_String; - - Result_String : B10.Bounded_String; - Test_String : B10.Bounded_String; - AtoE_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("abcde"); - FtoJ_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("fghij"); - AtoJ_Bnd_Str : B10.Bounded_String := - B10.To_Bounded_String("abcdefghij"); - - Location : Natural := 0; - Total_Count : Natural := 0; - - CD_Set : Maps.Character_Set := Maps.To_Set("cd"); - - AB_to_YZ_Map : Maps.Character_Mapping := - Maps.To_Mapping(From => "ab", To => "yz"); - - CD_to_XY_Map : Maps.Character_Mapping := - Maps.To_Mapping(From => "cd", To => "xy"); - - - begin - -- Function To_Bounded_String with Truncation - -- Evaluate the function Append with parameters that will - -- cause the truncation of the result. - - -- Drop = Error (default case, Length_Error will be raised) - - begin - Test_String := - B10.To_Bounded_String("Much too long for this bounded string"); - Report.Failed("Length Error not raised by To_Bounded_String"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed("Incorrect exception raised by To_Bounded_String"); - end; - - -- Drop = Left - - Test_String := B10.To_Bounded_String(Source => "abcdefghijklmn", - Drop => Ada.Strings.Left); - - if Test_String /= B10.To_Bounded_String("efghijklmn") then - Report.Failed - ("Incorrect result from To_Bounded_String, Drop = Left"); - end if; - - -- Drop = Right - - Test_String := B10.To_Bounded_String(Source => "abcdefghijklmn", - Drop => Ada.Strings.Right); - - if not(Test_String = AtoJ_Bnd_Str) then - Report.Failed - ("Incorrect result from To_Bounded_String, Drop = Right"); - end if; - - - - - -- Function Append with Truncation - -- Evaluate the function Append with parameters that will - -- cause the truncation of the result. - - -- Drop = Error (default case, Length_Error will be raised) - - begin - -- Append (Bnd Str, Bnd Str); - Result_String := - B10.Append(B10.To_Bounded_String("abcde"), - B10.To_Bounded_String("fghijk")); -- 11 char - Report.Failed("Length_Error not raised by Append - 1"); - exception - when AS.Length_Error => null; -- OK, correct exception raised. - when others => - Report.Failed("Incorrect exception raised by Append - 1"); - end; - - begin - -- Append (Str, Bnd Str); - Result_String := B10.Append(B10.To_String(AtoE_Bnd_Str), - B10.To_Bounded_String("fghijk"), - AS.Error); - Report.Failed("Length_Error not raised by Append - 2"); - exception - when AS.Length_Error => null; -- OK, correct exception raised. - when others => - Report.Failed("Incorrect exception raised by Append - 2"); - end; - - begin - -- Append (Bnd Str, Char); - Result_String := - B10.Append(B10.To_Bounded_String("abcdefghij"), 'k'); - Report.Failed("Length_Error not raised by Append - 3"); - exception - when AS.Length_Error => null; -- OK, correct exception raised. - when others => - Report.Failed("Incorrect exception raised by Append - 3"); - end; - - -- Drop = Left - - -- Append (Bnd Str, Bnd Str) - Result_String := B10.Append(B10.To_Bounded_String("abcdefgh"), -- 8 chs - B10.To_Bounded_String("ijklmn"), -- 6 chs - Ada.Strings.Left); - - if Result_String /= B10.To_Bounded_String("efghijklmn") then -- 10 chars - Report.Failed("Incorrect truncation performed by Append - 4"); - end if; - - -- Append (Bnd Str, Str) - Result_String := - B10.Append(B10.To_Bounded_String("abcdefghij"), - "xyz", - Ada.Strings.Left); - - if Result_String /= B10.To_Bounded_String("defghijxyz") then - Report.Failed("Incorrect truncation performed by Append - 5"); - end if; - - -- Append (Char, Bnd Str) - - Result_String := B10.Append('A', - B10.To_Bounded_String("abcdefghij"), - Ada.Strings.Left); - - if Result_String /= B10.To_Bounded_String("abcdefghij") then - Report.Failed("Incorrect truncation performed by Append - 6"); - end if; - - -- Drop = Right - - -- Append (Bnd Str, Bnd Str) - Result_String := B10.Append(FtoJ_Bnd_Str, - AtoJ_Bnd_Str, - Ada.Strings.Right); - - if Result_String /= B10.To_Bounded_String("fghijabcde") then - Report.Failed("Incorrect truncation performed by Append - 7"); - end if; - - -- Append (Str, Bnd Str) - Result_String := B10.Append(B10.To_String(AtoE_Bnd_Str), - AtoJ_Bnd_Str, - Ada.Strings.Right); - - if Result_String /= B10.To_Bounded_String("abcdeabcde") then - Report.Failed("Incorrect truncation performed by Append - 8"); - end if; - - -- Append (Char, Bnd Str) - Result_String := B10.Append('A', AtoJ_Bnd_Str, Ada.Strings.Right); - - if Result_String /= B10.To_Bounded_String("Aabcdefghi") then - Report.Failed("Incorrect truncation performed by Append - 9"); - end if; - - - -- Function Index with non-Identity map. - -- Evaluate the function Index with a non-identity map - -- parameter which will cause mapping of the source parameter - -- prior to the evaluation of the index position search. - - Location := B10.Index(Source => AtoJ_Bnd_Str, -- "abcdefghij" - Pattern => "xy", - Going => Ada.Strings.Forward, - Mapping => CD_to_XY_Map); -- change "cd" to "xy" - - if Location /= 3 then - Report.Failed("Incorrect result from Index, non-Identity map - 1"); - end if; - - Location := B10.Index(B10.To_Bounded_String("AND IF MAN"), - "an", - Ada.Strings.Backward, - ASC.Lower_Case_Map); - - if Location /= 9 then - Report.Failed("Incorrect result from Index, non-Identity map - 2"); - end if; - - Location := B10.Index(Source => B10.To_Bounded_String("The the"), - Pattern => "the", - Going => Ada.Strings.Forward, - Mapping => ASC.Lower_Case_Map); - - if Location /= 1 then - Report.Failed("Incorrect result from Index, non-Identity map - 3"); - end if; - - - if B10.Index(B10.To_Bounded_String("abcd"), -- Pattern = Source - "abcd") /= 1 or - B10.Index(B10.To_Bounded_String("abc"), -- Pattern < Source - "abcd") /= 0 or - B10.Index(B10.Null_Bounded_String, -- Source = Null - "abc") /= 0 - then - Report.Failed("Incorrect result from Index with string patterns"); - end if; - - - -- Function Index (for Sets). - -- This version of Index uses Sets as the basis of the search. - - -- Test = Inside, Going = Forward (Default case). - Location := - B10.Index(Source => B10.To_Bounded_String("abcdeabcde"), - Set => CD_Set, -- set containing 'c' and 'd' - Test => Ada.Strings.Inside, - Going => Ada.Strings.Forward); - - if not (Location = 3) then -- position of first 'c' in source. - Report.Failed("Incorrect result from Index using Sets - 1"); - end if; - - -- Test = Inside, Going = Backward. - Location := - B10.Index(Source => B10."&"(AtoE_Bnd_Str, AtoE_Bnd_Str), - Set => CD_Set, -- set containing 'c' and 'd' - Test => Ada.Strings.Inside, - Going => Ada.Strings.Backward); - - if not (Location = 9) then -- position of last 'd' in source. - Report.Failed("Incorrect result from Index using Sets - 2"); - end if; - - -- Test = Outside, Going = Forward. - Location := B10.Index(B10.To_Bounded_String("deddacd"), - CD_Set, - Test => Ada.Strings.Outside, - Going => Ada.Strings.Forward); - - if Location /= 2 then -- position of 'e' in source. - Report.Failed("Incorrect result from Index using Sets - 3"); - end if; - - -- Test = Outside, Going = Backward. - Location := B10.Index(B10.To_Bounded_String("deddacd"), - CD_Set, - Ada.Strings.Outside, - Ada.Strings.Backward); - - if Location /= 5 then -- correct position of 'a'. - Report.Failed("Incorrect result from Index using Sets - 4"); - end if; - - if B10.Index(B10.To_Bounded_String("cd"), -- Source = Set - CD_Set) /= 1 or - B10.Index(B10.To_Bounded_String("c"), -- Source < Set - CD_Set) /= 1 or - B10.Index(B10.Null_Bounded_String, -- Source = Null - CD_Set) /= 0 or - B10.Index(AtoE_Bnd_Str, -- "abcde" - Maps.Null_Set) /= 0 or -- Null set - B10.Index(AtoE_Bnd_Str, - Maps.To_Set('x')) /= 0 -- No match. - then - Report.Failed("Incorrect result from Index using Sets - 5"); - end if; - - - -- Function Count with non-Identity mapping. - -- Evaluate the function Count with a non-identity map - -- parameter which will cause mapping of the source parameter - -- prior to the evaluation of the number of matching patterns. - - Total_Count := - B10.Count(Source => B10.To_Bounded_String("abbabaabab"), - Pattern => "yz", - Mapping => AB_to_YZ_Map); - - if Total_Count /= 4 then - Report.Failed - ("Incorrect result from function Count, non-Identity map - 1"); - end if; - - -- And a few with identity maps as well. - - if B10.Count(B10.To_Bounded_String("ABABABABAB"), - "ABA", - Maps.Identity) /= 2 or - B10.Count(B10.To_Bounded_String("ADCBADABCD"), - "AB", - Maps.To_Mapping("CD", "AB")) /= 5 or - B10.Count(B10.To_Bounded_String("aaaaaaaaaa"), - "aaa") /= 3 or - B10.Count(B10.To_Bounded_String("XX"), -- Source < Pattern - "XXX", - Maps.Identity) /= 0 or - B10.Count(AtoE_Bnd_Str, -- Source = Pattern - "abcde") /= 1 or - B10.Count(B10.Null_Bounded_String, -- Source = Null - " ") /= 0 - then - Report.Failed - ("Incorrect result from function Count, w,w/o mapping"); - end if; - - - -- Procedure Translate - - -- Partial mapping of source. - - Test_String := B10.To_Bounded_String("abcdeabcab"); - - B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); - - if Test_String /= B10.To_Bounded_String("yzcdeyzcyz") then - Report.Failed("Incorrect result from procedure Translate - 1"); - end if; - - -- Total mapping of source. - - Test_String := B10.To_Bounded_String("abbaaababb"); - - B10.Translate(Source => Test_String, Mapping => ASC.Upper_Case_Map); - - if Test_String /= B10.To_Bounded_String("ABBAAABABB") then - Report.Failed("Incorrect result from procedure Translate - 2"); - end if; - - -- No mapping of source. - - Test_String := B10.To_Bounded_String("xyzsypcc"); - - B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); - - if Test_String /= B10.To_Bounded_String("xyzsypcc") then - Report.Failed("Incorrect result from procedure Translate - 3"); - end if; - - -- Map > 2 characters, partial mapping. - - Test_String := B10.To_Bounded_String("have faith"); - - B10.Translate(Test_String, - Maps.To_Mapping("aeiou", "AEIOU")); - - if Test_String /= B10.To_Bounded_String("hAvE fAIth") then - Report.Failed("Incorrect result from procedure Translate - 4"); - end if; - - - -- Function Replace_Slice - -- Evaluate function Replace_Slice with - -- a variety of Truncation options. - - -- Drop = Error (Default) - - begin - Test_String := AtoJ_Bnd_Str; - Result_String := - B10.Replace_Slice(Source => Test_String, -- "abcdefghij" - Low => 3, - High => 5, -- 3-5, 3 chars. - By => "xxxxxx"); -- more than 3. - Report.Failed("Length_Error not raised by Function Replace_Slice"); - exception - when AS.Length_Error => null; -- Correct exception raised. - when others => - Report.Failed - ("Incorrect exception raised by Function Replace_Slice"); - end; - - -- Drop = Left - - Result_String := - B10.Replace_Slice(Source => Test_String, -- "abcdefghij" - Low => 7, - High => 10, -- 7-10, 4 chars. - By => "xxxxxx", -- 6 chars. - Drop => Ada.Strings.Left); - - if Result_String /= B10.To_Bounded_String("cdefxxxxxx") then -- drop a,b - Report.Failed - ("Incorrect result from Function Replace Slice, Drop = Left"); - end if; - - -- Drop = Right - - Result_String := - B10.Replace_Slice(Source => Test_String, -- "abcdefghij" - Low => 2, - High => 5, -- 2-5, 4 chars. - By => "xxxxxx", -- 6 chars. - Drop => Ada.Strings.Right); - - if Result_String /= B10.To_Bounded_String("axxxxxxfgh") then -- drop i,j - Report.Failed - ("Incorrect result from Function Replace Slice, Drop = Right"); - end if; - - -- Low = High = Source'Last, "By" length = 1. - - if B10.Replace_Slice(AtoE_Bnd_Str, - B10.To_String(AtoE_Bnd_Str)'Last, - B10.To_String(AtoE_Bnd_Str)'Last, - "X", - Ada.Strings.Error) /= - B10.To_Bounded_String("abcdX") - then - Report.Failed("Incorrect result from Function Replace_Slice"); - end if; - - - - -- Procedure Replace_Slice - -- Evaluate procedure Replace_Slice with - -- a variety of Truncation options. - - -- Drop = Error (Default) - - begin - Test_String := AtoJ_Bnd_Str; - B10.Replace_Slice(Source => Test_String, -- "abcdefghij" - Low => 3, - High => 5, -- 3-5, 3 chars. - By => "xxxxxx"); -- more than 3. - Report.Failed("Length_Error not raised by Procedure Replace_Slice"); - exception - when AS.Length_Error => null; -- Correct exception raised. - when others => - Report.Failed - ("Incorrect exception raised by Procedure Replace_Slice"); - end; - - -- Drop = Left - - Test_String := AtoJ_Bnd_Str; - B10.Replace_Slice(Source => Test_String, -- "abcdefghij" - Low => 7, - High => 9, -- 7-9, 3 chars. - By => "xxxxx", -- 5 chars. - Drop => Ada.Strings.Left); - - if Test_String /= B10.To_Bounded_String("cdefxxxxxj") then -- drop a,b - Report.Failed - ("Incorrect result from Procedure Replace Slice, Drop = Left"); - end if; - - -- Drop = Right - - Test_String := AtoJ_Bnd_Str; - B10.Replace_Slice(Source => Test_String, -- "abcdefghij" - Low => 1, - High => 3, -- 1-3, 3chars. - By => "xxxx", -- 4 chars. - Drop => Ada.Strings.Right); - - if Test_String /= B10.To_Bounded_String("xxxxdefghi") then -- drop j - Report.Failed - ("Incorrect result from Procedure Replace Slice, Drop = Right"); - end if; - - -- High = Source'First, Low > High (Insert before Low). - - Test_String := AtoE_Bnd_Str; - B10.Replace_Slice(Source => Test_String, -- "abcde" - Low => B10.To_String(Test_String)'Last, - High => B10.To_String(Test_String)'First, - By => "XXXX", -- 4 chars. - Drop => Ada.Strings.Right); - - if Test_String /= B10.To_Bounded_String("abcdXXXXe") then - Report.Failed - ("Incorrect result from Procedure Replace Slice"); - end if; - - - - -- Function Insert with Truncation - -- Drop = Error (Default). - - begin - Result_String := - B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij" - Before => 2, - New_Item => "xyz"); - Report.Failed("Length_Error not raised by Function Insert"); - exception - when AS.Length_Error => null; -- Correct exception raised. - when others => - Report.Failed("Incorrect exception raised by Function Insert"); - end; - - -- Drop = Left - - Result_String := - B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij" - Before => 5, - New_Item => "xyz", -- 3 additional chars. - Drop => Ada.Strings.Left); - - if B10.To_String(Result_String) /= "dxyzefghij" then -- drop a, b, c - Report.Failed("Incorrect result from Function Insert, Drop = Left"); - end if; - - -- Drop = Right - - Result_String := - B10.Insert(Source => B10.To_Bounded_String("abcdef"), - Before => 2, - New_Item => "vwxyz", -- 5 additional chars. - Drop => Ada.Strings.Right); - - if B10.To_String(Result_String) /= "avwxyzbcde" then -- drop f. - Report.Failed("Incorrect result from Function Insert, Drop = Right"); - end if; - - -- Additional cases. - - if B10.Insert(B10.To_Bounded_String("a"), 1, " B") /= - B10.To_Bounded_String(" Ba") or - B10.Insert(B10.Null_Bounded_String, 1, "abcde") /= - AtoE_Bnd_Str or - B10.Insert(B10.To_Bounded_String("ab"), 2, "") /= - B10.To_Bounded_String("ab") - then - Report.Failed("Incorrect result from Function Insert"); - end if; - - - -- Procedure Insert - - -- Drop = Error (Default). - begin - Test_String := AtoJ_Bnd_Str; - B10.Insert(Source => Test_String, -- "abcdefghij" - Before => 9, - New_Item => "wxyz", - Drop => Ada.Strings.Error); - Report.Failed("Length_Error not raised by Procedure Insert"); - exception - when AS.Length_Error => null; -- Correct exception raised. - when others => - Report.Failed("Incorrect exception raised by Procedure Insert"); - end; - - -- Drop = Left - - Test_String := AtoJ_Bnd_Str; - B10.Insert(Source => Test_String, -- "abcdefghij" - Before => B10.Length(Test_String), -- before last char - New_Item => "xyz", -- 3 additional chars. - Drop => Ada.Strings.Left); - - if B10.To_String(Test_String) /= "defghixyzj" then -- drop a, b, c - Report.Failed("Incorrect result from Procedure Insert, Drop = Left"); - end if; - - -- Drop = Right - - Test_String := AtoJ_Bnd_Str; - B10.Insert(Source => Test_String, - Before => 4, - New_Item => "yz", -- 2 additional chars. - Drop => Ada.Strings.Right); - - if B10.To_String(Test_String) /= "abcyzdefgh" then -- drop i,j - Report.Failed - ("Incorrect result from Procedure Insert, Drop = Right"); - end if; - - -- Before = Source'First, New_Item length = 1. - - Test_String := B10.To_Bounded_String(" abc "); - B10.Insert(Test_String, - B10.To_String(Test_String)'First, - "Z"); - - if Test_String /= B10.To_Bounded_String("Z abc ") then - Report.Failed("Incorrect result from Procedure Insert"); - end if; - - - exception - when others => Report.Failed("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA4008; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a deleted file mode 100644 index f02ef036507..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a +++ /dev/null @@ -1,619 +0,0 @@ --- CXA4009.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 subprograms defined in package Ada.Strings.Bounded are --- available, and that they produce correct results, especially under --- conditions where truncation of the result is required. Specifically, --- check the subprograms Overwrite (function and procedure), Delete, --- Function Trim (blanks), Trim (Set characters, function and procedure), --- Head, Tail, and Replicate (characters and strings). --- --- TEST DESCRIPTION: --- This test, in conjunction with tests CXA4006, CXA4007, and CXA4008, --- will provide coverage of the most common usages of the functionality --- found in the Ada.Strings.Bounded package. It deals in large part --- with truncation effects and options. This test contains many small, --- specific test cases, situations that are often difficult to generate --- in large numbers in an application-based test. These cases represent --- specific usage paradigms in-the-small. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 10 Apr 95 SAIC Corrected errors in Procedure Overwrite subtests. --- 01 Nov 95 SAIC Fixed bugs for ACVC 2.0.1. --- ---! - -with Report; -with Ada.Strings.Bounded; -with Ada.Strings.Maps; - -procedure CXA4009 is - -begin - - Report.Test("CXA4009", "Check that the subprograms defined in " & - "package Ada.Strings.Bounded are available, " & - "and that they produce correct results, " & - "especially under conditions where " & - "truncation of the result is required"); - - Test_Block: - declare - - package AS renames Ada.Strings; - package ASB renames Ada.Strings.Bounded; - package Maps renames Ada.Strings.Maps; - - package B10 is new ASB.Generic_Bounded_Length(Max => 10); - use type B10.Bounded_String; - - Result_String : B10.Bounded_String; - Test_String : B10.Bounded_String; - AtoE_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("abcde"); - FtoJ_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("fghij"); - AtoJ_Bnd_Str : B10.Bounded_String := - B10.To_Bounded_String("abcdefghij"); - - Location : Natural := 0; - Total_Count : Natural := 0; - - CD_Set : Maps.Character_Set := Maps.To_Set("cd"); - XY_Set : Maps.Character_Set := Maps.To_Set("xy"); - - - begin - - -- Function Overwrite with Truncation - -- Drop = Error (Default). - - begin - Test_String := AtoJ_Bnd_Str; - Result_String := - B10.Overwrite(Source => Test_String, -- "abcdefghij" - Position => 9, - New_Item => "xyz", - Drop => AS.Error); - Report.Failed("Exception not raised by Function Overwrite"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed("Incorrect exception raised by Function Overwrite"); - end; - - -- Drop = Left - - Result_String := - B10.Overwrite(Source => Test_String, -- "abcdefghij" - Position => B10.Length(Test_String), -- 10 - New_Item => "xyz", - Drop => Ada.Strings.Left); - - if B10.To_String(Result_String) /= "cdefghixyz" then -- drop a,b - Report.Failed - ("Incorrect result from Function Overwrite, Drop = Left"); - end if; - - -- Drop = Right - - Result_String := B10.Overwrite(Test_String, -- "abcdefghij" - 3, - "xxxyyyzzz", - Ada.Strings.Right); - - if B10.To_String(Result_String) /= "abxxxyyyzz" then -- one 'z' dropped - Report.Failed - ("Incorrect result from Function Overwrite, Drop = Right"); - end if; - - -- Additional cases of function Overwrite. - - if B10.Overwrite(B10.To_Bounded_String("a"), -- Source length = 1 - 1, - " abc ") /= - B10.To_Bounded_String(" abc ") or - B10.Overwrite(B10.Null_Bounded_String, -- Null source - 1, - "abcdefghij") /= - AtoJ_Bnd_Str or - B10.Overwrite(AtoE_Bnd_Str, - B10.To_String(AtoE_Bnd_Str)'First, - " ") /= -- New_Item = 1 - B10.To_Bounded_String(" bcde") - then - Report.Failed("Incorrect result from Function Overwrite"); - end if; - - - - -- Procedure Overwrite - -- Correct usage, no truncation. - - Test_String := AtoE_Bnd_Str; -- "abcde" - B10.Overwrite(Test_String, 2, "xyz"); - - if Test_String /= B10.To_Bounded_String("axyze") then - Report.Failed("Incorrect result from Procedure Overwrite - 1"); - end if; - - Test_String := B10.To_Bounded_String("abc"); - B10.Overwrite(Test_String, 2, ""); -- New_Item is null string. - - if Test_String /= B10.To_Bounded_String("abc") then - Report.Failed("Incorrect result from Procedure Overwrite - 2"); - end if; - - -- Drop = Error (Default). - - begin - Test_String := AtoJ_Bnd_Str; - B10.Overwrite(Source => Test_String, -- "abcdefghij" - Position => 8, - New_Item => "uvwxyz"); - Report.Failed("Exception not raised by Procedure Overwrite"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed("Incorrect exception raised by Procedure Overwrite"); - end; - - -- Drop = Left - - Test_String := AtoJ_Bnd_Str; - B10.Overwrite(Source => Test_String, -- "abcdefghij" - Position => B10.Length(Test_String) - 2, -- 8 - New_Item => "uvwxyz", - Drop => Ada.Strings.Left); - - if B10.To_String(Test_String) /= "defguvwxyz" then -- drop a-c - Report.Failed - ("Incorrect result from Procedure Overwrite, Drop = Left"); - end if; - - -- Drop = Right - - Test_String := AtoJ_Bnd_Str; - B10.Overwrite(Test_String, -- "abcdefghij" - 3, - "xxxyyyzzz", - Ada.Strings.Right); - - if B10.To_String(Test_String) /= "abxxxyyyzz" then -- one 'z' dropped - Report.Failed - ("Incorrect result from Procedure Overwrite, Drop = Right"); - end if; - - - - -- Function Delete - - if B10.Delete(Source => AtoJ_Bnd_Str, -- "abcdefghij" - From => 3, - Through => 8) /= - B10."&"(B10.Head(AtoJ_Bnd_Str, 2), - B10.Tail(AtoJ_Bnd_Str, 2)) or - B10.Delete(AtoJ_Bnd_Str, 6, B10.Length(AtoJ_Bnd_Str)) /= - AtoE_Bnd_Str or - B10.Delete(AtoJ_Bnd_Str, 1, 5) /= - FtoJ_Bnd_Str or - B10.Delete(AtoE_Bnd_Str, 4, 5) /= - B10.Delete(AtoJ_Bnd_Str, 4, B10.Length(AtoJ_Bnd_Str)) - then - Report.Failed("Incorrect result from Function Delete - 1"); - end if; - - if B10.Delete(B10.To_Bounded_String("a"), 1, 1) /= - B10.Null_Bounded_String or - B10.Delete(AtoE_Bnd_Str, - 5, - B10.To_String(AtoE_Bnd_Str)'First) /= - AtoE_Bnd_Str or - B10.Delete(AtoE_Bnd_Str, - B10.To_String(AtoE_Bnd_Str)'Last, - B10.To_String(AtoE_Bnd_Str)'Last) /= - B10.To_Bounded_String("abcd") - then - Report.Failed("Incorrect result from Function Delete - 2"); - end if; - - - - -- Function Trim - - declare - - Text : B10.Bounded_String := B10.To_Bounded_String("Text"); - type Bnd_Array_Type is array (1..5) of B10.Bounded_String; - Bnd_Array : Bnd_Array_Type := - (B10.To_Bounded_String(" Text"), - B10.To_Bounded_String("Text "), - B10.To_Bounded_String(" Text "), - B10.To_Bounded_String("Text Text"), -- Ensure no inter-string - B10.To_Bounded_String(" Text Text")); -- trimming of blanks. - - begin - - for i in Bnd_Array_Type'Range loop - case i is - when 4 => - if B10.Trim(Bnd_Array(i), AS.Both) /= - Bnd_Array(i) then -- no change - Report.Failed("Incorrect result from Function Trim - 4"); - end if; - when 5 => - if B10.Trim(Bnd_Array(i), AS.Both) /= - B10."&"(Text, B10."&"(' ', Text)) then - Report.Failed("Incorrect result from Function Trim - 5"); - end if; - when others => - if B10.Trim(Bnd_Array(i), AS.Both) /= Text then - Report.Failed("Incorrect result from Function Trim - " & - Integer'Image(i)); - end if; - end case; - end loop; - - end; - - - - -- Function Trim using Sets - - -- Trim characters in sets from both sides of the bounded string. - if B10.Trim(Source => B10.To_Bounded_String("ddabbaxx"), - Left => CD_Set, - Right => XY_Set) /= - B10.To_Bounded_String("abba") - then - Report.Failed - ("Incorrect result from Fn Trim - Sets, Left & Right side - 1"); - end if; - - -- Ensure that the characters in the set provided as the actual to - -- parameter Right are not trimmed from the left side of the bounded - -- string; likewise for the opposite side. Only "cd" trimmed from left - -- side, and only "xy" trimmed from right side. - - if B10.Trim(B10.To_Bounded_String("cdxyabcdxy"), CD_Set, XY_Set) /= - B10.To_Bounded_String("xyabcd") - then - Report.Failed - ("Incorrect result from Fn Trim - Sets, Left & Right side - 2"); - end if; - - -- Ensure that characters contained in the sets are not trimmed from - -- the "interior" of the bounded string, just the appropriate ends. - - if B10.Trim(B10.To_Bounded_String("cdabdxabxy"), CD_Set, XY_Set) /= - B10.To_Bounded_String("abdxab") - then - Report.Failed - ("Incorrect result from Fn Trim - Sets, Left & Right side - 3"); - end if; - - -- Trim characters in set from right side only. No change to Left side. - - if B10.Trim(B10.To_Bounded_String("abxyzddcd"), XY_Set, CD_Set) /= - B10.To_Bounded_String("abxyz") - then - Report.Failed - ("Incorrect result from Fn Trim - Sets, Right side"); - end if; - - -- Trim no characters on either side of the bounded string. - - Result_String := B10.Trim(AtoJ_Bnd_Str, CD_Set, XY_Set); - if Result_String /= AtoJ_Bnd_Str then - Report.Failed("Incorrect result from Fn Trim - Sets, Neither side"); - end if; - - if B10.Trim(AtoE_Bnd_Str, Maps.Null_Set, Maps.Null_Set) /= - AtoE_Bnd_Str or - B10.Trim(B10.To_Bounded_String("dcddcxyyxx"), - CD_Set, - XY_Set) /= - B10.Null_Bounded_String - then - Report.Failed("Incorrect result from Function Trim"); - end if; - - - - -- Procedure Trim using Sets - - -- Trim characters in sets from both sides of the bounded string. - - Test_String := B10.To_Bounded_String("dcabbayx"); - B10.Trim(Source => Test_String, - Left => CD_Set, - Right => XY_Set); - - if Test_String /= B10.To_Bounded_String("abba") then - Report.Failed - ("Incorrect result from Proc Trim - Sets, Left & Right side - 1"); - end if; - - -- Ensure that the characters in the set provided as the actual to - -- parameter Right are not trimmed from the left side of the bounded - -- string; likewise for the opposite side. Only "cd" trimmed from left - -- side, and only "xy" trimmed from right side. - - Test_String := B10.To_Bounded_String("cdxyabcdxy"); - B10.Trim(Test_String, CD_Set, XY_Set); - - if Test_String /= B10.To_Bounded_String("xyabcd") then - Report.Failed - ("Incorrect result from Proc Trim - Sets, Left & Right side - 2"); - end if; - - -- Ensure that characters contained in the sets are not trimmed from - -- the "interior" of the bounded string, just the appropriate ends. - - Test_String := B10.To_Bounded_String("cdabdxabxy"); - B10.Trim(Test_String, CD_Set, XY_Set); - - if not (Test_String = B10.To_Bounded_String("abdxab")) then - Report.Failed - ("Incorrect result from Proc Trim - Sets, Left & Right side - 3"); - end if; - - -- Trim characters in set from Left side only. No change to Right side. - - Test_String := B10.To_Bounded_String("cccdabxyz"); - B10.Trim(Test_String, CD_Set, XY_Set); - - if Test_String /= B10.To_Bounded_String("abxyz") then - Report.Failed - ("Incorrect result from Proc Trim for Sets, Left side only"); - end if; - - -- Trim no characters on either side of the bounded string. - - Test_String := AtoJ_Bnd_Str; - B10.Trim(Test_String, CD_Set, CD_Set); - - if Test_String /= AtoJ_Bnd_Str then - Report.Failed("Incorrect result from Proc Trim-Sets, Neither side"); - end if; - - - - -- Function Head with Truncation - -- Drop = Error (Default). - - begin - Result_String := B10.Head(Source => AtoJ_Bnd_Str, -- max length - Count => B10.Length(AtoJ_Bnd_Str) + 1, - Pad => 'X'); - Report.Failed("Length_Error not raised by Function Head"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed("Incorrect exception raised by Function Head"); - end; - - -- Drop = Left - - -- Pad characters (5) are appended to the right end of the string - -- (which is initially at its maximum length), then the first five - -- characters of the intermediate result are dropped to conform to - -- the maximum size limit of the bounded string (10). - - Result_String := B10.Head(B10.To_Bounded_String("ABCDEFGHIJ"), - 15, - 'x', - Ada.Strings.Left); - - if Result_String /= B10.To_Bounded_String("FGHIJxxxxx") then - Report.Failed("Incorrect result from Function Head, Drop = Left"); - end if; - - -- Drop = Right - - -- Pad characters (6) are appended to the left end of the string - -- (which is initially at one less than its maximum length), then the - -- last five characters of the intermediate result are dropped - -- (which in this case are the pad characters) to conform to the - -- maximum size limit of the bounded string (10). - - Result_String := B10.Head(B10.To_Bounded_String("ABCDEFGHI"), - 15, - 'x', - Ada.Strings.Right); - - if Result_String /= B10.To_Bounded_String("ABCDEFGHIx") then - Report.Failed("Incorrect result from Function Head, Drop = Right"); - end if; - - -- Additional cases. - - if B10.Head(B10.Null_Bounded_String, 5) /= - B10.To_Bounded_String(" ") or - B10.Head(AtoE_Bnd_Str, - B10.Length(AtoE_Bnd_Str)) /= - AtoE_Bnd_Str - then - Report.Failed("Incorrect result from Function Head"); - end if; - - - - -- Function Tail with Truncation - -- Drop = Error (Default Case) - - begin - Result_String := B10.Tail(Source => AtoJ_Bnd_Str, -- max length - Count => B10.Length(AtoJ_Bnd_Str) + 1, - Pad => Ada.Strings.Space, - Drop => Ada.Strings.Error); - Report.Failed("Length_Error not raised by Function Tail"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed("Incorrect exception raised by Function Tail"); - end; - - -- Drop = Left - - -- Pad characters (5) are appended to the left end of the string - -- (which is initially at two less than its maximum length), then - -- the first three characters of the intermediate result (in this - -- case, 3 pad characters) are dropped. - - Result_String := B10.Tail(B10.To_Bounded_String("ABCDEFGH"), -- 8 ch - 13, - 'x', - Ada.Strings.Left); - - if Result_String /= B10.To_Bounded_String("xxABCDEFGH") then - Report.Failed("Incorrect result from Function Tail, Drop = Left"); - end if; - - -- Drop = Right - - -- Pad characters (3) are appended to the left end of the string - -- (which is initially at its maximum length), then the last three - -- characters of the intermediate result are dropped. - - Result_String := B10.Tail(B10.To_Bounded_String("ABCDEFGHIJ"), - 13, - 'x', - Ada.Strings.Right); - - if Result_String /= B10.To_Bounded_String("xxxABCDEFG") then - Report.Failed("Incorrect result from Function Tail, Drop = Right"); - end if; - - -- Additional cases. - - if B10.Tail(B10.Null_Bounded_String, 3, ' ') /= - B10.To_Bounded_String(" ") or - B10.Tail(AtoE_Bnd_Str, - B10.To_String(AtoE_Bnd_Str)'First) /= - B10.To_Bounded_String("e") - then - Report.Failed("Incorrect result from Function Tail"); - end if; - - - - -- Function Replicate (#, Char) with Truncation - -- Drop = Error (Default). - - begin - Result_String := B10.Replicate(Count => B10.Max_Length + 5, - Item => 'A', - Drop => AS.Error); - Report.Failed - ("Length_Error not raised by Replicate for characters"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed - ("Incorrect exception raised by Replicate for characters"); - end; - - -- Drop = Left, Right - -- Since this version of Replicate uses character parameters, the - -- result after truncation from left or right will appear the same. - -- The result will be a 10 character bounded string, composed of 10 - -- "Item" characters. - - if B10.Replicate(Count => 20, Item => 'A', Drop => Ada.Strings.Left) /= - B10.Replicate(15, 'A', Ada.Strings.Right) - then - Report.Failed("Incorrect result from Replicate for characters - 1"); - end if; - - -- Blank-filled 10 character bounded strings. - - if B10.Replicate(B10.Max_Length + 1, ' ', Drop => Ada.Strings.Left) /= - B10.Replicate(B10.Max_Length, Ada.Strings.Space) - then - Report.Failed("Incorrect result from Replicate for characters - 2"); - end if; - - -- Additional cases. - - if B10.Replicate(0, 'a') /= B10.Null_Bounded_String or - B10.Replicate(1, 'a') /= B10.To_Bounded_String("a") - then - Report.Failed("Incorrect result from Replicate for characters - 3"); - end if; - - - - -- Function Replicate (#, String) with Truncation - -- Drop = Error (Default). - - begin - Result_String := B10.Replicate(Count => 5, -- result would be 15. - Item => "abc"); - Report.Failed - ("Length_Error not raised by Replicate for strings"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed - ("Incorrect exception raised by Replicate for strings"); - end; - - -- Drop = Left - - Result_String := B10.Replicate(3, "abcd", Drop => Ada.Strings.Left); - - if Result_String /= B10.To_Bounded_String("cdabcdabcd") then - Report.Failed - ("Incorrect result from Replicate for strings, Drop = Left"); - end if; - - -- Drop = Right - - Result_String := B10.Replicate(3, "abcd", Drop => Ada.Strings.Right); - - if Result_String /= B10.To_Bounded_String("abcdabcdab") then - Report.Failed - ("Incorrect result from Replicate for strings, Drop = Right"); - end if; - - -- Additional cases. - - if B10.Replicate(10, "X") /= B10.To_Bounded_String("XXXXXXXXXX") or - B10.Replicate(10, "") /= B10.Null_Bounded_String or - B10.Replicate( 0, "ab") /= B10.Null_Bounded_String - then - Report.Failed("Incorrect result from Replicate for strings"); - end if; - - - exception - when others => Report.Failed("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA4009; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a deleted file mode 100644 index 8646b12b5e4..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a +++ /dev/null @@ -1,275 +0,0 @@ --- CXA4010.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 subprograms defined in package Ada.Strings.Unbounded --- are available, and that they produce correct results. Specifically, --- check the subprograms To_String, To_Unbounded_String, Insert, "&", --- "*", Length, Slice, Replace_Slice, Overwrite, Index, Index_Non_Blank, --- Head, Tail, and "=", "<=", ">=". --- --- TEST DESCRIPTION: --- This test demonstrates the uses of many of the subprograms defined --- in package Ada.Strings.Unbounded for use with unbounded strings. --- The test simulates how unbounded strings could be used --- to simulate paragraphs of text. Modifications could be easily be --- performed using the provided subprograms (although in this test, the --- main modification performed was the addition of more text to the --- string). One would not have to worry about the formatting of the --- paragraph until it was finished and correct in content. Then, once --- all required editing is complete, the unbounded strings can be divided --- up into the appropriate lengths based on particular formatting --- requirements. The test then compares the formatted text product --- with a predefined "finished product". --- --- This test uses a large number of the subprograms provided --- by package Ada.Strings.Unbounded. Often, the processing involved --- could have been performed more efficiently using a minimum number --- of the subprograms, in conjunction with loops, etc. However, for --- testing purposes, and in the interest of minimizing the number of --- tests developed, subprogram variety and feature mixing was stressed. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with Report; -with Ada.Strings.Maps; -with Ada.Strings.Unbounded; - -procedure CXA4010 is -begin - - Report.Test ("CXA4010", "Check that the subprograms defined in " & - "package Ada.Strings.Unbounded are available, " & - "and that they produce correct results"); - - Test_Block: - declare - - package ASUnb renames Ada.Strings.Unbounded; - use type ASUnb.Unbounded_String; - use Ada.Strings; - - Pamphlet_Paragraph_Count : constant := 2; - Lines : constant := 4; - Line_Length : constant := 40; - - type Document_Type is array (Positive range <>) - of ASUnb.Unbounded_String; - - type Camera_Ready_Copy_Type is array (1..Lines) - of String (1..Line_Length); - - Pamphlet : Document_Type (1..Pamphlet_Paragraph_Count); - - Camera_Ready_Copy : Camera_Ready_Copy_Type := - (others => (others => Ada.Strings.Space)); - - TC_Finished_Product : Camera_Ready_Copy_Type := - ( 1 => "Ada is a programming language designed ", - 2 => "to support long-lived, reliable software", - 3 => " systems. ", - 4 => "Go with Ada! "); - - ----- - - - procedure Enter_Text_Into_Document (Document : in out Document_Type) is - begin - - -- Fill in both "paragraphs" of the document. Each unbounded string - -- functions as an individual paragraph, containing an unspecified - -- number of characters. - -- Use a variety of different unbounded string subprograms to load - -- the data. - - Document(1) := ASUnb.To_Unbounded_String("Ada is a language"); - - -- Insert the word "programming" prior to "language". - Document(1) := - ASUnb.Insert(Document(1), - ASUnb.Index(Document(1), - "language"), - ASUnb.To_String("progra" & -- Str & - ASUnb."*"(2,'m') & -- Unbd & - "ing ")); -- Str - - - -- Overwrite the word "language" with "language" + additional text. - Document(1) := - ASUnb.Overwrite(Document(1), - ASUnb.Index(Document(1), - ASUnb.To_String( - ASUnb.Tail(Document(1), 8, ' ')), - Ada.Strings.Backward), - "language designed to support long-lifed"); - - - -- Replace the word "lifed" with "lived". - Document(1) := - ASUnb.Replace_Slice(Document(1), - ASUnb.Index(Document(1), "lifed"), - ASUnb.Length(Document(1)), - "lived"); - - - -- Overwrite the word "lived" with "lived" + additional text. - Document(1) := - ASUnb.Overwrite(Document(1), - ASUnb.Index(Document(1), - ASUnb.To_String( - ASUnb.Tail(Document(1), 5, ' ')), - Ada.Strings.Backward), - "lived, reliable software systems."); - - - -- Use several of the overloaded versions of "&" to form this - -- unbounded string. - - Document(2) := 'G' & - ASUnb.To_Unbounded_String("o ") & - ASUnb.To_Unbounded_String("with") & - ' ' & - "Ada!"; - - end Enter_Text_Into_Document; - - - ----- - - - procedure Create_Camera_Ready_Copy - (Document : in Document_Type; - Camera_Copy : out Camera_Ready_Copy_Type) is - begin - -- Break the unbounded strings into fixed lengths. - - -- Search the first unbounded string for portions of text that - -- are less than or equal to the length of a string in the - -- Camera_Ready_Copy_Type object. - - Camera_Copy(1) := -- Take characters 1-39, - ASUnb.Slice(Document(1), -- and append a blank space. - 1, - ASUnb.Index(ASUnb.To_Unbounded_String( - ASUnb.Slice(Document(1), - 1, - Line_Length)), - Ada.Strings.Maps.To_Set(' '), - Ada.Strings.Inside, - Ada.Strings.Backward)) & ' '; - - Camera_Copy(2) := -- Take characters 40-79. - ASUnb.Slice(Document(1), - 40, - (ASUnb.Index_Non_Blank -- Should return 79 - (ASUnb.To_Unbounded_String - (ASUnb.Slice(Document(1), -- Slice (40..79) - 40, - 79)), - Ada.Strings.Backward) + 39)); -- Increment since - -- this slice starts - -- at 40. - - Camera_Copy(3)(1..9) := ASUnb.Slice(Document(1), -- Characters 80-88 - 80, - ASUnb.Length(Document(1))); - - - -- Break the second unbounded string into the appropriate length. - -- It is only twelve characters in length, so the entire unbounded - -- string will be placed on one string of the output object. - - Camera_Copy(4)(1..ASUnb.Length(Document(2))) := - ASUnb.To_String(ASUnb.Head(Document(2), - ASUnb.Length(Document(2)))); - - end Create_Camera_Ready_Copy; - - - ----- - - - function Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type) - return Boolean is - begin - - -- Evaluate strings for equality, using the operators defined in - -- package Ada.Strings.Unbounded. The less than/greater than or - -- equal comparisons should evaluate to "equals => True". - - if ASUnb.To_Unbounded_String(Draft(1)) = -- "="(Unb,Unb) - ASUnb.To_Unbounded_String(Master(1)) and - ASUnb.To_Unbounded_String(Draft(2)) <= -- "<="(Unb,Unb) - ASUnb.To_Unbounded_String(Master(2)) and - ASUnb.To_Unbounded_String(Draft(3)) >= -- ">="(Unb,Unb) - ASUnb.To_Unbounded_String(Master(3)) and - ASUnb.To_Unbounded_String(Draft(4)) = -- "="(Unb,Unb) - ASUnb.To_Unbounded_String(Master(4)) - then - return True; - else - return False; - end if; - - end Valid_Proofread; - - - ----- - - - begin - - -- Enter text into the unbounded string paragraphs of the document. - - Enter_Text_Into_Document (Pamphlet); - - - -- Reformat the unbounded strings into fixed string format. - - Create_Camera_Ready_Copy (Document => Pamphlet, - Camera_Copy => Camera_Ready_Copy); - - - -- Verify the conversion process. - - if not Valid_Proofread (Draft => Camera_Ready_Copy, - Master => TC_Finished_Product) - then - Report.Failed ("Incorrect string processing result"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4010; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a deleted file mode 100644 index 05388a04ba7..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a +++ /dev/null @@ -1,376 +0,0 @@ --- CXA4011.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 subprograms defined in package Ada.Strings.Unbounded --- are available, and that they produce correct results. Specifically, --- check the subprograms To_Unbounded_String, "&", ">", "<", Element, --- Replace_Element, Count, Find_Token, Translate, Trim, Delete, and --- "*". --- --- TEST DESCRIPTION: --- This test demonstrates the uses of many of the subprograms defined --- in package Ada.Strings.Unbounded for use with unbounded strings. --- The test simulates how unbounded strings could be processed in a --- user environment, using the subprograms provided in this package. --- --- This test uses a variety of the subprograms defined in the unbounded --- string package in ways typical of common usage, with different --- combinations of available subprograms being used to accomplish --- similar unbounded string processing goals. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 27 Feb 95 SAIC Test description modification. --- 01 Nov 95 SAIC Update and repair for ACVC 2.0.1. --- ---! - -with Report; -with Ada.Strings.Maps; -with Ada.Strings.Unbounded; - -procedure CXA4011 is -begin - - Report.Test ("CXA4011", "Check that the subprograms defined in " & - "package Ada.Strings.Unbounded are available, " & - "and that they produce correct results"); - - Test_Block: - declare - - package ASUnb renames Ada.Strings.Unbounded; - use Ada.Strings; - use type Maps.Character_Set; - use type ASUnb.Unbounded_String; - - Cad_String : ASUnb.Unbounded_String := - ASUnb.To_Unbounded_String("cad"); - - Complete_String : ASUnb.Unbounded_String := - ASUnb.To_Unbounded_String("Incomplete") & - Ada.Strings.Space & - ASUnb.To_Unbounded_String("String"); - - Incomplete_String : ASUnb.Unbounded_String := - ASUnb.To_Unbounded_String("ncomplete Strin"); - - Incorrect_Spelling : ASUnb.Unbounded_String := - ASUnb.To_Unbounded_String("Guob Dai"); - - Magic_String : ASUnb.Unbounded_String := - ASUnb.To_Unbounded_String("abracadabra"); - - Incantation : ASUnb.Unbounded_String := Magic_String; - - - A_Small_G : Character := 'g'; - A_Small_D : Character := 'd'; - - ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd"); - B_Set : Maps.Character_Set := Maps.To_Set('b'); - AB_Set : Maps.Character_Set := Maps."OR"(Maps.To_Set('a'), B_Set); - - Code_Map : Maps.Character_Mapping := - Maps.To_Mapping(From => "abcd", To => "wxyz"); - Reverse_Code_Map : Maps.Character_Mapping := - Maps.To_Mapping(From => "wxyz", To => "abcd"); - Non_Existent_Map : Maps.Character_Mapping := - Maps.To_Mapping(From => "jkl", To => "mno"); - - - Token_Start : Positive; - Token_End : Natural := 0; - Matching_Letters : Natural := 0; - - - begin - - -- "&" - - -- Prepend an 'I' and append a 'g' to the string. - Incomplete_String := ASUnb."&"('I', Incomplete_String); -- Char & Unb - Incomplete_String := ASUnb."&"(Incomplete_String, - A_Small_G); -- Unb & Char - - if Incomplete_String < Complete_String or - Incomplete_String > Complete_String or - Incomplete_String /= Complete_String - then - Report.Failed("Incorrect result from use of ""&"" operator"); - end if; - - - -- Element - - -- Last element of the unbounded string should be a 'g'. - if ASUnb.Element(Incomplete_String, ASUnb.Length(Incomplete_String)) /= - A_Small_G - then - Report.Failed("Incorrect result from use of Function Element - 1"); - end if; - - if ASUnb.Element(Incomplete_String, 2) /= - ASUnb.Element(ASUnb.Tail(Incomplete_String, 2), 1) or - ASUnb.Element(ASUnb.Head(Incomplete_String, 4), 2) /= - ASUnb.Element(ASUnb.To_Unbounded_String("wnqz"), 2) - then - Report.Failed("Incorrect result from use of Function Element - 2"); - end if; - - - -- Replace_Element - - -- The unbounded string Incorrect_Spelling starts as "Guob Dai", and - -- is transformed by the following three procedure calls to "Good Day". - - ASUnb.Replace_Element(Incorrect_Spelling, 2, 'o'); - - ASUnb.Replace_Element(Incorrect_Spelling, - ASUnb.Index(Incorrect_Spelling, B_Set), - A_Small_D); - - ASUnb.Replace_Element(Source => Incorrect_Spelling, - Index => ASUnb.Length(Incorrect_Spelling), - By => 'y'); - - if Incorrect_Spelling /= ASUnb.To_Unbounded_String("Good Day") then - Report.Failed("Incorrect result from Procedure Replace_Element"); - end if; - - - -- Count - - -- Determine the number of characters in the unbounded string that - -- are contained in the set. - - Matching_Letters := ASUnb.Count(Source => Magic_String, - Set => ABCD_Set); - - if Matching_Letters /= 9 then - Report.Failed - ("Incorrect result from Function Count with Set parameter"); - end if; - - -- Determine the number of occurrences of the following pattern strings - -- in the unbounded string Magic_String. - - if ASUnb.Count(Magic_String, "ab") /= - (ASUnb.Count(Magic_String, "ac") + ASUnb.Count(Magic_String, "ad")) or - ASUnb.Count(Magic_String, "ab") /= 2 - then - Report.Failed - ("Incorrect result from Function Count with String parameter"); - end if; - - - -- Find_Token - - ASUnb.Find_Token(Magic_String, -- Find location of first "ab". - AB_Set, -- Should be (1..2). - Ada.Strings.Inside, - Token_Start, - Token_End); - - if Natural(Token_Start) /= ASUnb.To_String(Magic_String)'First or - Token_End /= ASUnb.Index(Magic_String, B_Set) - then - Report.Failed("Incorrect result from Procedure Find_Token - 1"); - end if; - - - ASUnb.Find_Token(Source => Magic_String, -- Find location of char 'r' - Set => ABCD_Set, -- in string, should be (3..3) - Test => Ada.Strings.Outside, - First => Token_Start, - Last => Token_End); - - if Natural(Token_Start) /= 3 or - Token_End /= 3 then - Report.Failed("Incorrect result from Procedure Find_Token - 2"); - end if; - - - ASUnb.Find_Token(Magic_String, -- No 'g' is in the string, so - Maps.To_Set(A_Small_G), -- the result parameters should - Ada.Strings.Inside, -- be First = Source'First and - First => Token_Start, -- Last = 0. - Last => Token_End); - - if Token_Start /= ASUnb.To_String(Magic_String)'First or - Token_End /= 0 - then - Report.Failed("Incorrect result from Procedure Find_Token - 3"); - end if; - - - -- Translate - - -- Use a mapping ("abcd" -> "wxyz") to transform the contents of - -- the unbounded string. - -- Magic_String = "abracadabra" - - Incantation := ASUnb.Translate(Magic_String, Code_Map); - - if Incantation /= ASUnb.To_Unbounded_String("wxrwywzwxrw") then - Report.Failed("Incorrect result from Function Translate"); - end if; - - -- Use the inverse mapping of the one above to return the "translated" - -- unbounded string to its original form. - - ASUnb.Translate(Incantation, Reverse_Code_Map); - - -- The map contained in the following call to Translate contains one - -- element, and this element is not found in the unbounded string, so - -- this call to Translate should have no effect on the unbounded string. - - if Incantation /= ASUnb.Translate(Magic_String, Non_Existent_Map) then - Report.Failed("Incorrect result from Procedure Translate"); - end if; - - - -- Trim - - Trim_Block: - declare - - XYZ_Set : Maps.Character_Set := Maps.To_Set("xyz"); - PQR_Set : Maps.Character_Set := Maps.To_Set("pqr"); - - Pad : constant ASUnb.Unbounded_String := - ASUnb.To_Unbounded_String("Pad"); - - The_New_Ada : constant ASUnb.Unbounded_String := - ASUnb.To_Unbounded_String("Ada9X"); - - Space_Array : array (1..4) of ASUnb.Unbounded_String := - (ASUnb.To_Unbounded_String(" Pad "), - ASUnb.To_Unbounded_String("Pad "), - ASUnb.To_Unbounded_String(" Pad"), - Pad); - - String_Array : array (1..5) of ASUnb.Unbounded_String := - (ASUnb.To_Unbounded_String("xyzxAda9Xpqr"), - ASUnb.To_Unbounded_String("Ada9Xqqrp"), - ASUnb.To_Unbounded_String("zxyxAda9Xqpqr"), - ASUnb.To_Unbounded_String("xxxyAda9X"), - The_New_Ada); - - begin - - -- Examine the version of Trim that removes blanks from - -- the left and/or right of a string. - - for i in 1..4 loop - if ASUnb.Trim(Space_Array(i), Ada.Strings.Both) /= Pad then - Report.Failed("Incorrect result from Trim for spaces - " & - Integer'Image(i)); - end if; - end loop; - - -- Examine the version of Trim that removes set characters from - -- the left and right of a string. - - for i in 1..5 loop - if ASUnb.Trim(String_Array(i), - Left => XYZ_Set, - Right => PQR_Set) /= The_New_Ada then - Report.Failed - ("Incorrect result from Trim for set characters - " & - Integer'Image(i)); - end if; - end loop; - - end Trim_Block; - - - -- Delete - - -- Use the Delete function to remove the first four and last four - -- characters from the string. - - if ASUnb.Delete(Source => ASUnb.Delete(Magic_String, - 8, - ASUnb.Length(Magic_String)), - From => ASUnb.To_String(Magic_String)'First, - Through => 4) /= - Cad_String - then - Report.Failed("Incorrect results from Function Delete"); - end if; - - - -- Constructors ("*") - - Constructor_Block: - declare - - SOS : ASUnb.Unbounded_String; - - Dot : constant ASUnb.Unbounded_String := - ASUnb.To_Unbounded_String("Dot_"); - Dash : constant String := "Dash_"; - - Distress : ASUnb.Unbounded_String := - ASUnb.To_Unbounded_String("Dot_Dot_Dot_") & - ASUnb.To_Unbounded_String("Dash_Dash_Dash_") & - ASUnb.To_Unbounded_String("Dot_Dot_Dot"); - - Repeat : constant Natural := 3; - Separator : constant Character := '_'; - - Separator_Set : Maps.Character_Set := Maps.To_Set(Separator); - - begin - - -- Use the following constructor forms to construct the string - -- "Dot_Dot_Dot_Dash_Dash_Dash_Dot_Dot_Dot". Note that the - -- trailing underscore in the string is removed in the call to - -- Trim in the If statement condition. - - SOS := ASUnb."*"(Repeat, Dot); -- "*"(#, Unb Str) - - SOS := SOS & - ASUnb."*"(Repeat, Dash) & -- "*"(#, Str) - ASUnb."*"(Repeat, Dot); -- "*"(#, Unb Str) - - if ASUnb.Trim(SOS, Maps.Null_Set, Separator_Set) /= Distress then - Report.Failed("Incorrect results from Function ""*"""); - end if; - - end Constructor_Block; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4011; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a deleted file mode 100644 index 5ab12b6dfa9..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a +++ /dev/null @@ -1,305 +0,0 @@ --- CXA4012.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 types, operations, and other entities defined within --- the package Ada.Strings.Wide_Maps are available and produce correct --- results. --- --- TEST DESCRIPTION: --- This test demonstrates the availability and function of the types and --- operations defined in package Ada.Strings.Wide_Maps. It demonstrates --- the use of these types and functions as they would be used in common --- programming practice. --- Wide_Character set creation, assignment, and comparison are evaluated --- in this test. Each of the functions provided in package --- Ada.Strings.Wide_Maps is utilized in creating or manipulating set --- objects, and the function results are evaluated for correctness. --- Wide_Character sequences are examined using the functions provided for --- manipulating objects of this type. Likewise, Wide_Character maps are --- created, and their contents evaluated. Exception raising conditions --- from the function To_Mapping are also created. --- Note: Throughout this test, the set logical operators are printed in --- capital letters to enhance their visibility. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 01 Nov 95 SAIC Update and repair for ACVC 2.0.1. --- ---! - -with Ada.Characters.Handling; -with Ada.Strings.Wide_Maps; - -package CXA40120 is - - function Equiv (Ch : Character) return Wide_Character; - function Equiv (Str : String) - return Ada.Strings.Wide_Maps.Wide_Character_Sequence; - function X_Map(From : Wide_Character) return Wide_Character; - -end CXA40120; - -package body CXA40120 is - - -- The following two functions are used to translate character and string - -- values to "Wide" values. They will be applied to certain Wide_Map - -- subprogram parameters to simulate the use of Wide_Characters and - -- Wide_Character_Sequences in actual practice. - -- Note: These functions do not actually return "equivalent" wide - -- characters to their character inputs, just "non-character" - -- wide characters. - - function Equiv (Ch : Character) return Wide_Character is - C : Character := Ch; - begin - if Ch = ' ' then - return Ada.Characters.Handling.To_Wide_Character(C); - else - return Wide_Character'Val(Character'Pos(Ch) + - Character'Pos(Character'Last) + 1); - end if; - end Equiv; - - function Equiv (Str : String) - return Ada.Strings.Wide_Maps.Wide_Character_Sequence is - use Ada.Strings; - WS : Wide_Maps.Wide_Character_Sequence(Str'First..Str'Last); - begin - for i in Str'First..Str'Last loop - WS(i) := Equiv(Str(i)); - end loop; - return WS; - end Equiv; - - function X_Map(From : Wide_Character) return Wide_Character is - begin - return Equiv('X'); - end X_Map; - -end CXA40120; - - - -with CXA40120; -with Ada.Characters.Handling; -with Ada.Strings.Wide_Maps; -with Report; - -procedure CXA4012 is - - use CXA40120; - use Ada.Strings; - -begin - - Report.Test ("CXA4012", "Check that the types, operations, and other " & - "entities defined within the package " & - "Ada.Strings.Wide_Maps are available and " & - "produce correct results"); - - Test_Block: - declare - - use type Wide_Maps.Wide_Character_Set; - - MidPoint_Letter : constant := 13; - Last_Letter : constant := 26; - - Vowels : constant Wide_Maps.Wide_Character_Sequence := - Equiv("aeiou"); - Quasi_Vowel : constant Wide_Character := Equiv('y'); - - Alphabet : Wide_Maps.Wide_Character_Sequence(1..Last_Letter); - Half_Alphabet : Wide_Maps.Wide_Character_Sequence(1..MidPoint_Letter); - Inverse_Alphabet : Wide_Maps.Wide_Character_Sequence(1..Last_Letter); - - Alphabet_Set, - Consonant_Set, - Vowel_Set, - Full_Vowel_Set, - First_Half_Set, - Second_Half_Set : Wide_Maps.Wide_Character_Set := Wide_Maps.Null_Set; - - begin - - -- Load the alphabet string for use in creating sets. - - for i in 0..MidPoint_Letter-1 loop - Half_Alphabet(i+1) := - Wide_Character'Val(Wide_Character'Pos(Equiv('a')) + i); - end loop; - - for i in 0..Last_Letter-1 loop - Alphabet(i+1) := - Wide_Character'Val(Wide_Character'Pos(Equiv('a')) + i); - end loop; - - - -- Initialize a series of Wide_Character_Set objects. - - Alphabet_Set := Wide_Maps.To_Set(Alphabet); - Vowel_Set := Wide_Maps.To_Set(Vowels); - Full_Vowel_Set := Vowel_Set OR Wide_Maps.To_Set(Quasi_Vowel); - Consonant_Set := Vowel_Set XOR Alphabet_Set; - - First_Half_Set := Wide_Maps.To_Set(Half_Alphabet); - Second_Half_Set := Alphabet_Set XOR First_Half_Set; - - - -- Evaluation of Set objects, operators, and functions. - - if Alphabet_Set /= (Vowel_Set OR Consonant_Set) then - Report.Failed("Incorrect set combinations using OR operator"); - end if; - - - for i in Vowels'First .. Vowels'Last loop - if not Wide_Maps.Is_In(Vowels(i), Vowel_Set) or - not Wide_Maps.Is_In(Vowels(i), Alphabet_Set) or - Wide_Maps.Is_In(Vowels(i), Consonant_Set) - then - Report.Failed("Incorrect function Is_In use with set " & - "combinations - " & Integer'Image(i)); - end if; - end loop; - - - if Wide_Maps.Is_Subset(Vowel_Set, First_Half_Set) or - Wide_Maps."<="(Vowel_Set, Second_Half_Set) or - not Wide_Maps.Is_Subset(Vowel_Set, Alphabet_Set) - then - Report.Failed - ("Incorrect set evaluation using Is_Subset function"); - end if; - - - if not (Full_Vowel_Set = Wide_Maps.To_Set(Equiv("aeiouy"))) then - Report.Failed("Incorrect result for ""="" set operator"); - end if; - - - if not ((Vowel_Set AND First_Half_Set) OR - (Full_Vowel_Set AND Second_Half_Set)) = Full_Vowel_Set then - Report.Failed - ("Incorrect result for AND, OR, or ""="" set operators"); - end if; - - - if (Alphabet_Set AND Wide_Maps.Null_Set) /= Wide_Maps.Null_Set or - (Alphabet_Set OR Wide_Maps.Null_Set) /= Alphabet_Set - then - Report.Failed("Incorrect result for AND or OR set operators"); - end if; - - - Vowel_Set := Full_Vowel_Set; - Vowel_Set := Vowel_Set AND (NOT Wide_Maps.To_Set(Quasi_Vowel)); - - if not (Vowels = Wide_Maps.To_Sequence(Vowel_Set)) then - Report.Failed("Incorrect Set to Sequence translation"); - end if; - - - for i in 0..Last_Letter-1 loop - Inverse_Alphabet(i+1) := Alphabet(Last_Letter-i); - end loop; - - - -- Wide_Character_Mapping - - declare - Inverse_Map : Wide_Maps.Wide_Character_Mapping := - Wide_Maps.To_Mapping(Alphabet, Inverse_Alphabet); - begin - if Wide_Maps.Value(Wide_Maps.Identity, Equiv('b')) /= - Wide_Maps.Value(Inverse_Map, Equiv('y')) - then - Report.Failed("Incorrect Inverse mapping"); - end if; - end; - - - -- Check that Translation_Error is raised when a character is - -- repeated in the parameter "From" string. - declare - Bad_Map : Wide_Maps.Wide_Character_Mapping; - begin - Bad_Map := Wide_Maps.To_Mapping(From => Equiv("aa"), - To => Equiv("yz")); - Report.Failed("Exception not raised with repeated character"); - exception - when Translation_Error => null; -- OK - when others => - Report.Failed("Incorrect exception raised in To_Mapping with " & - "a repeated character"); - end; - - - -- Check that Translation_Error is raised when the parameters of the - -- function To_Mapping are of unequal lengths. - declare - Bad_Map : Wide_Maps.Wide_Character_Mapping; - begin - Bad_Map := Wide_Maps.To_Mapping(Equiv("abc"), Equiv("yz")); - Report.Failed - ("Exception not raised with unequal parameter lengths"); - exception - when Translation_Error => null; -- OK - when others => - Report.Failed("Incorrect exception raised in To_Mapping with " & - "unequal parameter lengths"); - end; - - - -- Check that the access-to-subprogram type is defined and available. - -- This provides for one Wide_Character mapping capability only. - -- The actual mapping functionality will be tested in conjunction with - -- the tests of subprograms defined for Wide_String handling. - - declare - - X_Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function := - X_Map'Access; - - begin - if X_Map_Ptr(Equiv('A')) /= -- both return 'X' - X_Map_Ptr.all(Equiv('Q')) - then - Report.Failed - ("Incorrect result using access-to-subprogram values"); - end if; - end; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4012; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a deleted file mode 100644 index 0f93e9dc8d1..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a +++ /dev/null @@ -1,203 +0,0 @@ --- CXA4013.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 subprograms defined in package Ada.Strings.Wide_Fixed --- are available, and that they produce correct results. Specifically, --- check the subprograms Index, "*" (Wide_String constructor function), --- Count, Trim, and Replace_Slice. --- --- TEST DESCRIPTION: --- This test demonstrates how certain Wide_Fixed string functions --- are used to eliminate specific substrings from portions of text. --- A procedure is defined that will take as parameters a source --- Wide_String along with a substring that is to be completely removed --- from the source string. The source Wide_String is parsed using the --- Index function, and any substring slices are replaced in the source --- Wide_String by a series of X's (based on the length of the substring.) --- Three lines of text are provided to this procedure, and the resulting --- substitutions are compared with expected results to validate the --- string processing. --- A global accumulator is updated with the number of occurrences of the --- substring in the source string. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with Ada.Strings; -with Ada.Strings.Wide_Fixed; -with Ada.Strings.Wide_Maps; -with Report; - -procedure CXA4013 is - -begin - - Report.Test ("CXA4013", "Check that the subprograms defined in package " & - "Ada.Strings.Wide_Fixed are available, and that " & - "they produce correct results"); - - Test_Block: - declare - - TC_Total : Natural := 0; - Number_Of_Lines : constant := 3; - WC : Wide_Character := - Wide_Character'Val(Character'Pos('X') + - Character'Pos(Character'Last) + - 1 ); - - subtype WS is Wide_String (1..25); - - type Restricted_Words_Array_Type is - array (1..10) of Wide_String (1..10); - - Restricted_Words : Restricted_Words_Array_Type := - (" platoon", " marines ", " Marines ", - "north ", "south ", " east", - " beach ", " airport", "airfield ", - " road "); - - type Page_Of_Text_Type is array (1..Number_Of_Lines) of WS; - - Text_Page : Page_Of_Text_Type := ("The platoon of Marines ", - "moved south on the south ", - "road to the airfield. "); - - TC_Revised_Line_1 : constant Wide_String := "The XXXXXXX of XXXXXXX "; - TC_Revised_Line_2 : constant Wide_String := "moved XXXXX on the XXXXX "; - TC_Revised_Line_3 : constant Wide_String := "XXXX to the XXXXXXXX. "; - - - function Equivalent (Left : WS; Right : Wide_String) - return Boolean is - begin - for i in WS'range loop - if Left(i) /= Right(i) then - if Left(i) /= WC or Right(i) /= 'X' then - return False; - end if; - end if; - end loop; - return True; - end Equivalent; - - --- - - procedure Censor (Source_String : in out Wide_String; - Pattern_String : in Wide_String) is - - use Ada.Strings.Wide_Fixed; -- allows infix notation of "*" below. - - -- Create a replacement string that is the same length as the - -- pattern string being removed. Use the infix notation of the - -- wide string constructor function. - - Replacement : constant Wide_String := - Pattern_String'Length * WC; -- "*" - - Going : Ada.Strings.Direction := Ada.Strings.Forward; - Start_Pos, - Index : Natural := Source_String'First; - - begin -- Censor - - -- Accumulate count of total replacement operations. - - TC_Total := TC_Total + - Ada.Strings.Wide_Fixed.Count -- Count - (Source => Source_String, - Pattern => Pattern_String, - Mapping => Ada.Strings.Wide_Maps.Identity); - loop - - Index := Ada.Strings.Wide_Fixed.Index -- Index - (Source_String(Start_Pos..Source_String'Last), - Pattern_String, - Going, - Ada.Strings.Wide_Maps.Identity); - - exit when Index = 0; -- No matches, exit loop. - - -- if a match was found, modify the substring. - Ada.Strings.Wide_Fixed.Replace_Slice -- Replace_Slice - (Source_String, - Index, - Index + Pattern_String'Length - 1, - Replacement); - Start_Pos := Index + Pattern_String'Length; - - end loop; - - end Censor; - - - begin - - -- Invoke Censor subprogram to cleanse text. - -- Loop through each line of text, and check for the presence of each - -- restricted word. - -- Use the Trim function to eliminate leading or trailing blanks from - -- the restricted word parameters. - - for Line in 1..Number_Of_Lines loop - for Word in Restricted_Words'Range loop - Censor (Text_Page(Line), -- Trim - Ada.Strings.Wide_Fixed.Trim(Restricted_Words(Word), - Ada.Strings.Both)); - end loop; - end loop; - - - -- Validate results. - - if TC_Total /= 6 then - Report.Failed ("Incorrect number of substitutions performed"); - end if; - - if not Equivalent (Text_Page(1), TC_Revised_Line_1) then - Report.Failed ("Incorrect substitutions on Line 1"); - end if; - - if not Equivalent (Text_Page(2), TC_Revised_Line_2) then - Report.Failed ("Incorrect substitutions on Line 2"); - end if; - - if not Equivalent (Text_Page(3), TC_Revised_Line_3) then - Report.Failed ("Incorrect substitutions on Line 3"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4013; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a deleted file mode 100644 index 6e26a0330d5..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a +++ /dev/null @@ -1,359 +0,0 @@ --- CXA4014.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 subprograms defined in package Ada.Strings.Wide_Fixed --- are available, and that they produce correct results. Specifically, --- check the subprograms Find_Token, Head, Index, Index_Non_Blank, Move, --- Overwrite, and Replace_Slice, Tail, and Translate. --- Use the access-to-subprogram mapping version of Translate (function --- and procedure). --- --- TEST DESCRIPTION: --- This test demonstrates how certain wide fixed string operations could --- be used in wide string information processing. A procedure is defined --- that will extract portions of a 50 character string that correspond to --- certain data items (i.e., name, address, state, zip code). These --- parsed items will then be added to the appropriate fields of data --- base elements. These data base elements are then compared for --- accuracy against a similar set of predefined data base --- elements. --- A variety of wide fixed string processing subprograms are used in this --- test. Each parsing operation attempts to use a different combination --- of the available subprograms to accomplish the same goal, therefore --- continuity of approach to wide string parsing is not seen in this --- test. --- However, a wide variety of possible approaches are demonstrated, while --- exercising a large number of the total predefined subprograms of --- package Ada.Strings.Wide_Fixed. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 02 Nov 95 SAIC Update and repair for ACVC 2.0.1. --- ---! - -package CXA40140 is - - UnderScore : Wide_Character := '_'; - Blank : Wide_Character := ' '; - - -- Function providing a mapping to a blank Wide_Character. - function US_to_Blank_Map (From : Wide_Character) return Wide_Character; - -end CXA40140; - -package body CXA40140 is - - function US_to_Blank_Map (From : Wide_Character) return Wide_Character is - begin - if From = UnderScore then - return Blank; - else - return From; - end if; - end US_to_Blank_Map; - -end CXA40140; - - -with CXA40140; -with Ada.Strings.Wide_Fixed; -with Ada.Strings.Wide_Maps; -with Report; - -procedure CXA4014 is - use CXA40140; -begin - - Report.Test ("CXA4014", "Check that the subprograms defined in package " & - "Ada.Strings.Wide_Fixed are available, and that " & - "they produce correct results"); - - Test_Block: - declare - - Number_Of_Info_Strings : constant Natural := 3; - DB_Size : constant Natural := Number_Of_Info_Strings; - Count : Natural := 0; - Finished_Processing : Boolean := False; - Blank_Wide_String : constant Wide_String := " "; - - subtype Info_Wide_String_Type is Wide_String (1..50); - type Info_Wide_String_Storage_Type is - array (1..Number_Of_Info_Strings) of Info_Wide_String_Type; - - - subtype Name_Type is Wide_String (1..10); - subtype Street_Number_Type is Wide_String (1..5); - subtype Street_Name_Type is Wide_String (1..10); - subtype City_Type is Wide_String (1..10); - subtype State_Type is Wide_String (1..2); - subtype Zip_Code_Type is Wide_String (1..5); - - type Data_Base_Element_Type is - record - Name : Name_Type := (others => ' '); - Street_Number : Street_Number_Type := (others => ' '); - Street_Name : Street_Name_Type := (others => ' '); - City : City_Type := (others => ' '); - State : State_Type := (others => ' '); - Zip_Code : Zip_Code_Type := (others => ' '); - end record; - - type Data_Base_Type is array (1..DB_Size) of Data_Base_Element_Type; - - Data_Base : Data_Base_Type; - - --- - - Info_String_1 : Info_Wide_String_Type := - "Joe_Jones 123 Sixth_St San_Diego CA 98765"; - - Info_String_2 : Info_Wide_String_Type := - "Sam_Smith 56789 S._Seventh Carlsbad CA 92177"; - - Info_String_3 : Info_Wide_String_Type := - "Jane_Brown 1219 Info_Lane Tuscon AZ 85643"; - - - Info_Strings : Info_Wide_String_Storage_Type := - (1 => Info_String_1, - 2 => Info_String_2, - 3 => Info_String_3); - - - - TC_DB_Element_1 : Data_Base_Element_Type := - ("Joe Jones ", "123 ", "Sixth St ", "San Diego ", "CA", "98765"); - - TC_DB_Element_2 : Data_Base_Element_Type := - ("Sam Smith ", "56789", "S. Seventh", "Carlsbad ", "CA", "92177"); - - TC_DB_Element_3 : Data_Base_Element_Type := - ("Jane Brown", "1219 ", "Info Lane ", "Tuscon ", "AZ", "85643"); - - TC_Data_Base : Data_Base_Type := (TC_DB_Element_1, - TC_DB_Element_2, - TC_DB_Element_3); - - --- - - - procedure Store_Information - (Info_String : in Info_Wide_String_Type; - DB_Record : in out Data_Base_Element_Type) is - - package AS renames Ada.Strings; - use type AS.Wide_Maps.Wide_Character_Set; - - Start, - Stop : Natural := 0; - - Numeric_Set : constant AS.Wide_Maps.Wide_Character_Set := - AS.Wide_Maps.To_Set("0123456789"); - - Cal : constant - AS.Wide_Maps.Wide_Character_Sequence := "CA"; - California_Set : constant AS.Wide_Maps.Wide_Character_Set := - AS.Wide_Maps.To_Set(Cal); - Arizona_Set : constant AS.Wide_Maps.Wide_Character_Set := - AS.Wide_Maps.To_Set("AZ"); - Nevada_Set : constant AS.Wide_Maps.Wide_Character_Set := - AS.Wide_Maps.To_Set("NV"); - - Blank_Ftn_Ptr : AS.Wide_Maps.Wide_Character_Mapping_Function := - US_to_Blank_Map'Access; - - begin - - -- Find the starting position of the name field (first non-blank), - -- then, from that position, find the end of the name field (first - -- blank). - - Start := AS.Wide_Fixed.Index_Non_Blank(Info_String); - Stop := AS.Wide_Fixed.Index (Info_String(Start..Info_String'Length), - AS.Wide_Maps.To_Set(Blank), - AS.Inside, - AS.Forward) - 1 ; - - -- Store the name field in the data base element field for "Name". - - DB_Record.Name := AS.Wide_Fixed.Head(Info_String(1..Stop), - DB_Record.Name'Length); - - -- Replace any underscore characters in the name field - -- that were used to separate first/middle/last names. - -- Use the overloaded version of Translate that takes an - -- access-to-subprogram value. - - AS.Wide_Fixed.Translate (DB_Record.Name, Blank_Ftn_Ptr); - - - -- Continue the extraction process; now find the position of - -- the street number in the string. - - Start := Stop + 1; - - AS.Wide_Fixed.Find_Token(Info_String(Start..Info_String'Length), - Numeric_Set, - AS.Inside, - Start, - Stop); - - -- Store the street number field in the appropriate data base - -- element. - -- No modification of the default parameters of procedure Move - -- is required. - - AS.Wide_Fixed.Move(Source => Info_String(Start..Stop), - Target => DB_Record.Street_Number); - - - -- Continue the extraction process; find the street name in the - -- info string. Skip blanks to the start of the street name, then - -- search for the index of the next blank character in the string. - - Start := AS.Wide_Fixed.Index_Non_Blank - (Info_String(Stop+1..Info_String'Length)); - - Stop := - AS.Wide_Fixed.Index(Info_String(Start..Info_String'Length), - Blank_Wide_String) - 1; - - -- Store the street name in the appropriate data base element field. - - AS.Wide_Fixed.Overwrite(DB_Record.Street_Name, - 1, - Info_String(Start..Stop)); - - -- Replace any underscore characters in the street name field - -- that were used as word separation with blanks. Again, use the - -- access-to-subprogram value to provide the mapping. - - DB_Record.Street_Name := - AS.Wide_Fixed.Translate(DB_Record.Street_Name, - Blank_Ftn_Ptr); - - - -- Continue the extraction; remove the city name from the string. - - Start := AS.Wide_Fixed.Index_Non_Blank - (Info_String(Stop+1..Info_String'Length)); - - Stop := - AS.Wide_Fixed.Index(Info_String(Start..Info_String'Length), - Blank_Wide_String) - 1; - - -- Store the city name field in the appropriate data base element. - - AS.Wide_Fixed.Replace_Slice(DB_Record.City, - 1, - DB_Record.City'Length, - Info_String(Start..Stop)); - - -- Replace any underscore characters in the city name field - -- that were used as word separation. - - AS.Wide_Fixed.Translate (DB_Record.City, - Blank_Ftn_Ptr); - - - -- Continue the extraction; remove the state identifier from the - -- info string. - - Start := Stop + 1; - - AS.Wide_Fixed.Find_Token(Info_String(Start..Info_String'Length), - AS.Wide_Maps."OR"(California_Set, - AS.Wide_Maps."OR"(Nevada_Set, - Arizona_Set)), - AS.Inside, - Start, - Stop); - - -- Store the state indicator into the data base element. - - AS.Wide_Fixed.Move(Source => Info_String(Start..Stop), - Target => DB_Record.State, - Drop => Ada.Strings.Right, - Justify => Ada.Strings.Left, - Pad => AS.Wide_Space); - - - -- Continue the extraction process; remove the final data item in - -- the info string, the zip code, and place it into the - -- corresponding data base element. - - DB_Record.Zip_Code := - AS.Wide_Fixed.Tail(Info_String, DB_Record.Zip_Code'Length); - - exception - when AS.Length_Error => - Report.Failed ("Length_Error raised in procedure"); - when AS.Pattern_Error => - Report.Failed ("Pattern_Error raised in procedure"); - when AS.Translation_Error => - Report.Failed ("Translation_Error raised in procedure"); - when others => - Report.Failed ("Exception raised in procedure"); - end Store_Information; - - - begin - - -- Loop thru the information strings, extract the name and address - -- information, place this info into elements of the data base. - - while not Finished_Processing loop - - Count := Count + 1; - - Store_Information (Info_Strings(Count), Data_Base(Count)); - - Finished_Processing := (Count = Number_Of_Info_Strings); - - end loop; - - - -- Verify that the string processing was successful. - - for i in 1..DB_Size loop - if Data_Base(i) /= TC_Data_Base(i) then - Report.Failed - ("Data processing error on record " & Integer'Image(i)); - end if; - end loop; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4014; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a deleted file mode 100644 index 83fad3af866..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a +++ /dev/null @@ -1,580 +0,0 @@ --- CXA4015.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 subprograms defined in package Ada.Strings.Wide_Fixed --- are available, and that they produce correct results. Specifically, --- check the subprograms Count, Find_Token, Index, Index_Non_Blank, and --- Move. --- --- TEST DESCRIPTION: --- This test, when combined with tests CXA4013,14,16 will provide --- coverage of the functionality found in Ada.Strings.Wide_Fixed. --- This test contains many small, specific test cases, situations that --- although common in user environments, are often difficult to generate --- in large numbers in a application-based test. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 02 Nov 95 SAIC Corrected various accesssibility problems and --- expected result strings for ACVC 2.0.1. --- ---! - -package CXA40150 is - - -- Wide Character mapping function defined for use with specific - -- versions of functions Index and Count. - - function AK_to_ZQ_Mapping (From : Wide_Character) return Wide_Character; - -end CXA40150; - -package body CXA40150 is - - function AK_to_ZQ_Mapping (From : Wide_Character) - return Wide_Character is - begin - if From = 'a' then - return 'z'; - elsif From = 'k' then - return 'q'; - else - return From; - end if; - end AK_to_ZQ_Mapping; - -end CXA40150; - - -with CXA40150; -with Report; -with Ada.Strings; -with Ada.Strings.Wide_Fixed; -with Ada.Strings.Wide_Maps; - -procedure CXA4015 is -begin - - Report.Test("CXA4015", "Check that the subprograms defined in " & - "package Ada.Strings.Wide_Fixed are available, " & - "and that they produce correct results"); - - - Test_Block: - declare - - use CXA40150; - - package ASF renames Ada.Strings.Wide_Fixed; - package Maps renames Ada.Strings.Wide_Maps; - - Result_String : Wide_String(1..10) := - (others => Ada.Strings.Wide_Space); - - Source_String1 : Wide_String(1..5) := "abcde"; -- odd len Wide_String - Source_String2 : Wide_String(1..6) := "abcdef"; -- even len Wide_String - Source_String3 : Wide_String(1..12) := "abcdefghijkl"; - Source_String4 : Wide_String(1..12) := "abcdefghij "; -- last 2 ch pad - Source_String5 : Wide_String(1..12) := " cdefghijkl"; -- first 2 ch pad - Source_String6 : Wide_String(1..12) := "abcdefabcdef"; - - Location : Natural := 0; - Slice_Start : Positive; - Slice_End, - Slice_Count : Natural := 0; - - CD_Set : Maps.Wide_Character_Set := Maps.To_Set("cd"); - ABCD_Set : Maps.Wide_Character_Set := Maps.To_Set("abcd"); - A_to_F_Set : Maps.Wide_Character_Set := Maps.To_Set("abcdef"); - - CD_to_XY_Map : Maps.Wide_Character_Mapping := - Maps.To_Mapping(From => "cd", To => "xy"); - - - -- Access-to-Subprogram object defined for use with specific versions of - -- functions Index and Count. - - Map_Ptr : Maps.Wide_Character_Mapping_Function := - AK_to_ZQ_Mapping'Access; - - - begin - - - -- Procedure Move - -- Evaluate the Procedure Move with various combinations of - -- parameters. - - -- Justify = Left (default case) - - ASF.Move(Source => Source_String1, -- "abcde" - Target => Result_String); - - if Result_String /= "abcde " then - Report.Failed("Incorrect result from Move with Justify = Left"); - end if; - - -- Justify = Right - - ASF.Move(Source => Source_String2, -- "abcdef" - Target => Result_String, - Drop => Ada.Strings.Error, - Justify => Ada.Strings.Right); - - if Result_String /= " abcdef" then - Report.Failed("Incorrect result from Move with Justify = Right"); - end if; - - -- Justify = Center (two cases, odd and even pad lengths) - - ASF.Move(Source_String1, -- "abcde" - Result_String, - Ada.Strings.Error, - Ada.Strings.Center, - 'x'); -- non-default padding. - - if Result_String /= "xxabcdexxx" then -- Unequal padding added right - Report.Failed("Incorrect result from Move with Justify = Center-1"); - end if; - - ASF.Move(Source_String2, -- "abcdef" - Result_String, - Ada.Strings.Error, - Ada.Strings.Center); - - if Result_String /= " abcdef " then -- Equal padding added on L/R. - Report.Failed("Incorrect result from Move with Justify = Center-2"); - end if; - - -- When the source Wide_String is longer than the target Wide_String, - -- several cases can be examined, with the results depending on the - -- value of the Drop parameter. - - -- Drop = Left - - ASF.Move(Source => Source_String3, -- "abcdefghijkl" - Target => Result_String, - Drop => Ada.Strings.Left); - - if Result_String /= "cdefghijkl" then - Report.Failed("Incorrect result from Move with Drop = Left"); - end if; - - -- Drop = Right - - ASF.Move(Source_String3, Result_String, Ada.Strings.Right); - - if Result_String /= "abcdefghij" then - Report.Failed("Incorrect result from Move with Drop = Right"); - end if; - - -- Drop = Error - -- The effect in this case depends on the value of the justify - -- parameter, and on whether any characters in Source other than - -- Pad would fail to be copied. - - -- Drop = Error, Justify = Left, right overflow characters are pad. - - ASF.Move(Source => Source_String4, -- "abcdefghij " - Target => Result_String, - Drop => Ada.Strings.Error, - Justify => Ada.Strings.Left); - - if not(Result_String = "abcdefghij") then -- leftmost 10 characters - Report.Failed("Incorrect result from Move with Drop = Error - 1"); - end if; - - -- Drop = Error, Justify = Right, left overflow characters are pad. - - ASF.Move(Source_String5, -- " cdefghijkl" - Result_String, - Ada.Strings.Error, - Ada.Strings.Right); - - if Result_String /= "cdefghijkl" then -- rightmost 10 characters - Report.Failed("Incorrect result from Move with Drop = Error - 2"); - end if; - - -- In other cases of Drop=Error, Length_Error is propagated, such as: - - begin - - ASF.Move(Source_String3, -- 12 characters, no Pad. - Result_String, -- 10 characters - Ada.Strings.Error, - Ada.Strings.Left); - - Report.Failed("Length_Error not raised by Move - 1"); - - exception - when Ada.Strings.Length_Error => null; -- OK - when others => - Report.Failed("Incorrect exception raised by Move - 1"); - end; - - - - -- Function Index - -- (Other usage examples of this function found in CXA4013-14.) - -- Check when the pattern is not found in the source. - - if ASF.Index("abcdef", "gh") /= 0 or - ASF.Index("abcde", "abcdef") /= 0 or -- pattern > source - ASF.Index("xyz", - "abcde", - Ada.Strings.Backward) /= 0 or - ASF.Index("", "ab") /= 0 or -- null source Wide_String. - ASF.Index("abcde", " ") /= 0 -- blank pattern. - then - Report.Failed("Incorrect result from Index, no pattern match"); - end if; - - -- Check that Pattern_Error is raised when the pattern is the - -- null Wide_String. - begin - Location := ASF.Index(Source_String6, -- "abcdefabcdef" - "", -- null pattern Wide_String. - Ada.Strings.Forward); - Report.Failed("Pattern_Error not raised by Index"); - exception - when Ada.Strings.Pattern_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by Index, null pattern"); - end; - - -- Use the search direction "backward" to locate the particular - -- pattern within the source Wide_String. - - Location := ASF.Index(Source_String6, -- "abcdefabcdef" - "de", -- slice 4..5, 10..11 - Ada.Strings.Backward); -- search from right end. - - if Location /= 10 then - Report.Failed("Incorrect result from Index going Backward"); - end if; - - - - -- Function Index - -- Use the version of Index that takes a Wide_Character_Mapping_Function - -- parameter. - -- Use the search directions Forward and Backward to locate the - -- particular pattern wide string within the source wide string. - - Location := ASF.Index("akzqefakzqef", - "qzq", -- slice 8..10 - Ada.Strings.Backward, - Map_Ptr); -- perform 'a' to 'z', 'k' to 'q' - -- translation. - if Location /= 8 then - Report.Failed - ("Incorrect result from Index w/map ptr going Backward"); - end if; - - Location := ASF.Index("ddkkddakcdakdefcadckdfzaaqd", - "zq", -- slice 7..8 - Ada.Strings.Forward, - Map_Ptr); -- perform 'a' to 'z', 'k' to 'q' - -- translation. - if Location /= 7 then - Report.Failed - ("Incorrect result from Index w/map ptr going Forward"); - end if; - - - if ASF.Index("aakkzq", "zq", Ada.Strings.Forward, Map_Ptr) /= 2 or - ASF.Index("qzedka", "qz", Ada.Strings.Backward, Map_Ptr) /= 5 or - ASF.Index("zazaza", "zzzz", Ada.Strings.Backward, Map_Ptr) /= 3 or - ASF.Index("kka", "qqz", Ada.Strings.Forward, Map_Ptr) /= 1 - then - Report.Failed("Incorrect result from Index w/map ptr"); - end if; - - - -- Check when the pattern wide string is not found in the source. - - if ASF.Index("akzqef", "kzq", Ada.Strings.Forward, Map_Ptr) /= 0 or - ASF.Index("abcde", "abcdef", Ada.Strings.Backward, Map_Ptr) /= 0 or - ASF.Index("xyz", "akzde", Ada.Strings.Backward, Map_Ptr) /= 0 or - ASF.Index("", "zq", Ada.Strings.Forward, Map_Ptr) /= 0 or - ASF.Index("akcde", " ", Ada.Strings.Backward, Map_Ptr) /= 0 - then - Report.Failed - ("Incorrect result from Index w/map ptr, no pattern match"); - end if; - - -- Check that Pattern_Error is raised when the pattern is a - -- null Wide_String. - begin - Location := ASF.Index("akzqefakqzef", - "", -- null pattern Wide_String. - Ada.Strings.Forward, - Map_Ptr); - Report.Failed("Pattern_Error not raised by Index w/map ptr"); - exception - when Ada.Strings.Pattern_Error => null; -- OK, expected exception. - when others => - Report.Failed - ("Incorrect exception raised by Index w/map ptr, null pattern"); - end; - - - - -- Function Index - -- Using the version of Index testing wide character set membership, - -- check combinations of forward/backward, inside/outside parameter - -- configurations. - - if ASF.Index(Source => Source_String1, -- "abcde" - Set => CD_Set, - Test => Ada.Strings.Inside, - Going => Ada.Strings.Forward) /= 3 or -- 'c' at pos 3. - ASF.Index(Source_String6, -- "abcdefabcdef" - CD_Set, - Ada.Strings.Outside, - Ada.Strings.Backward) /= 12 or -- 'f' at position 12 - ASF.Index(Source_String6, -- "abcdefabcdef" - CD_Set, - Ada.Strings.Inside, - Ada.Strings.Backward) /= 10 or -- 'd' at position 10 - ASF.Index("cdcdcdcdacdcdcdcd", - CD_Set, - Ada.Strings.Outside, - Ada.Strings.Forward) /= 9 -- 'a' at position 9 - then - Report.Failed("Incorrect result from function Index for sets - 1"); - end if; - - -- Additional interesting uses/combinations using Index for sets. - - if ASF.Index("cd", -- same size, str-set - CD_Set, - Ada.Strings.Inside, - Ada.Strings.Forward) /= 1 or -- 'c' at position 1 - ASF.Index("abcd", -- same size, str-set, - Maps.To_Set("efgh"), -- different contents. - Ada.Strings.Outside, - Ada.Strings.Forward) /= 1 or - ASF.Index("abccd", -- set > Wide_String - Maps.To_Set("acegik"), - Ada.Strings.Inside, - Ada.Strings.Backward) /= 4 or -- 'c' at position 4 - ASF.Index("abcde", - Maps.Null_Set) /= 0 or - ASF.Index("", -- Null string. - CD_Set) /= 0 or - ASF.Index("abc ab", -- blank included - Maps.To_Set("e "), -- in Wide_String and - Ada.Strings.Inside, -- set. - Ada.Strings.Backward) /= 4 -- blank in Wide_Str. - then - Report.Failed("Incorrect result from function Index for sets - 2"); - end if; - - - - -- Function Index_Non_Blank. - -- (Other usage examples of this function found in CXA4013-14.) - - - if ASF.Index_Non_Blank(Source => Source_String4, -- "abcdefghij " - Going => Ada.Strings.Backward) /= 10 or - ASF.Index_Non_Blank("abc def ghi jkl ", - Ada.Strings.Backward) /= 15 or - ASF.Index_Non_Blank(" abcdef") /= 3 or - ASF.Index_Non_Blank(" ") /= 0 - then - Report.Failed("Incorrect result from Index_Non_Blank"); - end if; - - - - -- Function Count - -- (Other usage examples of this function found in CXA4013-14.) - - if ASF.Count("abababa", "aba") /= 2 or - ASF.Count("abababa", "ab" ) /= 3 or - ASF.Count("babababa", "ab") /= 3 or - ASF.Count("abaabaaba", "aba") /= 3 or - ASF.Count("xxxxxxxxxxxxxxxxxxxy", "xy") /= 1 or - ASF.Count("xxxxxxxxxxxxxxxxxxxx", "x") /= 20 - then - Report.Failed("Incorrect result from Function Count"); - end if; - - -- Determine the number of slices of Source that when mapped to a - -- non-identity map, match the pattern Wide_String. - - Slice_Count := ASF.Count(Source_String6, -- "abcdefabcdef" - "xy", - CD_to_XY_Map); -- maps 'c' to 'x', 'd' to 'y' - - if Slice_Count /= 2 then -- two slices "xy" in "mapped" Source_String6 - Report.Failed("Incorrect result from Count with non-identity map"); - end if; - - -- If the pattern supplied to Function Count is the null Wide_String, - -- then Pattern_Error is propagated. - declare - The_Null_Wide_String : constant Wide_String := ""; - begin - Slice_Count := ASF.Count(Source_String6, The_Null_Wide_String); - Report.Failed("Pattern_Error not raised by Function Count"); - exception - when Ada.Strings.Pattern_Error => null; -- OK - when others => - Report.Failed("Incorrect exception from Count with null pattern"); - end; - - - - - -- Function Count - -- Use the version of Count that takes a Wide_Character_Mapping_Function - -- value as the basis of its source mapping. - - if ASF.Count("akakaka", "zqz", Map_Ptr) /= 2 or - ASF.Count("akakaka", "qz", Map_Ptr) /= 3 or - ASF.Count("kakakaka", "q", Map_Ptr) /= 4 or - ASF.Count("zzqaakzaqzzk", "zzq", Map_Ptr) /= 4 or - ASF.Count(" ", "z", Map_Ptr) /= 0 or - ASF.Count("", "qz", Map_Ptr) /= 0 or - ASF.Count("abbababab", "zq", Map_Ptr) /= 0 or - ASF.Count("aaaaaaaaaaaaaaaaaakk", "zqq", Map_Ptr) /= 1 or - ASF.Count("azaazaazzzaaaaazzzza", "z", Map_Ptr) /= 20 - then - Report.Failed("Incorrect result from Function Count w/map ptr"); - end if; - - -- If the pattern supplied to Function Count is a null Wide_String, - -- then Pattern_Error is propagated. - declare - The_Null_Wide_String : constant Wide_String := ""; - begin - Slice_Count := ASF.Count(Source_String6, - The_Null_Wide_String, - Map_Ptr); - Report.Failed - ("Pattern_Error not raised by Function Count w/map ptr"); - exception - when Ada.Strings.Pattern_Error => null; -- OK - when others => - Report.Failed - ("Incorrect exception from Count w/map ptr, null pattern"); - end; - - - - - -- Function Count returning the number of characters in a particular - -- set that are found in source Wide_String. - - if ASF.Count(Source_String6, CD_Set) /= 4 or -- 2 'c' and 'd' chars. - ASF.Count("cddaccdaccdd", CD_Set) /= 10 - then - Report.Failed("Incorrect result from Count with set"); - end if; - - - - -- Function Find_Token. - -- (Other usage examples of this function found in CXA4013-14.) - - ASF.Find_Token(Source => Source_String6, -- First slice with no - Set => ABCD_Set, -- 'a', 'b', 'c', or 'd' - Test => Ada.Strings.Outside, -- is "ef" at 5..6. - First => Slice_Start, - Last => Slice_End); - - if Slice_Start /= 5 or Slice_End /= 6 then - Report.Failed("Incorrect result from Find_Token - 1"); - end if; - - -- If no appropriate slice is contained by the source Wide_String, - -- then the value returned in Last is zero, and the value in First is - -- Source'First. - - ASF.Find_Token(Source_String6, -- "abcdefabcdef" - A_to_F_Set, -- Set of characters 'a' thru 'f'. - Ada.Strings.Outside, -- No characters outside this set. - Slice_Start, - Slice_End); - - if Slice_Start /= Source_String6'First or Slice_End /= 0 then - Report.Failed("Incorrect result from Find_Token - 2"); - end if; - - -- Additional testing of Find_Token. - - ASF.Find_Token("eabcdabcddcab", - ABCD_Set, - Ada.Strings.Inside, - Slice_Start, - Slice_End); - - if Slice_Start /= 2 or Slice_End /= 13 then - Report.Failed("Incorrect result from Find_Token - 3"); - end if; - - ASF.Find_Token("efghijklabcdabcd", - ABCD_Set, - Ada.Strings.Outside, - Slice_Start, - Slice_End); - - if Slice_Start /= 1 or Slice_End /= 8 then - Report.Failed("Incorrect result from Find_Token - 4"); - end if; - - ASF.Find_Token("abcdefgabcdabcd", - ABCD_Set, - Ada.Strings.Outside, - Slice_Start, - Slice_End); - - if Slice_Start /= 5 or Slice_End /= 7 then - Report.Failed("Incorrect result from Find_Token - 5"); - end if; - - ASF.Find_Token("abcdcbabcdcba", - ABCD_Set, - Ada.Strings.Inside, - Slice_Start, - Slice_End); - - if Slice_Start /= 1 or Slice_End /= 13 then - Report.Failed("Incorrect result from Find_Token - 6"); - end if; - - - exception - when others => Report.Failed("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA4015; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a deleted file mode 100644 index 00dcdcdbd00..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a +++ /dev/null @@ -1,685 +0,0 @@ --- CXA4016.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 subprograms defined in package Ada.Strings.Wide_Fixed --- are available, and that they produce correct results. Specifically, --- check the subprograms Delete, Head, Insert, Overwrite, Replace_Slice, --- Tail, Trim, and "*". --- --- TEST DESCRIPTION: --- This test, when combined with tests CXA4013-15 will provide --- coverage of the functionality found in package Ada.Strings.Wide_Fixed. --- This test contains many small, specific test cases, situations that --- although common in user environments, are often difficult to generate --- in large numbers in a application-based test. They represent --- individual usage paradigms in-the-small. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 10 Apr 94 SAIC Modified comments in a subtest failure message. --- 06 Nov 95 SAIC Corrected subtest results for ACVC 2.0.1 --- 14 Mar 01 RLB Added checks that the lower bound is 1, similar --- to CXA4005. These changes were made to test --- Defect Report 8652/0049, as reflected in --- Technical Corrigendum 1. --- ---! - -with Report; -with Ada.Strings; -with Ada.Strings.Wide_Fixed; -with Ada.Strings.Wide_Maps; - -procedure CXA4016 is - - type TC_Name_Holder is access String; - Name : TC_Name_Holder; - - function TC_Check (S : Wide_String) return Wide_String is - begin - if S'First /= 1 then - Report.Failed ("Lower bound of result of function " & Name.all & - " is" & Integer'Image (S'First)); - end if; - return S; - end TC_Check; - - procedure TC_Set_Name (N : String) is - begin - Name := new String'(N); - end TC_Set_Name; - -begin - - Report.Test("CXA4016", "Check that the subprograms defined in " & - "package Ada.Strings.Wide_Fixed are available, " & - "and that they produce correct results"); - - Test_Block: - declare - - package ASW renames Ada.Strings.Wide_Fixed; - package Wide_Maps renames Ada.Strings.Wide_Maps; - - Result_String, - Delete_String, - Insert_String, - Trim_String, - Overwrite_String : Wide_String(1..10) := - (others => Ada.Strings.Wide_Space); - Replace_String : Wide_String(10..30) := - (others => Ada.Strings.Wide_Space); - - Source_String1 : Wide_String(1..5) := "abcde"; -- odd len wd str - Source_String2 : Wide_String(1..6) := "abcdef"; -- even len wd str - Source_String3 : Wide_String(1..12) := "abcdefghijkl"; - Source_String4 : Wide_String(1..12) := "abcdefghij "; -- last two ch pad - Source_String5 : Wide_String(1..12) := " cdefghijkl"; -- first two ch pad - Source_String6 : Wide_String(1..12) := "abcdefabcdef"; - - Location : Natural := 0; - Slice_Start : Positive; - Slice_End, - Slice_Count : Natural := 0; - - CD_Set : Wide_Maps.Wide_Character_Set := - Wide_Maps.To_Set("cd"); - X_Set : Wide_Maps.Wide_Character_Set := - Wide_Maps.To_Set('x'); - ABCD_Set : Wide_Maps.Wide_Character_Set := - Wide_Maps.To_Set("abcd"); - A_to_F_Set : Wide_Maps.Wide_Character_Set := - Wide_Maps.To_Set("abcdef"); - - CD_to_XY_Map : Wide_Maps.Wide_Character_Mapping := - Wide_Maps.To_Mapping(From => "cd", To => "xy"); - - begin - - -- Procedure Replace_Slice - -- The functionality of this procedure is similar to procedure Move, - -- and is tested here in the same manner, evaluated with various - -- combinations of parameters. - - -- Index_Error propagation when Low > Source'Last + 1 - - begin - ASW.Replace_Slice(Result_String, - Result_String'Last + 2, -- should raise exception - Result_String'Last, - "xxxxxxx"); - Report.Failed("Index_Error not raised by Replace_Slice - 1"); - exception - when Ada.Strings.Index_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception from Replace_Slice - 1"); - end; - - -- Index_Error propagation when High < Source'First - 1 - - begin - ASW.Replace_Slice(Replace_String(20..30), - Replace_String'First, - Replace_String'First - 2, -- should raise exception - "xxxxxxx"); - Report.Failed("Index_Error not raised by Replace_Slice - 2"); - exception - when Ada.Strings.Index_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception from Replace_Slice - 2"); - end; - - -- Justify = Left (default case) - - Result_String := "XXXXXXXXXX"; - - ASW.Replace_Slice(Source => Result_String, - Low => 1, - High => 10, - By => Source_String1); -- "abcde" - - if Result_String /= "abcde " then - Report.Failed("Incorrect result from Replace_Slice - Justify = Left"); - end if; - - -- Justify = Right - - ASW.Replace_Slice(Source => Result_String, - Low => 1, - High => Result_String'Last, - By => Source_String2, -- "abcdef" - Drop => Ada.Strings.Error, - Justify => Ada.Strings.Right); - - if Result_String /= " abcdef" then - Report.Failed("Incorrect result from Replace_Slice - Justify=Right"); - end if; - - -- Justify = Center (two cases, odd and even pad lengths) - - ASW.Replace_Slice(Result_String, - 1, - Result_String'Last, - Source_String1, -- "abcde" - Ada.Strings.Error, - Ada.Strings.Center, - 'x'); -- non-default padding. - - if Result_String /= "xxabcdexxx" then -- Unequal padding added right - Report.Failed("Incorrect result, Replace_Slice - Justify=Center - 1"); - end if; - - ASW.Replace_Slice(Result_String, - 1, - Result_String'Last, - Source_String2, -- "abcdef" - Ada.Strings.Error, - Ada.Strings.Center); - - if Result_String /= " abcdef " then -- Equal padding added on L/R. - Report.Failed("Incorrect result from Replace_Slice with " & - "Justify = Center - 2"); - end if; - - -- When the source string is longer than the target string, several - -- cases can be examined, with the results depending on the value of - -- the Drop parameter. - - -- Drop = Left - - ASW.Replace_Slice(Result_String, - 1, - Result_String'Last, - Source_String3, -- "abcdefghijkl" - Drop => Ada.Strings.Left); - - if Result_String /= "cdefghijkl" then - Report.Failed("Incorrect result from Replace_Slice - Drop=Left"); - end if; - - -- Drop = Right - - ASW.Replace_Slice(Result_String, - 1, - Result_String'Last, - Source_String3, -- "abcdefghijkl" - Ada.Strings.Right); - - if Result_String /= "abcdefghij" then - Report.Failed("Incorrect result, Replace_Slice with Drop=Right"); - end if; - - -- Drop = Error - - -- The effect in this case depends on the value of the justify - -- parameter, and on whether any characters in Source other than - -- Pad would fail to be copied. - - -- Drop = Error, Justify = Left, right overflow characters are pad. - - ASW.Replace_Slice(Result_String, - 1, - Result_String'Last, - Source_String4, -- "abcdefghij " - Drop => Ada.Strings.Error, - Justify => Ada.Strings.Left); - - if not(Result_String = "abcdefghij") then -- leftmost 10 characters - Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 1"); - end if; - - -- Drop = Error, Justify = Right, left overflow characters are pad. - - ASW.Replace_Slice(Source => Result_String, - Low => 1, - High => Result_String'Last, - By => Source_String5, -- " cdefghijkl" - Drop => Ada.Strings.Error, - Justify => Ada.Strings.Right); - - if Result_String /= "cdefghijkl" then -- rightmost 10 characters - Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 2"); - end if; - - -- In other cases of Drop=Error, Length_Error is propagated, such as: - - begin - - ASW.Replace_Slice(Source => Result_String, - Low => 1, - High => Result_String'Last, - By => Source_String3, -- "abcdefghijkl" - Drop => Ada.Strings.Error); - - Report.Failed("Length_Error not raised by Replace_Slice - 1"); - - exception - when Ada.Strings.Length_Error => null; -- OK - when others => - Report.Failed("Incorrect exception from Replace_Slice - 3"); - end; - - - -- Function Replace_Slice - - TC_Set_Name ("Replace_Slice"); - - if TC_Check (ASW.Replace_Slice("abcde", 3, 3, "x")) - /= "abxde" or -- High = Low - TC_Check (ASW.Replace_Slice("abc", 2, 3, "xyz")) /= "axyz" or - TC_Check (ASW.Replace_Slice("abcd", 4, 1, "xy")) - /= "abcxyd" or -- High < Low - TC_Check (ASW.Replace_Slice("abc", 2, 3, "x")) /= "ax" or - TC_Check (ASW.Replace_Slice("a", 1, 1, "z")) /= "z" - then - Report.Failed("Incorrect result from Function Replace_Slice - 1"); - end if; - - if TC_Check (ASW.Replace_Slice("abcde", 5, 5, "z")) - /= "abcdz" or -- By length 1 - TC_Check (ASW.Replace_Slice("abc", 1, 3, "xyz")) - /= "xyz" or -- High > Low - TC_Check (ASW.Replace_Slice("abc", 3, 2, "xy")) - /= "abxyc" or -- insert - TC_Check (ASW.Replace_Slice("a", 1, 1, "xyz")) /= "xyz" - then - Report.Failed("Incorrect result from Function Replace_Slice - 2"); - end if; - - - - -- Function Insert. - - TC_Set_Name ("Insert"); - - declare - New_String : constant Wide_String := - TC_Check ( - ASW.Insert(Source => Source_String1(2..5), -- "bcde" - Before => 2, - New_Item => Source_String2)); -- "abcdef" - begin - if New_String /= "abcdefbcde" then - Report.Failed("Incorrect result from Function Insert - 1"); - end if; - end; - - if TC_Check (ASW.Insert("a", 1, "z")) /= "za" or - TC_Check (ASW.Insert("abc", 3, "")) /= "abc" or - TC_Check (ASW.Insert("abc", 4, "z")) /= "abcz" - then - Report.Failed("Incorrect result from Function Insert - 2"); - end if; - - begin - if TC_Check (ASW.Insert(Source => Source_String1(2..5), -- "bcde" - Before => Report.Ident_Int(7), - New_Item => Source_String2)) -- "abcdef" - /= "babcdefcde" then - Report.Failed("Index_Error not raised by Insert - 3A"); - else - Report.Failed("Index_Error not raised by Insert - 3B"); - end if; - exception - when Ada.Strings.Index_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception from Insert - 3"); - end; - - - -- Procedure Insert - - -- Drop = Right - - ASW.Insert(Source => Insert_String, - Before => 6, - New_Item => Source_String2, -- "abcdef" - Drop => Ada.Strings.Right); - - if Insert_String /= " abcde" then -- last char of New_Item dropped. - Report.Failed("Incorrect result from Insert with Drop = Right"); - end if; - - -- Drop = Left - - ASW.Insert(Source => Insert_String, -- 10 char string - Before => 2, -- 9 chars, 2..10 available - New_Item => Source_String3, -- 12 characters long. - Drop => Ada.Strings.Left); -- truncate from Left. - - if Insert_String /= "l abcde" then -- 10 chars, leading blank. - Report.Failed("Incorrect result from Insert with Drop=Left"); - end if; - - -- Drop = Error - - begin - ASW.Insert(Source => Result_String, -- 10 chars - Before => Result_String'Last, - New_Item => "abcdefghijk", - Drop => Ada.Strings.Error); - Report.Failed("Exception not raised by Procedure Insert"); - exception - when Ada.Strings.Length_Error => null; -- OK, expected exception - when others => - Report.Failed("Incorrect exception raised by Procedure Insert"); - end; - - - - -- Function Overwrite - - TC_Set_Name ("Overwrite"); - - Overwrite_String := TC_Check ( - ASW.Overwrite(Result_String, -- 10 chars - 1, -- starting at pos=1 - Source_String3(1..10))); - - if Overwrite_String /= Source_String3(1..10) then - Report.Failed("Incorrect result from Function Overwrite - 1"); - end if; - - - if TC_Check (ASW.Overwrite("abcdef", 4, "xyz")) /= "abcxyz" or - TC_Check (ASW.Overwrite("a", 1, "xyz")) - /= "xyz" or -- chars appended - TC_Check (ASW.Overwrite("abc", 3, " ")) - /= "ab " or -- blanks appended - TC_Check (ASW.Overwrite("abcde", 1, "z" )) /= "zbcde" - then - Report.Failed("Incorrect result from Function Overwrite - 2"); - end if; - - - - -- Procedure Overwrite, with truncation. - - ASW.Overwrite(Source => Overwrite_String, -- 10 characters. - Position => 1, - New_Item => Source_String3, -- 12 characters. - Drop => Ada.Strings.Left); - - if Overwrite_String /= "cdefghijkl" then - Report.Failed("Incorrect result from Overwrite with Drop=Left"); - end if; - - -- The default drop value is Right, used here. - - ASW.Overwrite(Source => Overwrite_String, -- 10 characters. - Position => 1, - New_Item => Source_String3); -- 12 characters. - - if Overwrite_String /= "abcdefghij" then - Report.Failed("Incorrect result from Overwrite with Drop=Right"); - end if; - - -- Drop = Error - - begin - ASW.Overwrite(Source => Overwrite_String, -- 10 characters. - Position => 1, - New_Item => Source_String3, -- 12 characters. - Drop => Ada.Strings.Error); - Report.Failed("Exception not raised by Procedure Overwrite"); - exception - when Ada.Strings.Length_Error => null; -- OK, expected exception. - when others => - Report.Failed - ("Incorrect exception raised by Procedure Overwrite"); - end; - - Overwrite_String := "ababababab"; - ASW.Overwrite(Overwrite_String, Overwrite_String'Last, "z"); - ASW.Overwrite(Overwrite_String, Overwrite_String'First,"z"); - ASW.Overwrite(Overwrite_String, 5, "zz"); - - if Overwrite_String /= "zbabzzabaz" then - Report.Failed("Incorrect result from Procedure Overwrite"); - end if; - - - - -- Function Delete - - TC_Set_Name ("Delete"); - - declare - New_String1 : constant Wide_String := -- Returns a 4 char wide str. - TC_Check (ASW.Delete(Source => Source_String3, - From => 3, - Through => 10)); - New_String2 : constant Wide_String := -- This returns Source. - TC_Check (ASW.Delete(Source_String3, 10, 3)); - begin - if New_String1 /= "abkl" or - New_String2 /= Source_String3 - then - Report.Failed("Incorrect result from Function Delete - 1"); - end if; - end; - - if TC_Check (ASW.Delete("a", 1, 1)) - /= "" or -- Source length = 1 - TC_Check (ASW.Delete("abc", 1, 2)) - /= "c" or -- From = Source'First - TC_Check (ASW.Delete("abc", 3, 3)) - /= "ab" or -- From = Source'Last - TC_Check (ASW.Delete("abc", 3, 1)) - /= "abc" -- From > Through - then - Report.Failed("Incorrect result from Function Delete - 2"); - end if; - - - - -- Procedure Delete - - -- Justify = Left - - Delete_String := Source_String3(1..10); -- Initialize to "abcdefghij" - - ASW.Delete(Source => Delete_String, - From => 6, - Through => Delete_String'Last, - Justify => Ada.Strings.Left, - Pad => 'x'); -- pad with char 'x' - - if Delete_String /= "abcdexxxxx" then - Report.Failed("Incorrect result from Delete - Justify = Left"); - end if; - - -- Justify = Right - - ASW.Delete(Source => Delete_String, -- Remove x"s from end and - From => 6, -- shift right. - Through => Delete_String'Last, - Justify => Ada.Strings.Right, - Pad => 'x'); -- pad with char 'x' on left. - - if Delete_String /= "xxxxxabcde" then - Report.Failed("Incorrect result from Delete - Justify = Right"); - end if; - - -- Justify = Center - - ASW.Delete(Source => Delete_String, - From => 1, - Through => 5, - Justify => Ada.Strings.Center, - Pad => 'z'); - - if Delete_String /= "zzabcdezzz" then -- extra pad char on right side. - Report.Failed("Incorrect result from Delete - Justify = Center"); - end if; - - - - -- Function Trim - -- Use non-identity character sets to perform the trim operation. - - TC_Set_Name ("Trim"); - - Trim_String := "cdabcdefcd"; - - -- Remove the "cd" from each end of the string. This will not effect - -- the "cd" slice at 5..6. - - declare - New_String : constant Wide_String := - TC_Check (ASW.Trim(Source => Trim_String, - Left => CD_Set, Right => CD_Set)); - begin - if New_String /= Source_String2 then -- string "abcdef" - Report.Failed - ("Incorrect result from Trim with wide character sets"); - end if; - end; - - if TC_Check (ASW.Trim("abcdef", Wide_Maps.Null_Set, Wide_Maps.Null_Set)) - /= "abcdef" then - Report.Failed("Incorrect result from Trim with Null sets"); - end if; - - if TC_Check (ASW.Trim("cdxx", CD_Set, X_Set)) /= "" then - Report.Failed("Incorrect result from Trim, wide string removal"); - end if; - - - -- Procedure Trim - - -- Justify = Right - - ASW.Trim(Source => Trim_String, - Left => CD_Set, - Right => CD_Set, - Justify => Ada.Strings.Right, - Pad => 'x'); - - if Trim_String /= "xxxxabcdef" then - Report.Failed("Incorrect result from Trim with Justify = Right"); - end if; - - -- Justify = Left - - ASW.Trim(Source => Trim_String, - Left => X_Set, - Right => Wide_Maps.Null_Set, - Justify => Ada.Strings.Left, - Pad => ' '); - - if Trim_String /= "abcdef " then -- Padded with 4 blanks on right. - Report.Failed("Incorrect result from Trim with Justify = Left"); - end if; - - -- Justify = Center - - ASW.Trim(Source => Trim_String, - Left => ABCD_Set, - Right => CD_Set, - Justify => Ada.Strings.Center, - Pad => 'x'); - - if Trim_String /= "xxef xx" then -- Padded with 4 pad chars on L/R - Report.Failed("Incorrect result from Trim with Justify = Center"); - end if; - - - - -- Function Head, testing use of padding. - - TC_Set_Name ("Head"); - - -- Use the wide characters of Source_String1 ("abcde") and pad the - -- last five wide characters of Result_String with 'x' wide characters. - - Result_String := TC_CHeck (ASW.Head(Source_String1, 10, 'x')); - - if Result_String /= "abcdexxxxx" then - Report.Failed("Incorrect result from Function Head with padding"); - end if; - - if TC_Check (ASW.Head(" ab ", 2)) /= " " or - TC_Check (ASW.Head("a", 6, 'A')) /= "aAAAAA" or - TC_Check (ASW.Head(ASW.Head("abc ", 7, 'x'), 10, 'X')) - /= "abc xxXXX" - then - Report.Failed("Incorrect result from Function Head"); - end if; - - - - -- Function Tail, testing use of padding. - - TC_Set_Name ("Tail"); - - -- Use the wide characters of Source_String1 ("abcde") and pad the - -- first five wide characters of Result_String with 'x' wide characters. - - Result_String := TC_Check (ASW.Tail(Source_String1, 10, 'x')); - - if Result_String /= "xxxxxabcde" then - Report.Failed("Incorrect result from Function Tail with padding"); - end if; - - if TC_Check (ASW.Tail("abcde ", 5)) - /= "cde " or -- blanks, back - TC_Check (ASW.Tail(" abc ", 8, ' ')) - /= " abc " or -- blanks, front/back - TC_Check (ASW.Tail("", 5, 'Z')) - /= "ZZZZZ" or -- pad characters only - TC_Check (ASW.Tail("abc", 0)) - /= "" or -- null result - TC_Check (ASW.Tail(ASW.Tail(" abc ", 6, 'x'), - 10, - 'X')) /= "XXXXx abc " - then - Report.Failed("Incorrect result from Function Tail"); - end if; - - - - -- Function "*" - with (Natural, Wide_String) parameters - - TC_Set_Name ("""*"""); - - if TC_Check (ASW."*"(3, Source_String1)) /= "abcdeabcdeabcde" or - TC_Check (ASW."*"(2, Source_String2)) /= Source_String6 or - TC_Check (ASW."*"(4, Source_String1(1..2))) /= "abababab" or - TC_Check (ASW."*"(0, Source_String1)) /= "" - then - Report.Failed - ("Incorrect result from Function ""*"" with wide strings"); - end if; - - exception - when others => Report.Failed("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA4016; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a deleted file mode 100644 index 8d6886897ad..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a +++ /dev/null @@ -1,337 +0,0 @@ --- CXA4017.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 subprograms defined in package Ada.Strings.Wide_Bounded --- are available, and that they produce correct results. Specifically, --- check the subprograms Append, Delete, Index, Insert , Length, --- Overwrite, Replace_Slice, Slice, "&", To_Bounded_Wide_String, --- To_Wide_String, Translate, and Trim. --- --- TEST DESCRIPTION: --- This test demonstrates the uses of a variety of the Wide_String --- functions found in the package Ada.Strings.Wide_Bounded, simulating --- the operations found in a text processing environment. --- With bounded wide strings, the length of each "line" of text can vary --- up to the instantiated maximum, allowing one to view a page of text as --- a series of expandable lines. This provides flexibility in text --- formatting of individual lines (wide strings). --- Several subprograms are defined, all of which attempt to take --- advantage of as many different bounded wide string utilities as --- possible. Often, an operation that is being performed in a subprogram --- using a certain bounded wide string utility could more efficiently be --- performed using a different utility. However, in the interest of --- including as broad coverage as possible, a mixture of utilities is --- invoked in this test. --- A simulated page of text is provided as a parameter to the test --- defined subprograms, and the appropriate processing performed. The --- processed page of text is then compared to a predefined "finished" --- page, and test passage/failure is based on the results of this --- comparison. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 06 Nov 95 SAIC Corrected initialization error for ACVC 2.0.1. --- ---! - -with Ada.Strings; -with Ada.Strings.Wide_Bounded; -with Ada.Strings.Wide_Maps; -with Report; - -procedure CXA4017 is - -begin - - Report.Test ("CXA4017", "Check that the subprograms defined in package " & - "Ada.Strings.Wide_Bounded are available, and " & - "that they produce correct results"); - - Test_Block: - declare - - Characters_Per_Line : constant Positive := 40; - Lines_Per_Page : constant Natural := 4; - - - package BS_40 is new - Ada.Strings.Wide_Bounded.Generic_Bounded_Length(Characters_Per_Line); - - use type BS_40.Bounded_Wide_String; - - type Page_Type is array (1..Lines_Per_Page) of - BS_40.Bounded_Wide_String; - - -- Note: Misspellings below are intentional. - - Line1 : BS_40.Bounded_Wide_String := - BS_40.To_Bounded_Wide_String - ("ada is a progrraming language designed"); - Line2 : BS_40.Bounded_Wide_String := - BS_40.To_Bounded_Wide_String("to support the construction of long-"); - Line3 : BS_40.Bounded_Wide_String := - BS_40.To_Bounded_Wide_String("lived, highly reliabel software "); - Line4 : BS_40.Bounded_Wide_String := - BS_40.To_Bounded_Wide_String("systems"); - - Page : Page_Type := (1 => Line1, 2 => Line2, 3 => Line3, 4 => Line4); - - Finished_Page : Page_Type := - (BS_40.To_Bounded_Wide_String - ("Ada is a programming language designed"), - BS_40.To_Bounded_Wide_String("to support the construction of long-"), - BS_40.To_Bounded_Wide_String - ("lived, HIGHLY RELIABLE software systems."), - BS_40.To_Bounded_Wide_String("")); - - --- - - procedure Compress (Page : in out Page_Type) is - Clear_Line : Natural := Lines_Per_Page; - begin - -- If two consecutive lines on the page are together less than the - -- maximum line length, then append those two lines, move up all - -- lower lines on the page, and blank out the last line. - -- This algorithm works one time through the page, does not perform - -- repetitive compression, and is designed for use with this test - -- program only. - for i in 1..Lines_Per_Page - 1 loop - if BS_40.Length(Page(i)) + BS_40.Length(Page(i+1)) <= - BS_40.Max_Length - then - Page(i) := BS_40."&"(Page(i), - Page(i+1)); -- "&" (wd bnd, wd bnd) - - for j in i+1..Lines_Per_Page - 1 loop - Page(j) := - BS_40.To_Bounded_Wide_String - (BS_40.Slice(Page(j+1), - 1, - BS_40.Length(Page(j+1)))); - Clear_Line := j + 1; - end loop; - Page(Clear_Line) := BS_40.Null_Bounded_Wide_String; - end if; - end loop; - end Compress; - - --- - - procedure Format (Page : in out Page_Type) is - Sm_Ada : BS_40.Bounded_Wide_String := - BS_40.To_Bounded_Wide_String("ada"); - Cap_Ada : constant Wide_String := "Ada"; - Char_Pos : Natural := 0; - Finished : Boolean := False; - Line : Natural := Page_Type'Last; - begin - - -- Add a period to the end of the last line. - while Line >= Page_Type'First and not Finished loop - if Page(Line) /= BS_40.Null_Bounded_Wide_String and - BS_40.Length(Page(Line)) <= BS_40.Max_Length - then - Page(Line) := BS_40.Append(Page(Line), '.'); - Finished := True; - end if; - Line := Line - 1; - end loop; - - -- Replace all occurrences of "ada" with "Ada". - for Line in Page_Type'First .. Page_Type'Last loop - Finished := False; - while not Finished loop - Char_Pos := - BS_40.Index (Source => Page(Line), - Pattern => BS_40.To_Wide_String(Sm_Ada), - Going => Ada.Strings.Backward); - -- A zero is returned by function Index if no occurrences of - -- the pattern wide string are found. - Finished := (Char_Pos = 0); - if not Finished then - BS_40.Replace_Slice - (Source => Page(Line), - Low => Char_Pos, - High => Char_Pos + BS_40.Length(Sm_Ada) - 1, - By => Cap_Ada); - end if; - end loop; -- while loop - end loop; -- for loop - - end Format; - - --- - - procedure Spell_Check (Page : in out Page_Type) is - type Spelling_Type is (Incorrect, Correct); - type Word_Array_Type is array (Spelling_Type) - of BS_40.Bounded_Wide_String; - type Dictionary_Type is array (1..2) of Word_Array_Type; - - -- Note that the "words" in the dictionary will require various - -- amounts of Trimming prior to their use in the bounded wide string - -- functions. - Dictionary : Dictionary_Type := - (1 => (BS_40.To_Bounded_Wide_String(" reliabel "), - BS_40.To_Bounded_Wide_String(" reliable ")), - 2 => (BS_40.To_Bounded_Wide_String(" progrraming "), - BS_40.To_Bounded_Wide_String(" programming "))); - - Pos : Natural := Natural'First; - Finished : Boolean := False; - - begin - - for Line in Page_Type'Range loop - - -- Search for the first incorrectly spelled word in the - -- Dictionary, if it is found, replace it with the correctly - -- spelled word, using the Overwrite function. - - while not Finished loop - Pos := - BS_40.Index(Page(Line), - BS_40.To_Wide_String - (BS_40.Trim(Dictionary(1)(Incorrect), - Ada.Strings.Both)), - Ada.Strings.Forward); - Finished := (Pos = 0); - if not Finished then - Page(Line) := - BS_40.Overwrite(Page(Line), - Pos, - BS_40.To_Wide_String - (BS_40.Trim(Dictionary(1)(Correct), - Ada.Strings.Both))); - end if; - end loop; - - Finished := False; - - -- Search for the second incorrectly spelled word in the - -- Dictionary, if it is found, replace it with the correctly - -- spelled word, using the Delete procedure and Insert function. - - while not Finished loop - Pos := - BS_40.Index(Page(Line), - BS_40.To_Wide_String( - BS_40.Trim(Dictionary(2)(Incorrect), - Ada.Strings.Both)), - Ada.Strings.Forward); - - Finished := (Pos = 0); - - if not Finished then - BS_40.Delete - (Page(Line), - Pos, - Pos + BS_40.To_Wide_String - (BS_40.Trim(Dictionary(2)(Incorrect), - Ada.Strings.Both))'Length-1); - Page(Line) := - BS_40.Insert(Page(Line), - Pos, - BS_40.To_Wide_String - (BS_40.Trim(Dictionary(2)(Correct), - Ada.Strings.Both))); - end if; - end loop; - - Finished := False; - - end loop; - end Spell_Check; - - --- - - procedure Bold (Page : in out Page_Type) is - Key_Word : constant Wide_String := "highly reliable"; - Bold_Mapping : constant - Ada.Strings.Wide_Maps.Wide_Character_Mapping := - Ada.Strings.Wide_Maps.To_Mapping - (From => " abcdefghijklmnopqrstuvwxyz", - To => " ABCDEFGHIJKLMNOPQRSTUVWXYZ"); - Pos : Natural := Natural'First; - Finished : Boolean := False; - begin - -- This procedure is designed to change the case of the phrase - -- "highly reliable" into upper case (a type of "Bolding"). - -- All instances of the phrase on all lines of the page will be - -- modified. - - for Line in Page_Type'First .. Page_Type'Last loop - while not Finished loop - Pos := BS_40.Index(Page(Line), Key_Word); - Finished := (Pos = 0); - if not Finished then - - BS_40.Overwrite - (Page(Line), - Pos, - BS_40.To_Wide_String - (BS_40.Translate - (BS_40.To_Bounded_Wide_String - (BS_40.Slice(Page(Line), - Pos, - Pos + Key_Word'Length - 1)), - Bold_Mapping))); - - end if; - end loop; - Finished := False; - end loop; - end Bold; - - - begin - - Compress(Page); - Format(Page); - Spell_Check(Page); - Bold(Page); - - for i in 1..Lines_Per_Page loop - if BS_40.To_Wide_String(Page(i)) /= - BS_40.To_Wide_String(Finished_Page(i)) or - BS_40.Length(Page(i)) /= - BS_40.Length(Finished_Page(i)) - then - Report.Failed("Incorrect modification of Page, Line " & - Integer'Image(i)); - end if; - end loop; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4017; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a deleted file mode 100644 index 98e0ded4a2c..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a +++ /dev/null @@ -1,379 +0,0 @@ --- CXA4018.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 subprograms defined in package --- Ada.Strings.Wide_Bounded are available, and that they produce --- correct results. Specifically, check the subprograms Append, --- Count, Element, Find_Token, Head, Index_Non_Blank, Replace_Element, --- Replicate, Tail, To_Bounded_Wide_String, "&", ">", "<", ">=", "<=", --- and "*". --- --- TEST DESCRIPTION: --- This test, when taken in conjunction with test CXA40[17,19,20], will --- constitute a test of all the functionality contained in package --- Ada.Strings.Wide_Bounded. This test uses a variety of the --- subprograms defined in the wide bounded string package in ways typical --- of common usage. Different combinations of available subprograms --- are used to accomplish similar wide bounded string processing goals. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 22 Dec 94 SAIC Changed obsolete constant to Strings.Wide_Space. --- 06 Nov 95 SAIC Corrected evaluation string used in Head/Tail --- subtests for ACVC 2.0.1. --- ---! - -with Ada.Strings; -with Ada.Strings.Wide_Bounded; -with Ada.Characters.Handling; -with Ada.Strings.Wide_Maps; -with Report; - -procedure CXA4018 is - - -- The following two functions are used to translate character and string - -- values to "Wide" values. They will be applied to all the Wide_Bounded - -- subprogram parameters to simulate the use of Wide_Characters and - -- Wide_Strings in actual practice. Blanks are translated to Wide_Character - -- blanks and all other characters are translated into Wide_Characters with - -- position values 256 greater than their (narrow) character position - -- values. - - function Translate (Ch : Character) return Wide_Character is - C : Character := Ch; - begin - if Ch = ' ' then - return Ada.Characters.Handling.To_Wide_Character(C); - else - return Wide_Character'Val(Character'Pos(Ch) + - Character'Pos(Character'Last) + 1); - end if; - end Translate; - - function Translate (Str : String) return Wide_String is - WS : Wide_String(Str'First..Str'Last); - begin - for i in Str'First..Str'Last loop - WS(i) := Translate(Str(i)); - end loop; - return WS; - end Translate; - - -begin - - Report.Test ("CXA4018", "Check that the subprograms defined in package " & - "Ada.Strings.Wide_Bounded are available, and " & - "that they produce correct results"); - - Test_Block: - declare - - package BS80 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(80); - use type BS80.Bounded_Wide_String; - - Part1 : constant Wide_String := Translate("Rum"); - Part2 : Wide_Character := Translate('p'); - Part3 : BS80.Bounded_Wide_String := - BS80.To_Bounded_Wide_String(Translate("el")); - Part4 : Wide_Character := Translate('s'); - Part5 : BS80.Bounded_Wide_String := - BS80.To_Bounded_Wide_String(Translate("tilt")); - Part6 : Wide_String(1..3) := Translate("ski"); - - Full_Catenate_String, - Full_Append_String, - Constructed_String, - Drop_String, - Replicated_String, - Token_String : BS80.Bounded_Wide_String; - - CharA : Wide_Character := Translate('A'); - CharB : Wide_Character := Translate('B'); - CharC : Wide_Character := Translate('C'); - CharD : Wide_Character := Translate('D'); - CharE : Wide_Character := Translate('E'); - CharF : Wide_Character := Translate('F'); - - ABStr : Wide_String(1..15) := Translate("AAAAABBBBBBBBBB"); - StrB : Wide_String(1..2) := Translate("BB"); - StrE : Wide_String(1..2) := Translate("EE"); - - - begin - - -- Evaluation of the overloaded forms of the "&" operator. - - Full_Catenate_String := - BS80."&"(Part2, -- WChar & Bnd WStr - BS80."&"(Part3, -- Bnd WStr & Bnd WStr - BS80."&"(Part4, -- WChar & Bnd WStr - BS80."&"(Part5, -- Bnd WStr & Bnd WStr - BS80.To_Bounded_Wide_String - (Part6))))); - - Full_Catenate_String := - BS80."&"(Part1, Full_Catenate_String); -- WStr & Bnd WStr - Full_Catenate_String := - BS80."&"(Left => Full_Catenate_String, - Right => Translate('n')); -- Bnd WStr & WChar - - - -- Evaluation of the overloaded forms of function Append. - - Full_Append_String := - BS80.Append(Part2, -- WChar,Bnd WStr - BS80.Append(Part3, -- Bnd WStr, Bnd WStr - BS80.Append(Part4, -- WChar,Bnd WStr - BS80.Append(BS80.To_Wide_String(Part5), -- WStr,Bnd WStr - BS80.To_Bounded_Wide_String(Part6))))); - - Full_Append_String := - BS80.Append(BS80.To_Bounded_Wide_String(Part1), -- Bnd WStr, WStr - BS80.To_Wide_String(Full_Append_String)); - - Full_Append_String := - BS80.Append(Left => Full_Append_String, - Right => Translate('n')); -- Bnd WStr, WChar - - - -- Validate the resulting bounded wide strings. - - if BS80."<"(Full_Catenate_String, Full_Append_String) or - BS80.">"(Full_Catenate_String, Full_Append_String) or - not (Full_Catenate_String = Full_Append_String and - BS80."<="(Full_Catenate_String, Full_Append_String) and - BS80.">="(Full_Catenate_String, Full_Append_String)) - then - Report.Failed - ("Incorrect results from bounded wide string catenation" & - " and comparison"); - end if; - - - -- Evaluate the overloaded forms of the Constructor function "*" and - -- the Replicate function. - - Constructed_String := - BS80."*"(2,CharA) & -- "AA" - BS80."*"(2,StrB) & -- "AABBBB" - BS80."*"(3, BS80."*"(2, CharC)) & -- "AABBBBCCCCCC" - BS80.Replicate(3, - BS80.Replicate(2, CharD)) & -- "AABBBBCCCCCCDDDDDD" - BS80.Replicate(2, StrE) & -- "AABBBBCCCCCCDDDDDDEEEE" - BS80.Replicate(2, CharF); -- "AABBBBCCCCCCDDDDDDEEEEFF" - - - -- Use of Function Replicate that involves dropping wide characters. - -- The attempt to replicate the 15 character wide string six times will - -- exceed the 80 wide character bound of the wide string. Therefore, - -- the result should be the catenation of 5 copies of the 15 character - -- wide string, followed by 5 'A' wide characters (the first five wide - -- characters of the 6th replication) with the remaining wide - -- characters of the 6th replication dropped. - - Drop_String := - BS80.Replicate(Count => 6, - Item => ABStr, -- "AAAAABBBBBBBBBB" - Drop => Ada.Strings.Right); - - if BS80.Element(Drop_String, 1) /= Translate('A') or - BS80.Element(Drop_String, 6) /= Translate('B') or - BS80.Element(Drop_String, 76) /= Translate('A') or - BS80.Element(Drop_String, 80) /= Translate('A') - then - Report.Failed("Incorrect result from Replicate with Drop"); - end if; - - - -- Use function Index_Non_Blank in the evaluation of the - -- Constructed_String. - - if BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Forward) /= - BS80.To_Wide_String(Constructed_String)'First or - BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Backward) /= - BS80.Length(Constructed_String) - then - Report.Failed("Incorrect results from constructor functions"); - end if; - - - - declare - - -- Define wide character set objects for use with the Count function. - -- Constructed_String = "AABBBBCCCCCCDDDDDDEEEEFF" from above. - - A_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := - Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, - 1)); - B_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := - Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, - 3)); - C_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := - Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, - 7)); - D_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := - Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, - 13)); - E_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := - Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, - 19)); - F_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := - Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, - 23)); - Start : Positive; - Stop : Natural := 0; - - begin - - -- Evaluate the results from function Count by comparing the number - -- of A's to the number of F's, B's to E's, and C's to D's in the - -- Constructed_String. - -- There should be an equal number of each of the wide characters that - -- are being compared (i.e., 2 A's and F's, 4 B's and E's, etc) - - if BS80.Count(Constructed_String, A_Set) /= - BS80.Count(Constructed_String, F_Set) or - BS80.Count(Constructed_String, B_Set) /= - BS80.Count(Constructed_String, E_Set) or - not (BS80.Count(Constructed_String, C_Set) = - BS80.Count(Constructed_String, D_Set)) - then - Report.Failed("Incorrect result from function Count"); - end if; - - - -- Evaluate the functions Head, Tail, and Find_Token. - -- Create the Token_String from the Constructed_String above. - - Token_String := - BS80.Tail(BS80.Head(Constructed_String, 3), 2) & -- "AB" & - BS80.Head(BS80.Tail(Constructed_String, 13), 2) & -- "CD" & - BS80.Head(BS80.Tail(Constructed_String, 3), 2); -- "EF" - - if Token_String /= - BS80.To_Bounded_Wide_String(Translate("ABCDEF")) then - Report.Failed("Incorrect result from Catenation of Token_String"); - end if; - - - -- Find the starting/ending position of the first A in the - -- Token_String (both should be 1, only one A appears in string). - -- The Function Head uses the default pad character to return a - -- bounded wide string longer than its input parameter bounded - -- wide string. - - BS80.Find_Token(BS80.Head(Token_String, 10), -- Default pad. - A_Set, - Ada.Strings.Inside, - Start, - Stop); - - if Start /= 1 and Stop /= 1 then - Report.Failed("Incorrect result from Find_Token - 1"); - end if; - - - -- Find the starting/ending position of the first non-AB slice in - -- the "head" five wide characters of Token_String (slice CDE at - -- positions 3-5) - - BS80.Find_Token(BS80.Head(Token_String, 5), -- "ABCDE" - Ada.Strings.Wide_Maps."OR"(A_Set, B_Set), -- Set (AB) - Ada.Strings.Outside, - Start, - Stop); - - if Start /= 3 and Stop /= 5 then - Report.Failed("Incorrect result from Find_Token - 2"); - end if; - - - -- Find the starting/ending position of the first CD slice in - -- the "tail" eight wide characters (including two pad wide - -- characters) of Token_String (slice CD at positions 5-6 of - -- the tail portion specified) - - BS80.Find_Token(BS80.Tail(Token_String, 8, - Ada.Strings.Wide_Space), - Ada.Strings.Wide_Maps."OR"(C_Set, D_Set), - Ada.Strings.Inside, - Start, - Stop); - - if Start /= 5 and Stop /= 6 then - Report.Failed("Incorrect result from Find_Token - 3"); - end if; - - - -- Evaluate the Replace_Element function. - - -- Token_String = "ABCDEF" - - BS80.Replace_Element(Token_String, 3, BS80.Element(Token_String,4)); - - -- Token_String = "ABDDEF" - - BS80.Replace_Element(Source => Token_String, - Index => 2, - By => BS80.Element(Token_String, 5)); - - -- Token_String = "AEDDEF" - - BS80.Replace_Element(Token_String, - 1, - BS80.Element(BS80.Tail(Token_String, 2), 2)); - - -- Token_String = "FEDDEF" - -- Evaluate this result. - - if BS80.Element(Token_String, - BS80.To_Wide_String(Token_String)'First) /= - BS80.Element(Token_String, - BS80.To_Wide_String(Token_String)'Last) or - BS80.Count(Token_String, D_Set) /= - BS80.Count(Token_String, E_Set) or - BS80.Index_Non_Blank(BS80.Head(Token_String,6)) /= - BS80.Index_Non_Blank(BS80.Tail(Token_String,6)) or - BS80.Head(Token_String, 1) /= - BS80.Tail(Token_String, 1) - then - Report.Failed("Incorrect result from operations in combination"); - end if; - - end; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4018; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a deleted file mode 100644 index 943e3e73b88..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a +++ /dev/null @@ -1,1027 +0,0 @@ --- CXA4019.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 subprograms defined in package Ada.Strings.Wide_Bounded --- are available, and that they produce correct results, especially --- under conditions where truncation of the result is required. --- Specifically, check the subprograms Append, Count with non-Identity --- maps, Index with non-Identity maps, Index with Set parameters, --- Insert (function and procedure), Replace_Slice (function and --- procedure), To_Bounded_Wide_String, and Translate (function and --- procedure). --- --- TEST DESCRIPTION: --- This test, in conjunction with tests CXA4017, CXA4018, and CXA4020, --- will provide coverage of the most common usages of the functionality --- found in the Ada.Strings.Wide_Bounded package. It deals in large part --- with truncation effects and options. This test contains many small, --- specific test cases, situations that are often difficult to generate --- in large numbers in an application-based test. These cases represent --- specific usage paradigms in-the-small. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 06 Nov 95 SAIC Corrected expected result string in subtest for --- ACVC 2.0.1. --- Moved function Dog_to_Cat_Mapping to library --- level to correct accessibility problem in test. --- 22 Aug 96 SAIC Corrected three subtests identified in reviewer --- comments. --- 17 Feb 97 PWB.CTA Corrected result strings for Translate and Insert --- ---! - -package CXA40190 is - - -- Wide Character mapping function defined for use with specific - -- versions of functions Index and Count. - - function Dog_to_Cat_Mapping (From : Wide_Character) - return Wide_Character; - -end CXA40190; - -package body CXA40190 is - - -- Translates "dog" to "cat". - function Dog_to_Cat_Mapping (From : Wide_Character) - return Wide_Character is - begin - if From = 'd' then - return 'c'; - elsif From = 'o' then - return 'a'; - elsif From = 'g' then - return 't'; - else - return From; - end if; - end Dog_to_Cat_Mapping; - -end CXA40190; - - -with CXA40190; -with Report; -with Ada.Characters.Handling; -with Ada.Strings.Wide_Bounded; -with Ada.Strings.Wide_Maps; -with Ada.Strings.Wide_Maps.Wide_Constants; - -procedure CXA4019 is - - -- The following two functions are used to translate character and string - -- values to "Wide" values. They will be applied to all the Wide_Bounded - -- subprogram parameters to simulate the use of Wide_Characters and - -- Wide_Strings in actual practice. - - function Equiv (Ch : Character) return Wide_Character is - C : Character := Ch; - begin - if Ch = ' ' then - return Ada.Characters.Handling.To_Wide_Character(C); - else - return Wide_Character'Val(Character'Pos(Ch) + - Character'Pos(Character'Last) + 1); - end if; - end Equiv; - - - function Equiv (Str : String) return Wide_String is - WS : Wide_String(Str'First..Str'Last); - begin - for i in Str'First..Str'Last loop - WS(i) := Equiv(Str(i)); - end loop; - return WS; - end Equiv; - -begin - - Report.Test("CXA4019", "Check that the subprograms defined in " & - "package Ada.Strings.Wide_Bounded are " & - "available, and that they produce correct " & - "results, especially under conditions where " & - "truncation of the result is required"); - - Test_Block: - declare - - use CXA40190; - - package AS renames Ada.Strings; - package ASB renames Ada.Strings.Wide_Bounded; - package ASWC renames Ada.Strings.Wide_Maps.Wide_Constants; - package Maps renames Ada.Strings.Wide_Maps; - - package B10 is new ASB.Generic_Bounded_Length(Max => 10); - use type B10.Bounded_Wide_String; - - Result_String : B10.Bounded_Wide_String; - Test_String : B10.Bounded_Wide_String; - AtoE_Bnd_Str : B10.Bounded_Wide_String := - B10.To_Bounded_Wide_String(Equiv("abcde")); - FtoJ_Bnd_Str : B10.Bounded_Wide_String := - B10.To_Bounded_Wide_String(Equiv("fghij")); - AtoJ_Bnd_Str : B10.Bounded_Wide_String := - B10.To_Bounded_Wide_String(Equiv("abcdefghij")); - - Location : Natural := 0; - Total_Count : Natural := 0; - - CD_Set : Maps.Wide_Character_Set := Maps.To_Set("cd"); - Wide_CD_Set : Maps.Wide_Character_Set := Maps.To_Set(Equiv("cd")); - - AB_to_YZ_Map : Maps.Wide_Character_Mapping := - Maps.To_Mapping(From => "ab", To => "yz"); - - Wide_AB_to_YZ_Map : Maps.Wide_Character_Mapping := - Maps.To_Mapping(From => Equiv("ab"), - To => Equiv("yz")); - - CD_to_XY_Map : Maps.Wide_Character_Mapping := - Maps.To_Mapping(From => "cd", To => "xy"); - - Wide_CD_to_XY_Map : Maps.Wide_Character_Mapping := - Maps.To_Mapping(From => Equiv("cd"), - To => Equiv("xy")); - - - -- Access-to-Subprogram object defined for use with specific versions of - -- functions Index, Count Translate, and procedure Translate. - - Map_Ptr : Maps.Wide_Character_Mapping_Function := - Dog_to_Cat_Mapping'Access; - - - - begin - - -- Function To_Bounded_Wide_String with Truncation - -- Evaluate the function Append with parameters that will - -- cause the truncation of the result. - - -- Drop = Error (default case, Length_Error will be raised) - - begin - Test_String := - B10.To_Bounded_Wide_String - (Equiv("Much too long for this bounded wide string")); - Report.Failed("Length Error not raised by To_Bounded_Wide_String"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed - ("Incorrect exception raised by To_Bounded_Wide_String"); - end; - - -- Drop = Left - - Test_String := - B10.To_Bounded_Wide_String(Source => Equiv("abcdefghijklmn"), - Drop => Ada.Strings.Left); - - if Test_String /= B10.To_Bounded_Wide_String(Equiv("efghijklmn")) then - Report.Failed - ("Incorrect result from To_Bounded_Wide_String, Drop = Left"); - end if; - - -- Drop = Right - - Test_String := - B10.To_Bounded_Wide_String(Source => Equiv("abcdefghijklmn"), - Drop => Ada.Strings.Right); - - if not(Test_String = AtoJ_Bnd_Str) then - Report.Failed - ("Incorrect result from To_Bounded_Wide_String, Drop = Right"); - end if; - - - - - -- Function Append with Truncation - -- Evaluate the function Append with parameters that will - -- cause the truncation of the result. - - -- Drop = Error (default case, Length_Error will be raised) - - begin - -- Append (Bnd Str, Bnd Str); - Result_String := - B10.Append(B10.To_Bounded_Wide_String(Equiv("abcde")), - B10.To_Bounded_Wide_String(Equiv("fghijk"))); -- 11 char - Report.Failed("Length_Error not raised by Append - 1"); - exception - when AS.Length_Error => null; -- OK, correct exception raised. - when others => - Report.Failed("Incorrect exception raised by Append - 1"); - end; - - begin - -- Append (Str, Bnd Str); - Result_String := - B10.Append(B10.To_Wide_String(AtoE_Bnd_Str), - B10.To_Bounded_Wide_String(Equiv("fghijk")), - AS.Error); - Report.Failed("Length_Error not raised by Append - 2"); - exception - when AS.Length_Error => null; -- OK, correct exception raised. - when others => - Report.Failed("Incorrect exception raised by Append - 2"); - end; - - begin - -- Append (Bnd Str, Char); - Result_String := - B10.Append(B10.To_Bounded_Wide_String("abcdefghij"), 'k'); - Report.Failed("Length_Error not raised by Append - 3"); - exception - when AS.Length_Error => null; -- OK, correct exception raised. - when others => - Report.Failed("Incorrect exception raised by Append - 3"); - end; - - -- Drop = Left - - -- Append (Bnd Str, Bnd Str) - Result_String := - B10.Append(B10.To_Bounded_Wide_String(Equiv("abcdefgh")), -- 8 chs - B10.To_Bounded_Wide_String(Equiv("ijklmn")), -- 6 chs - Ada.Strings.Left); - - if Result_String /= - B10.To_Bounded_Wide_String(Equiv("efghijklmn")) -- 10 chars - then - Report.Failed("Incorrect truncation performed by Append - 4"); - end if; - - -- Append (Bnd Str, Str) - Result_String := - B10.Append(B10.To_Bounded_Wide_String("abcdefghij"), - "xyz", - Ada.Strings.Left); - - if Result_String /= B10.To_Bounded_Wide_String("defghijxyz") then - Report.Failed("Incorrect truncation performed by Append - 5"); - end if; - - -- Append (Char, Bnd Str) - - Result_String := - B10.Append(Equiv('A'), - B10.To_Bounded_Wide_String(Equiv("abcdefghij")), - Ada.Strings.Left); - - if Result_String /= B10.To_Bounded_Wide_String(Equiv("abcdefghij")) - then - Report.Failed("Incorrect truncation performed by Append - 6"); - end if; - - -- Drop = Right - - -- Append (Bnd Str, Bnd Str) - Result_String := B10.Append(FtoJ_Bnd_Str, - AtoJ_Bnd_Str, - Ada.Strings.Right); - - if Result_String /= - B10.To_Bounded_Wide_String(Equiv("fghijabcde")) - then - Report.Failed("Incorrect truncation performed by Append - 7"); - end if; - - -- Append (Str, Bnd Str) - Result_String := B10.Append(B10.To_Wide_String(AtoE_Bnd_Str), - AtoJ_Bnd_Str, - Ada.Strings.Right); - - if Result_String /= - B10.To_Bounded_Wide_String(Equiv("abcdeabcde")) - then - Report.Failed("Incorrect truncation performed by Append - 8"); - end if; - - -- Append (Char, Bnd Str) - Result_String := B10.Append(Equiv('A'), AtoJ_Bnd_Str, Ada.Strings.Right); - - if Result_String /= B10.To_Bounded_Wide_String(Equiv("Aabcdefghi")) then - Report.Failed("Incorrect truncation performed by Append - 9"); - end if; - - - - -- Function Index with non-Identity map. - -- Evaluate the function Index with a non-identity map - -- parameter which will cause mapping of the source parameter - -- prior to the evaluation of the index position search. - - Location := - B10.Index(Source => B10.To_Bounded_Wide_String("foxy fox 2"), - Pattern => "FOX", - Going => Ada.Strings.Backward, - Mapping => ASWC.Upper_Case_Map); - - if Location /= 6 then - Report.Failed("Incorrect result from Index, non-Identity map - 1"); - end if; - - Location := - B10.Index(B10.To_Bounded_Wide_String("THE QUICK "), - "quick", - Ada.Strings.Forward, - Ada.Strings.Wide_Maps.Wide_Constants.Lower_Case_Map); - - if Location /= 5 then - Report.Failed("Incorrect result from Index, non-Identity map - 2"); - end if; - - Location := B10.Index(Source => B10.To_Bounded_Wide_String("The the"), - Pattern => "the", - Going => Ada.Strings.Forward, - Mapping => ASWC.Lower_Case_Map); - - if Location /= 1 then - Report.Failed("Incorrect result from Index, non-Identity map - 3"); - end if; - - - - if B10.Index(B10.To_Bounded_Wide_String("abcd"), -- Pattern = Source - "abcd") /= 1 or - B10.Index(B10.To_Bounded_Wide_String("abc"), -- Pattern < Source - "abcd") /= 0 or - B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null - "abc") /= 0 - then - Report.Failed("Incorrect result from Index with string patterns"); - end if; - - - - -- Function Index with access-to-subprogram mapping value. - -- Evaluate the function Index with a wide character mapping function - -- object that performs the mapping operation. - - Location := B10.Index(Source => B10.To_Bounded_Wide_String("My dog"), - Pattern => "cat", - Going => Ada.Strings.Forward, - Mapping => Map_Ptr); -- change "dog" to "cat" - - if Location /= 4 then - Report.Failed("Incorrect result from Index, w/map ptr - 1"); - end if; - - Location := B10.Index(B10.To_Bounded_Wide_String("cat or dog"), - "cat", - Ada.Strings.Backward, - Map_Ptr); - - if Location /= 8 then - Report.Failed("Incorrect result from Index, w/map ptr - 2"); - end if; - - if B10.Index(B10.To_Bounded_Wide_String("dog"), -- Pattern = Source - "cat", - Ada.Strings.Forward, - Map_Ptr) /= 1 or - B10.Index(B10.To_Bounded_Wide_String("dog"), -- Pattern < Source - "cats", - Ada.Strings.Backward, - Map_Ptr) /= 0 or - B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null - "cat", - Ada.Strings.Forward, - Map_Ptr) /= 0 or - B10.Index(B10.To_Bounded_Wide_String("hot dog"), - "dog", - Ada.Strings.Backward, - Map_Ptr) /= 0 or - B10.Index(B10.To_Bounded_Wide_String(" cat dog "), - " cat", - Ada.Strings.Backward, - Map_Ptr) /= 5 or - B10.Index(B10.To_Bounded_Wide_String("dog CatDog"), - "cat", - Ada.Strings.Backward, - Map_Ptr) /= 1 or - B10.Index(B10.To_Bounded_Wide_String("CatandDog"), - "cat", - Ada.Strings.Forward, - Map_Ptr) /= 0 or - B10.Index(B10.To_Bounded_Wide_String("dddd"), - "ccccc", - Ada.Strings.Backward, - Map_Ptr) /= 0 - then - Report.Failed("Incorrect result from Index w/map ptr - 3"); - end if; - - - - -- Function Index (for Sets). - -- This version of Index uses Sets as the basis of the search. - - -- Test = Inside, Going = Forward (Default case). - Location := - B10.Index(Source => B10.To_Bounded_Wide_String(Equiv("abcdeabcde")), - Set => Wide_CD_Set, - Test => Ada.Strings.Inside, - Going => Ada.Strings.Forward); - - if not (Location = 3) then -- position of first 'c' equivalent in source. - Report.Failed("Incorrect result from Index using Sets - 1"); - end if; - - -- Test = Inside, Going = Backward. - Location := - B10.Index(Source => B10."&"(AtoE_Bnd_Str, AtoE_Bnd_Str), - Set => Wide_CD_Set, - Test => Ada.Strings.Inside, - Going => Ada.Strings.Backward); - - if not (Location = 9) then -- position of last 'd' in source. - Report.Failed("Incorrect result from Index using Sets - 2"); - end if; - - -- Test = Outside, Going = Forward. - Location := B10.Index(B10.To_Bounded_Wide_String("deddacd"), - CD_Set, - Test => Ada.Strings.Outside, - Going => Ada.Strings.Forward); - - if Location /= 2 then -- position of 'e' in source. - Report.Failed("Incorrect result from Index using Sets - 3"); - end if; - - -- Test = Outside, Going = Backward. - Location := B10.Index(B10.To_Bounded_Wide_String(Equiv("deddacd")), - Wide_CD_Set, - Ada.Strings.Outside, - Ada.Strings.Backward); - - if Location /= 5 then -- position of 'a', correct. - Report.Failed("Incorrect result from Index using Sets - 4"); - end if; - - if B10.Index(B10.To_Bounded_Wide_String("cd"), -- Source = Set - CD_Set) /= 1 or - B10.Index(B10.To_Bounded_Wide_String("c"), -- Source < Set - CD_Set) /= 1 or - B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null - Wide_CD_Set) /= 0 or - B10.Index(AtoE_Bnd_Str, - Maps.To_Set('x')) /= 0 -- No match. - then - Report.Failed("Incorrect result from Index using Sets - 5"); - end if; - - - - -- Function Count with non-Identity mapping. - -- Evaluate the function Count with a non-identity map - -- parameter which will cause mapping of the source parameter - -- prior to the evaluation of the number of matching patterns. - - Total_Count := - B10.Count(Source => B10.To_Bounded_Wide_String("THE THE TH"), - Pattern => "th", - Mapping => ASWC.Lower_Case_Map); - - if Total_Count /= 3 then - Report.Failed - ("Incorrect result from function Count, non-Identity map - 1"); - end if; - - -- And a few with identity maps as well. - - if B10.Count(B10.To_Bounded_Wide_String(Equiv("ABABABABAB")), - Equiv("ABA"), - Maps.Identity) /= 2 or - B10.Count(B10.To_Bounded_Wide_String("ADCBADABCD"), - "AB", - Maps.To_Mapping("CD", "AB")) /= 5 or - B10.Count(B10.To_Bounded_Wide_String(Equiv("aaaaaaaaaa")), - Equiv("aaa")) /= 3 or - B10.Count(B10.To_Bounded_Wide_String(Equiv("XX")), - Equiv("XXX"), - Maps.Identity) /= 0 or - B10.Count(AtoE_Bnd_Str, -- Source = Pattern - Equiv("abcde")) /= 1 or - B10.Count(B10.Null_Bounded_Wide_String, -- Source = Null - " ") /= 0 - then - Report.Failed - ("Incorrect result from function Count, w,w/o mapping"); - end if; - - - - - - -- Function Count with access-to-subprogram mapping. - -- Evaluate the version function Count that uses an access-to-subprogram - -- map parameter. - - Total_Count := - B10.Count(Source => B10.To_Bounded_Wide_String("dogdogdo"), - Pattern => "ca", - Mapping => Map_Ptr); - - if Total_Count /= 3 then - Report.Failed - ("Incorrect result from function Count, w/map ptr - 1"); - end if; - - - if B10.Count(B10.To_Bounded_Wide_String("DdOoGgod"), - "c", - Map_Ptr) /= 2 or - B10.Count(B10.To_Bounded_Wide_String("dododododo"), - "do", - Map_Ptr) /= 0 or - B10.Count(B10.To_Bounded_Wide_String("Dog or dog"), - "cat", - Map_Ptr) /= 1 or - B10.Count(B10.To_Bounded_Wide_String("dddddddddd"), - "ccccc", - Map_Ptr) /= 2 or - B10.Count(B10.To_Bounded_Wide_String("do"), -- Source < Pattern - "cat", - Map_Ptr) /= 0 or - B10.Count(B10.To_Bounded_Wide_String(" dog "), -- Source = Pattern - " cat ", - Map_Ptr) /= 1 or - B10.Count(B10.Null_Bounded_Wide_String, -- Source = Null - " ", - Map_Ptr) /= 0 - then - Report.Failed - ("Incorrect result from function Count, w/map ptr - 2"); - end if; - - - - - -- Procedure Translate - - -- Partial mapping of source. - - Test_String := B10.To_Bounded_Wide_String("abcdeabcab"); - - B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); - - if Test_String /= B10.To_Bounded_Wide_String("yzcdeyzcyz") then - Report.Failed("Incorrect result from procedure Translate - 1"); - end if; - - -- Total mapping of source. - - Test_String := B10.To_Bounded_Wide_String("abbaaababb"); - - B10.Translate(Source => Test_String, Mapping => ASWC.Upper_Case_Map); - - if Test_String /= B10.To_Bounded_Wide_String("ABBAAABABB") then - Report.Failed("Incorrect result from procedure Translate - 2"); - end if; - - -- No mapping of source. - - Test_String := B10.To_Bounded_Wide_String(Equiv("xyzsypcc")); - - B10.Translate(Source => Test_String, Mapping => Wide_AB_to_YZ_Map); - - if Test_String /= B10.To_Bounded_Wide_String(Equiv("xyzsypcc")) then - Report.Failed("Incorrect result from procedure Translate - 3"); - end if; - - -- Map > 2 characters, partial mapping. - - Test_String := B10.To_Bounded_Wide_String("opabcdelmn"); - - B10.Translate(Test_String, - Maps.To_Mapping("abcde", "lmnop")); - - if Test_String /= B10.To_Bounded_Wide_String("oplmnoplmn") then - Report.Failed("Incorrect result from procedure Translate - 4"); - end if; - - - - - -- Procedure Translate with access-to-subprogram mapping. - -- Use the version of Procedure Translate that takes an - -- access-to-subprogram parameter to perform the Source mapping. - - -- Partial mapping of source. - - Test_String := B10.To_Bounded_Wide_String("dogeatdog"); - - B10.Translate(Source => Test_String, Mapping => Map_Ptr); - - if Test_String /= B10.To_Bounded_Wide_String("cateatcat") then - Report.Failed - ("Incorrect result from procedure Translate w/map ptr - 1"); - end if; - - Test_String := B10.To_Bounded_Wide_String("odogcatlmn"); - - B10.Translate(Test_String, Map_Ptr); - - if Test_String /= B10.To_Bounded_Wide_String("acatcatlmn") then - Report.Failed - ("Incorrect result from procedure Translate w/map ptr - 2"); - end if; - - - -- Total mapping of source. - - Test_String := B10.To_Bounded_Wide_String("gggooooddd"); - - B10.Translate(Source => Test_String, Mapping => Map_Ptr); - - if Test_String /= B10.To_Bounded_Wide_String("tttaaaaccc") then - Report.Failed - ("Incorrect result from procedure Translate w/map ptr- 3"); - end if; - - -- No mapping of source. - - Test_String := B10.To_Bounded_Wide_String(" DOG cat "); - - B10.Translate(Source => Test_String, Mapping => Map_Ptr); - - if Test_String /= B10.To_Bounded_Wide_String(" DOG cat ") then - Report.Failed - ("Incorrect result from procedure Translate w/map ptr - 4"); - end if; - - Test_String := B10.Null_Bounded_Wide_String; - - B10.Translate(Source => Test_String, Mapping => Map_Ptr); - - if Test_String /= B10.To_Bounded_Wide_String("") then - Report.Failed - ("Incorrect result from procedure Translate w/map ptr - 5"); - end if; - - - - - -- Function Translate with access-to-subprogram mapping. - -- Use the version of Function Translate that takes an - -- access-to-subprogram parameter to perform the Source mapping. - - -- Partial mapping of source. - - if B10.Translate(Source => B10.To_Bounded_Wide_String("cateatdog"), - Mapping => Map_Ptr) /= - B10.To_Bounded_Wide_String("cateatcat") - then - Report.Failed - ("Incorrect result from function Translate w/map ptr - 1"); - end if; - - if B10.Translate(B10.To_Bounded_Wide_String("cadogtac"), - Map_Ptr) /= - B10.To_Bounded_Wide_String("cacattac") - then - Report.Failed - ("Incorrect result from function Translate w/map ptr - 2"); - end if; - - -- Total mapping of source. - - if B10.Translate(Source => B10.To_Bounded_Wide_String("dogodggdo"), - Mapping => Map_Ptr) /= - B10.To_Bounded_Wide_String("catacttca") - then - Report.Failed - ("Incorrect result from function Translate w/map ptr- 3"); - end if; - - -- No mapping of source. - - if B10.Translate(Source => B10.To_Bounded_Wide_String(" DOG cat "), - Mapping => Map_Ptr) /= - B10.To_Bounded_Wide_String(" DOG cat ") - then - Report.Failed - ("Incorrect result from function Translate w/map ptr - 4"); - end if; - - if B10.Translate(B10.To_Bounded_Wide_String("d "), Map_Ptr) /= - B10.To_Bounded_Wide_String("c ") or - B10.Translate(B10.To_Bounded_Wide_String(" god"), Map_Ptr) /= - B10.To_Bounded_Wide_String(" tac") or - B10.Translate(B10.To_Bounded_Wide_String("d o g D og"), Map_Ptr) /= - B10.To_Bounded_Wide_String("c a t D at") or - B10.Translate(B10.To_Bounded_Wide_String(" "), Map_Ptr) /= - B10.To_Bounded_Wide_String(" ") or - B10.Translate(B10.To_Bounded_Wide_String("dddddddddd"), Map_Ptr) /= - B10.To_Bounded_Wide_String("cccccccccc") - then - Report.Failed - ("Incorrect result from function Translate w/map ptr - 5"); - end if; - - if B10.Translate(Source => B10.Null_Bounded_Wide_String, - Mapping => Map_Ptr) /= - B10.To_Bounded_Wide_String("") - then - Report.Failed - ("Incorrect result from function Translate w/map ptr - 6"); - end if; - - - - - -- Function Replace_Slice - -- Evaluate function Replace_Slice with - -- a variety of Truncation options. - - -- Drop = Error (Default) - - begin - Test_String := AtoJ_Bnd_Str; - Result_String := - B10.Replace_Slice(Source => Test_String, - Low => 3, - High => 5, -- 3-5, 3 chars. - By => Equiv("xxxxxx")); -- more than 3. - Report.Failed("Length_Error not raised by Function Replace_Slice"); - exception - when AS.Length_Error => null; -- Correct exception raised. - when others => - Report.Failed - ("Incorrect exception raised by Function Replace_Slice"); - end; - - -- Drop = Left - - Result_String := - B10.Replace_Slice(Source => Test_String, - Low => 7, - High => 10, -- 7-10, 4 chars. - By => Equiv("xxxxxx"), -- 6 chars. - Drop => Ada.Strings.Left); - - if Result_String /= - B10.To_Bounded_Wide_String(Equiv("cdefxxxxxx")) -- drop a,b - then - Report.Failed - ("Incorrect result from Function Replace Slice, Drop = Left"); - end if; - - -- Drop = Right - - Result_String := - B10.Replace_Slice(Source => Test_String, - Low => 2, - High => 5, -- 2-5, 4 chars. - By => Equiv("xxxxxx"), -- 6 chars. - Drop => Ada.Strings.Right); - - if Result_String /= - B10.To_Bounded_Wide_String(Equiv("axxxxxxfgh")) -- drop i,j - then - Report.Failed - ("Incorrect result from Function Replace Slice, Drop = Right"); - end if; - - -- Low = High = Source'Last, "By" length = 1. - - if B10.Replace_Slice(AtoE_Bnd_Str, - B10.To_Wide_String(AtoE_Bnd_Str)'Last, - B10.To_Wide_String(AtoE_Bnd_Str)'Last, - Equiv("X"), - Ada.Strings.Error) /= - B10.To_Bounded_Wide_String(Equiv("abcdX")) - then - Report.Failed("Incorrect result from Function Replace_Slice"); - end if; - - -- Index_Error raised when High < Source'First - 1. - begin - Test_String := - B10.Replace_Slice(AtoE_Bnd_Str, - B10.To_Wide_String(AtoE_Bnd_Str)'First, - B10.To_Wide_String(AtoE_Bnd_Str)'First - 2, - Equiv("hijklm")); - Report.Failed("Index_Error not raised by Function Replace_Slice"); - exception - when AS.Index_Error => null; -- OK, expected exception - when Constraint_Error => null; -- Also OK, since RM is not clear - when others => - Report.Failed - ("Incorrect exception raised by Function Replace_Slice"); - end; - - - - -- Procedure Replace_Slice - -- Evaluate procedure Replace_Slice with - -- a variety of Truncation options. - - -- Drop = Error (Default) - - begin - Test_String := AtoJ_Bnd_Str; - B10.Replace_Slice(Source => Test_String, - Low => 3, - High => 5, -- 3-5, 3 chars. - By => Equiv("xxxxxx")); -- more than 3. - Report.Failed("Length_Error not raised by Procedure Replace_Slice"); - exception - when AS.Length_Error => null; -- Correct exception raised. - when others => - Report.Failed - ("Incorrect exception raised by Procedure Replace_Slice"); - end; - - -- Drop = Left - - Test_String := AtoJ_Bnd_Str; - B10.Replace_Slice(Source => Test_String, - Low => 7, - High => 9, -- 7-9, 3 chars. - By => Equiv("xxxxx"), -- 5 chars. - Drop => Ada.Strings.Left); - - if Test_String /= - B10.To_Bounded_Wide_String(Equiv("cdefxxxxxj")) -- drop a,b - then - Report.Failed - ("Incorrect result from Procedure Replace Slice, Drop = Left"); - end if; - - -- Drop = Right - - Test_String := AtoJ_Bnd_Str; - B10.Replace_Slice(Source => Test_String, - Low => 1, - High => 3, -- 1-3, 3chars. - By => Equiv("xxxx"), -- 4 chars. - Drop => Ada.Strings.Right); - - if Test_String /= - B10.To_Bounded_Wide_String(Equiv("xxxxdefghi")) -- drop j - then - Report.Failed - ("Incorrect result from Procedure Replace Slice, Drop = Right"); - end if; - - -- High = Source'First, Low > High (Insert before Low). - - Test_String := AtoE_Bnd_Str; - B10.Replace_Slice(Source => Test_String, - Low => B10.To_Wide_String(Test_String)'Last, - High => B10.To_Wide_String(Test_String)'First, - By => Equiv("XXXX"), -- 4 chars. - Drop => Ada.Strings.Right); - - if Test_String /= B10.To_Bounded_Wide_String(Equiv("abcdXXXXe")) then - Report.Failed - ("Incorrect result from Procedure Replace Slice"); - end if; - - - - - -- Function Insert with Truncation - -- Drop = Error (Default). - - begin - Result_String := - B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij" - Before => 2, - New_Item => Equiv("xyz")); - Report.Failed("Length_Error not raised by Function Insert"); - exception - when AS.Length_Error => null; -- Correct exception raised. - when others => - Report.Failed("Incorrect exception raised by Function Insert"); - end; - - -- Drop = Left - - Result_String := - B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij" - Before => 5, - New_Item => Equiv("xyz"), -- 3 additional chars. - Drop => Ada.Strings.Left); - - if B10.To_Wide_String(Result_String) /= Equiv("dxyzefghij") then - Report.Failed("Incorrect result from Function Insert, Drop = Left"); - end if; - - -- Drop = Right - - Result_String := - B10.Insert(Source => B10.To_Bounded_Wide_String("abcdef"), - Before => 2, - New_Item => "vwxyz", -- 5 additional chars. - Drop => Ada.Strings.Right); - - if B10.To_Wide_String(Result_String) /= "avwxyzbcde" then -- drop f. - Report.Failed("Incorrect result from Function Insert, Drop = Right"); - end if; - - -- Additional cases. - - if B10.Insert(B10.To_Bounded_Wide_String("a"), 1, " B") /= - B10.To_Bounded_Wide_String(" Ba") or - B10.Insert(B10.Null_Bounded_Wide_String, 1, Equiv("abcde")) /= - AtoE_Bnd_Str or - B10.Insert(B10.To_Bounded_Wide_String("ab"), 2, "") /= - B10.To_Bounded_Wide_String("ab") - then - Report.Failed("Incorrect result from Function Insert"); - end if; - - - - -- Procedure Insert - - -- Drop = Error (Default). - begin - Test_String := AtoJ_Bnd_Str; - B10.Insert(Source => Test_String, - Before => 9, - New_Item => Equiv("wxyz"), - Drop => Ada.Strings.Error); - Report.Failed("Length_Error not raised by Procedure Insert"); - exception - when AS.Length_Error => null; -- Correct exception raised. - when others => - Report.Failed("Incorrect exception raised by Procedure Insert"); - end; - - -- Drop = Left - - Test_String := AtoJ_Bnd_Str; - B10.Insert(Source => Test_String, - Before => B10.Length(Test_String), -- before last char - New_Item => Equiv("xyz"), -- 3 additional chars. - Drop => Ada.Strings.Left); - - if B10.To_Wide_String(Test_String) /= Equiv("defghixyzj") then - Report.Failed("Incorrect result from Procedure Insert, Drop = Left"); - end if; - - -- Drop = Right - - Test_String := AtoJ_Bnd_Str; - B10.Insert(Source => Test_String, - Before => 4, - New_Item => Equiv("yz"), -- 2 additional chars. - Drop => Ada.Strings.Right); - - if B10.To_Wide_String(Test_String) /= Equiv("abcyzdefgh") then - Report.Failed - ("Incorrect result from Procedure Insert, Drop = Right"); - end if; - - -- Before = Source'First, New_Item length = 1. - - Test_String := B10.To_Bounded_Wide_String(" abc "); - B10.Insert(Test_String, - B10.To_Wide_String(Test_String)'First, - "Z"); - - if Test_String /= B10.To_Bounded_Wide_String("Z abc ") then - Report.Failed("Incorrect result from Procedure Insert"); - end if; - - - exception - when others => Report.Failed("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA4019; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a deleted file mode 100644 index 24036f17103..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a +++ /dev/null @@ -1,688 +0,0 @@ --- CXA4020.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 subprograms defined in package Ada.Strings.Wide_Bounded --- are available, and that they produce correct results, especially under --- conditions where truncation of the result is required. Specifically, --- check the subprograms Overwrite (function and procedure), Delete, --- Function Trim (blanks), Trim (Set wide characters, function and --- procedure), Head, Tail, and Replicate (wide characters and wide --- strings). --- --- TEST DESCRIPTION: --- This test, in conjunction with tests CXA4017, CXA4018, CXA4019, --- will provide coverage of the most common usages of the functionality --- found in the Ada.Strings.Wide_Bounded package. It deals in large part --- with truncation effects and options. This test contains many small, --- specific test cases, situations that are often difficult to generate --- in large numbers in an application-based test. These cases represent --- specific usage paradigms in-the-small. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 22 Dec 94 SAIC Changed obsolete constant to Strings.Wide_Space. --- 13 Apr 95 SAIC Corrected certain subtest acceptance conditions. --- ---! - -with Report; -with Ada.Characters.Handling; -with Ada.Strings.Wide_Bounded; -with Ada.Strings.Wide_Maps; - -procedure CXA4020 is - - -- The following two functions are used to translate character and string - -- values to "Wide" values. They will be applied to all the Wide_Bounded - -- subprogram parameters to simulate the use of Wide_Characters and - -- Wide_Strings in actual practice. Blanks are translated to Wide_Character - -- blanks and all other characters are translated into Wide_Characters with - -- position values 256 greater than their (narrow) character position - -- values. - - function Translate (Ch : Character) return Wide_Character is - C : Character := Ch; - begin - if Ch = ' ' then - return Ada.Characters.Handling.To_Wide_Character(C); - else - return Wide_Character'Val(Character'Pos(Ch) + - Character'Pos(Character'Last) + 1); - end if; - end Translate; - - - function Translate (Str : String) return Wide_String is - WS : Wide_String(Str'First..Str'Last); - begin - for i in Str'First..Str'Last loop - WS(i) := Translate(Str(i)); - end loop; - return WS; - end Translate; - - -begin - - Report.Test("CXA4020", "Check that the subprograms defined in " & - "package Ada.Strings.Wide_Bounded are " & - "available, and that they produce correct " & - "results, especially under conditions where " & - "truncation of the result is required"); - - Test_Block: - declare - - package AS renames Ada.Strings; - package ASW renames Ada.Strings.Wide_Bounded; - package Maps renames Ada.Strings.Wide_Maps; - - package B10 is new ASW.Generic_Bounded_Length(Max => 10); - use type B10.Bounded_Wide_String; - - Result_String : B10.Bounded_Wide_String; - Test_String : B10.Bounded_Wide_String; - AtoE_Bnd_Str : B10.Bounded_Wide_String := - B10.To_Bounded_Wide_String(Translate("abcde")); - FtoJ_Bnd_Str : B10.Bounded_Wide_String := - B10.To_Bounded_Wide_String(Translate("fghij")); - AtoJ_Bnd_Str : B10.Bounded_Wide_String := - B10.To_Bounded_Wide_String(Translate("abcdefghij")); - - Location : Natural := 0; - Total_Count : Natural := 0; - - CD_Set : Maps.Wide_Character_Set := Maps.To_Set(Translate("cd")); - XY_Set : Maps.Wide_Character_Set := Maps.To_Set(Translate("xy")); - - - begin - - -- Function Overwrite with Truncation - -- Drop = Error (Default). - - begin - Test_String := AtoJ_Bnd_Str; - Result_String := - B10.Overwrite(Source => Test_String, -- "abcdefghij" - Position => 9, - New_Item => Translate("xyz"), - Drop => AS.Error); - Report.Failed("Exception not raised by Function Overwrite"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed("Incorrect exception raised by Function Overwrite"); - end; - - -- Drop = Left - - Result_String := - B10.Overwrite(Source => Test_String, -- "abcdefghij" - Position => B10.Length(Test_String), -- 10 - New_Item => Translate("xyz"), - Drop => Ada.Strings.Left); - - if B10.To_Wide_String(Result_String) /= - Translate("cdefghixyz") then -- drop a,b - Report.Failed - ("Incorrect result from Function Overwrite, Drop = Left"); - end if; - - -- Drop = Right - - Result_String := B10.Overwrite(Test_String, -- "abcdefghij" - 3, - Translate("xxxyyyzzz"), - Ada.Strings.Right); - - if B10.To_Wide_String(Result_String) /= - Translate("abxxxyyyzz") - then - Report.Failed - ("Incorrect result from Function Overwrite, Drop = Right"); - end if; - - -- Additional cases of function Overwrite. - - if B10.Overwrite(B10.To_Bounded_Wide_String(Translate("a")), - 1, -- Source length = 1 - Translate(" abc ")) /= - B10.To_Bounded_Wide_String(Translate(" abc ")) or - B10.Overwrite(B10.Null_Bounded_Wide_String, -- Null source - 1, - Translate("abcdefghij")) /= - AtoJ_Bnd_Str or - B10.Overwrite(AtoE_Bnd_Str, - B10.To_Wide_String(AtoE_Bnd_Str)'First, - Translate(" ")) /= -- New_Item = 1 - B10.To_Bounded_Wide_String(Translate(" bcde")) - then - Report.Failed("Incorrect result from Function Overwrite"); - end if; - - - - -- Procedure Overwrite - -- Correct usage, no truncation. - - Test_String := AtoE_Bnd_Str; -- "abcde" - B10.Overwrite(Test_String, 2, Translate("xyz")); - - if Test_String /= B10.To_Bounded_Wide_String(Translate("axyze")) then - Report.Failed("Incorrect result from Procedure Overwrite - 1"); - end if; - - Test_String := B10.To_Bounded_Wide_String(Translate("abc")); - B10.Overwrite(Test_String, 2, ""); -- New_Item is null string. - - if Test_String /= B10.To_Bounded_Wide_String(Translate("abc")) then - Report.Failed("Incorrect result from Procedure Overwrite - 2"); - end if; - - -- Drop = Error (Default). - - begin - Test_String := AtoJ_Bnd_Str; - B10.Overwrite(Source => Test_String, -- "abcdefghij" - Position => 8, - New_Item => Translate("uvwxyz")); - Report.Failed("Exception not raised by Procedure Overwrite"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed("Incorrect exception raised by Procedure Overwrite"); - end; - - -- Drop = Left - - Test_String := AtoJ_Bnd_Str; - B10.Overwrite(Source => Test_String, -- "abcdefghij" - Position => B10.Length(Test_String) - 2, -- 8 - New_Item => Translate("uvwxyz"), - Drop => Ada.Strings.Left); - - if B10.To_Wide_String(Test_String) /= - Translate("defguvwxyz") - then - Report.Failed - ("Incorrect result from Procedure Overwrite, Drop = Left"); - end if; - - -- Drop = Right - - Test_String := AtoJ_Bnd_Str; - B10.Overwrite(Test_String, -- "abcdefghij" - 3, - Translate("xxxyyyzzz"), - Ada.Strings.Right); - - if B10.To_Wide_String(Test_String) /= Translate("abxxxyyyzz") then - Report.Failed - ("Incorrect result from Procedure Overwrite, Drop = Right"); - end if; - - - - -- Function Delete - - if B10.Delete(Source => AtoJ_Bnd_Str, -- "abcdefghij" - From => 3, - Through => 8) /= - B10."&"(B10.Head(AtoJ_Bnd_Str, 2), - B10.Tail(AtoJ_Bnd_Str, 2)) or - B10.Delete(AtoJ_Bnd_Str, 6, B10.Length(AtoJ_Bnd_Str)) /= - AtoE_Bnd_Str or - B10.Delete(AtoJ_Bnd_Str, 1, 5) /= - FtoJ_Bnd_Str - then - Report.Failed("Incorrect result from Function Delete - 1"); - end if; - - if B10.Delete(B10.To_Bounded_Wide_String(Translate("a")), 1, 1) /= - B10.Null_Bounded_Wide_String or - B10.Delete(AtoE_Bnd_Str, - 5, - B10.To_Wide_String(AtoE_Bnd_Str)'First) /= - AtoE_Bnd_Str or - B10.Delete(AtoE_Bnd_Str, - B10.To_Wide_String(AtoE_Bnd_Str)'Last, - B10.To_Wide_String(AtoE_Bnd_Str)'Last) /= - B10.To_Bounded_Wide_String(Translate("abcd")) - then - Report.Failed("Incorrect result from Function Delete - 2"); - end if; - - - - -- Function Trim - - declare - - Text : B10.Bounded_Wide_String := - B10.To_Bounded_Wide_String(Translate("Text")); - type Bnd_Array_Type is array (1..5) of B10.Bounded_Wide_String; - Bnd_Array : Bnd_Array_Type := - (B10.To_Bounded_Wide_String(Translate(" Text")), - B10.To_Bounded_Wide_String(Translate("Text ")), - B10.To_Bounded_Wide_String(Translate(" Text ")), - B10.To_Bounded_Wide_String(Translate("Text Text")), - B10.To_Bounded_Wide_String(Translate(" Text Text"))); - - begin - - for i in Bnd_Array_Type'Range loop - case i is - when 4 => - if B10.Trim(Bnd_Array(i), AS.Both) /= - Bnd_Array(i) then -- no change - Report.Failed("Incorrect result from Function Trim - 4"); - end if; - when 5 => - if B10.Trim(Bnd_Array(i), AS.Both) /= - B10."&"(Text, B10."&"(Translate(' '), Text)) - then - Report.Failed("Incorrect result from Function Trim - 5"); - end if; - when others => - if B10.Trim(Bnd_Array(i), AS.Both) /= Text then - Report.Failed("Incorrect result from Function Trim - " & - Integer'Image(i)); - end if; - end case; - end loop; - - end; - - - - -- Function Trim using Sets - - -- Trim characters in sets from both sides of the bounded wide string. - if B10.Trim(Source => B10.To_Bounded_Wide_String(Translate("ddabbaxx")), - Left => CD_Set, - Right => XY_Set) /= - B10.To_Bounded_Wide_String(Translate("abba")) - then - Report.Failed - ("Incorrect result from Fn Trim - Sets, Left & Right side - 1"); - end if; - - -- Ensure that the characters in the set provided as the actual to - -- parameter Right are not trimmed from the left side of the bounded - -- wide string; likewise for the opposite side. Only "cd" trimmed - -- from left side, and only "xy" trimmed from right side. - - if B10.Trim(B10.To_Bounded_Wide_String(Translate("cdxyabcdxy")), - CD_Set, - XY_Set) /= - B10.To_Bounded_Wide_String(Translate("xyabcd")) - then - Report.Failed - ("Incorrect result from Fn Trim - Sets, Left & Right side - 2"); - end if; - - -- Ensure that characters contained in the sets are not trimmed from - -- the "interior" of the bounded wide string, just the appropriate ends. - - if B10.Trim(B10.To_Bounded_Wide_String(Translate("cdabdxabxy")), - CD_Set, - XY_Set) /= - B10.To_Bounded_Wide_String(Translate("abdxab")) - then - Report.Failed - ("Incorrect result from Fn Trim - Sets, Left & Right side - 3"); - end if; - - -- Trim characters in set from right side only. No change to Left side. - - if B10.Trim(B10.To_Bounded_Wide_String(Translate("abxyzddcd")), - XY_Set, - CD_Set) /= - B10.To_Bounded_Wide_String(Translate("abxyz")) - then - Report.Failed - ("Incorrect result from Fn Trim - Sets, Right side"); - end if; - - -- Trim no characters on either side of the bounded string. - - Result_String := B10.Trim(AtoJ_Bnd_Str, CD_Set, XY_Set); - if Result_String /= AtoJ_Bnd_Str then - Report.Failed("Incorrect result from Fn Trim - Sets, Neither side"); - end if; - - if B10.Trim(AtoE_Bnd_Str, Maps.Null_Set, Maps.Null_Set) /= - AtoE_Bnd_Str or - B10.Trim(B10.To_Bounded_Wide_String(Translate("dcddcxyyxx")), - CD_Set, - XY_Set) /= - B10.Null_Bounded_Wide_String - then - Report.Failed("Incorrect result from Function Trim"); - end if; - - - - -- Procedure Trim using Sets - - -- Trim characters in sets from both sides of the bounded wide string. - - Test_String := B10.To_Bounded_Wide_String(Translate("dcabbayx")); - B10.Trim(Source => Test_String, - Left => CD_Set, - Right => XY_Set); - - if Test_String /= B10.To_Bounded_Wide_String(Translate("abba")) then - Report.Failed - ("Incorrect result from Proc Trim - Sets, Left & Right side - 1"); - end if; - - -- Ensure that the characters in the set provided as the actual to - -- parameter Right are not trimmed from the left side of the bounded - -- wide string; likewise for the opposite side. Only "cd" trimmed - -- from left side, and only "xy" trimmed from right side. - - Test_String := B10.To_Bounded_Wide_String(Translate("cdxyabcdxy")); - B10.Trim(Test_String, CD_Set, XY_Set); - - if Test_String /= B10.To_Bounded_Wide_String(Translate("xyabcd")) then - Report.Failed - ("Incorrect result from Proc Trim - Sets, Left & Right side - 2"); - end if; - - -- Ensure that characters contained in the sets are not trimmed from - -- the "interior" of the bounded wide string, just the appropriate ends. - - Test_String := B10.To_Bounded_Wide_String(Translate("cdabdxabxy")); - B10.Trim(Test_String, CD_Set, XY_Set); - - if not - (Test_String = B10.To_Bounded_Wide_String(Translate("abdxab"))) then - Report.Failed - ("Incorrect result from Proc Trim - Sets, Left & Right side - 3"); - end if; - - -- Trim characters in set from Left side only. No change to Right side. - - Test_String := B10.To_Bounded_Wide_String(Translate("cccdabxyz")); - B10.Trim(Test_String, CD_Set, XY_Set); - - if Test_String /= B10.To_Bounded_Wide_String(Translate("abxyz")) then - Report.Failed - ("Incorrect result from Proc Trim for Sets, Left side only"); - end if; - - -- Trim no characters on either side of the bounded wide string. - - Test_String := AtoJ_Bnd_Str; - B10.Trim(Test_String, CD_Set, CD_Set); - - if Test_String /= AtoJ_Bnd_Str then - Report.Failed("Incorrect result from Proc Trim-Sets, Neither side"); - end if; - - - - -- Function Head with Truncation - -- Drop = Error (Default). - - begin - Result_String := B10.Head(Source => AtoJ_Bnd_Str, -- max length - Count => B10.Length(AtoJ_Bnd_Str) + 1, - Pad => Translate('X')); - Report.Failed("Length_Error not raised by Function Head"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed("Incorrect exception raised by Function Head"); - end; - - -- Drop = Left - - -- Pad characters (5) are appended to the right end of the bounded - -- wide string (which is initially at its maximum length), then the - -- first five characters of the intermediate result are dropped to - -- conform to the maximum size limit of the bounded wide string (10). - - Result_String := - B10.Head(B10.To_Bounded_Wide_String(Translate("ABCDEFGHIJ")), - 15, - Translate('x'), - Ada.Strings.Left); - - if Result_String /= - B10.To_Bounded_Wide_String(Translate("FGHIJxxxxx")) - then - Report.Failed("Incorrect result from Function Head, Drop = Left"); - end if; - - -- Drop = Right - - -- Pad characters (6) are appended to the left end of the bounded - -- wide string (which is initially at one less than its maximum length), - -- then the last five characters of the intermediate result are dropped - -- (which in this case are the pad characters) to conform to the - -- maximum size limit of the bounded wide string (10). - - Result_String := - B10.Head(B10.To_Bounded_Wide_String(Translate("ABCDEFGHI")), - 15, - Translate('x'), - Ada.Strings.Right); - - if Result_String /= - B10.To_Bounded_Wide_String(Translate("ABCDEFGHIx")) - then - Report.Failed("Incorrect result from Function Head, Drop = Right"); - end if; - - -- Additional cases. - - if B10.Head(B10.Null_Bounded_Wide_String, 5, Translate('a')) /= - B10.To_Bounded_Wide_String(Translate("aaaaa")) or - B10.Head(AtoE_Bnd_Str, - B10.Length(AtoE_Bnd_Str)) /= - AtoE_Bnd_Str - then - Report.Failed("Incorrect result from Function Head"); - end if; - - - - -- Function Tail with Truncation - -- Drop = Error (Default Case) - - begin - Result_String := B10.Tail(Source => AtoJ_Bnd_Str, -- max length - Count => B10.Length(AtoJ_Bnd_Str) + 1, - Pad => Ada.Strings.Wide_Space, - Drop => Ada.Strings.Error); - Report.Failed("Length_Error not raised by Function Tail"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed("Incorrect exception raised by Function Tail"); - end; - - -- Drop = Left - - -- Pad characters (5) are appended to the left end of the bounded wide - -- string (which is initially at two less than its maximum length), - -- then the first three characters of the intermediate result (in this - -- case, 3 pad characters) are dropped. - - Result_String := - B10.Tail(B10.To_Bounded_Wide_String(Translate("ABCDEFGH")), - 13, - Translate('x'), - Ada.Strings.Left); - - if Result_String /= - B10.To_Bounded_Wide_String(Translate("xxABCDEFGH")) - then - Report.Failed("Incorrect result from Function Tail, Drop = Left"); - end if; - - -- Drop = Right - - -- Pad characters (3) are appended to the left end of the bounded wide - -- string (which is initially at its maximum length), then the last - -- three characters of the intermediate result are dropped. - - Result_String := - B10.Tail(B10.To_Bounded_Wide_String(Translate("ABCDEFGHIJ")), - 13, - Translate('x'), - Ada.Strings.Right); - - if Result_String /= - B10.To_Bounded_Wide_String(Translate("xxxABCDEFG")) - then - Report.Failed("Incorrect result from Function Tail, Drop = Right"); - end if; - - -- Additional cases. - - if B10.Tail(B10.Null_Bounded_Wide_String, 3, Translate(' ')) /= - B10.To_Bounded_Wide_String(Translate(" ")) or - B10.Tail(AtoE_Bnd_Str, - B10.To_Wide_String(AtoE_Bnd_Str)'First) /= - B10.To_Bounded_Wide_String(Translate("e")) - then - Report.Failed("Incorrect result from Function Tail"); - end if; - - - - -- Function Replicate (#, Char) with Truncation - -- Drop = Error (Default). - - begin - Result_String := B10.Replicate(Count => B10.Max_Length + 5, - Item => Translate('A'), - Drop => AS.Error); - Report.Failed - ("Length_Error not raised by Replicate for characters"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed - ("Incorrect exception raised by Replicate for characters"); - end; - - -- Drop = Left, Right - -- Since this version of Replicate uses wide character parameters, the - -- result after truncation from left or right will appear the same. - -- The result will be a 10 character bounded wide string, composed of - -- 10 "Item" wide characters. - - if B10.Replicate(Count => 20, - Item => Translate('A'), - Drop => Ada.Strings.Left) /= - B10.Replicate(15, Translate('A'), Ada.Strings.Right) - then - Report.Failed("Incorrect result from Replicate for characters - 1"); - end if; - - -- Blank-filled, 10 character bounded wide strings. - - if B10.Replicate(B10.Max_Length + 1, - Translate(' '), - Drop => Ada.Strings.Left) /= - B10.Replicate(B10.Max_Length, Ada.Strings.Wide_Space) - then - Report.Failed("Incorrect result from Replicate for characters - 2"); - end if; - - -- Additional cases. - - if B10.Replicate(0, Translate('a')) /= B10.Null_Bounded_Wide_String or - B10.Replicate(1, Translate('a')) /= - B10.To_Bounded_Wide_String(Translate("a")) - then - Report.Failed("Incorrect result from Replicate for characters - 3"); - end if; - - - - -- Function Replicate (#, String) with Truncation - -- Drop = Error (Default). - - begin - Result_String := B10.Replicate(Count => 5, -- result would be 15. - Item => Translate("abc")); - Report.Failed - ("Length_Error not raised by Replicate for wide strings"); - exception - when AS.Length_Error => null; -- Expected exception raised. - when others => - Report.Failed - ("Incorrect exception raised by Replicate for wide strings"); - end; - - -- Drop = Left - - Result_String := B10.Replicate(3, Translate("abcd"), Ada.Strings.Left); - - if Result_String /= - B10.To_Bounded_Wide_String(Translate("cdabcdabcd")) - then - Report.Failed - ("Incorrect result from Replicate for wide strings, Drop = Left"); - end if; - - -- Drop = Right - - Result_String := B10.Replicate(3, Translate("abcd"), Ada.Strings.Right); - - if Result_String /= - B10.To_Bounded_Wide_String(Translate("abcdabcdab")) then - Report.Failed - ("Incorrect result from Replicate for wide strings, Drop = Right"); - end if; - - -- Additional cases. - - if B10.Replicate(5, Translate("X")) /= - B10.To_Bounded_Wide_String(Translate("XXXXX")) or - B10.Replicate(10, "") /= - B10.Null_Bounded_Wide_String or - B10.Replicate(0, Translate("ab")) /= - B10.Null_Bounded_Wide_String - then - Report.Failed("Incorrect result from Replicate for wide strings"); - end if; - - - exception - when others => Report.Failed("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA4020; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a deleted file mode 100644 index 345a77c68d0..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a +++ /dev/null @@ -1,311 +0,0 @@ --- CXA4021.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 subprograms defined in package --- Ada.Strings.Wide_Unbounded are available, and that they produce --- correct results. Specifically, check the subprograms Head, Index, --- Index_Non_Blank, Insert, Length, Overwrite, Replace_Slice, Slice, --- Tail, To_Wide_String, To_Unbounded_Wide_String, "*", "&", --- and "=", "<=", ">=". --- --- TEST DESCRIPTION: --- This test demonstrates the uses of many of the subprograms defined --- in package Ada.Strings.Wide_Unbounded for use with unbounded wide --- strings. --- The test attempts to simulate how unbounded wide strings could be used --- to simulate paragraphs of text. Modifications could be easily be --- performed using the provided subprograms (although in this test, the --- main modification performed was the addition of more text to the --- string). One would not have to worry about the formatting of the --- paragraph until it was finished and correct in content. Then, once --- all required editing is complete, the unbounded strings can be divided --- up into the appropriate lengths based on particular formatting --- requirements. The test then compares the formatted text product --- with a predefined "finished product". --- --- This test attempts to use a large number of the subprograms provided --- by package Ada.Strings.Wide_Unbounded. Often, the processing involved --- could have been performed more efficiently using a minimum number --- of the subprograms, in conjunction with loops, etc. However, for --- testing purposes, and in the interest of minimizing the number of --- tests developed, subprogram variety and feature mixing was stressed. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with Report; -with Ada.Characters.Handling; -with Ada.Strings.Wide_Maps; -with Ada.Strings.Wide_Unbounded; - -procedure CXA4021 is - - -- The following two functions are used to translate character and string - -- values to "Wide" values. They will be applied to all the Wide_Bounded - -- subprogram character and string parameters to simulate the use of non- - -- character Wide_Characters and Wide_Strings in actual practice. - -- Note: These functions do not actually return "equivalent" wide - -- characters to their character inputs, just "non-character" - -- wide characters. - - function Equiv (Ch : Character) return Wide_Character is - C : Character := Ch; - begin - if Ch = ' ' then - return Ada.Characters.Handling.To_Wide_Character(C); - else - return Wide_Character'Val(Character'Pos(Ch) + - Character'Pos(Character'Last) + 1); - end if; - end Equiv; - - - function Equiv (Str : String) return Wide_String is - WS : Wide_String(Str'First..Str'Last); - begin - for i in Str'First..Str'Last loop - WS(i) := Equiv(Str(i)); - end loop; - return WS; - end Equiv; - -begin - - Report.Test ("CXA4021", "Check that the subprograms defined in " & - "package Ada.Strings.Wide_Unbounded are " & - "available, and that they produce correct " & - "results"); - - Test_Block: - declare - - package ASW renames Ada.Strings.Wide_Unbounded; - use type ASW.Unbounded_Wide_String; - use Ada.Strings; - - Pamphlet_Paragraph_Count : constant := 2; - Lines : constant := 4; - Line_Length : constant := 40; - - type Document_Type is array (Positive range <>) - of ASW.Unbounded_Wide_String; - - type Camera_Ready_Copy_Type is array (1..Lines) - of Wide_String (1..Line_Length); - - Pamphlet : Document_Type (1..Pamphlet_Paragraph_Count); - - Camera_Ready_Copy : Camera_Ready_Copy_Type := - (others => (others => Ada.Strings.Wide_Space)); - - TC_Finished_Product : Camera_Ready_Copy_Type := - ( 1 => Equiv("Ada is a programming language designed "), - 2 => Equiv("to support long-lived, reliable software"), - 3 => Equiv(" systems. "), - 4 => Equiv("Go with Ada! ")); - - ----- - - - procedure Enter_Text_Into_Document (Document : in out Document_Type) is - begin - - -- Fill in both "paragraphs" of the document. Each unbounded wide - -- string functions as an individual paragraph, containing an - -- unspecified number of characters. - -- Use a variety of different unbounded wide string subprograms to - -- load the data. - - Document(1) := - ASW.To_Unbounded_Wide_String(Equiv("Ada is a language")); - - -- Insert the word "programming" prior to "language". - Document(1) := - ASW.Insert(Document(1), - ASW.Index(Document(1), - Equiv("language")), - ASW.To_Wide_String(Equiv("progra") & -- Wd Str & - ASW."*"(2,Equiv('m')) & -- Wd Unbd & - Equiv("ing "))); -- Wd Str - - - -- Overwrite the word "language" with "language" + additional text. - Document(1) := - ASW.Overwrite(Document(1), - ASW.Index(Document(1), - ASW.To_Wide_String( - ASW.Tail(Document(1), 8, Equiv(' '))), - Ada.Strings.Backward), - Equiv("language designed to support long-lifed")); - - - -- Replace the word "lifed" with "lived". - Document(1) := - ASW.Replace_Slice(Document(1), - ASW.Index(Document(1), Equiv("lifed")), - ASW.Length(Document(1)), - Equiv("lived")); - - - -- Overwrite the word "lived" with "lived" + additional text. - Document(1) := - ASW.Overwrite(Document(1), - ASW.Index(Document(1), - ASW.To_Wide_String - (ASW.Tail(Document(1), 5, Equiv(' '))), - Ada.Strings.Backward), - Equiv("lived, reliable software systems.")); - - - -- Use several of the overloaded versions of "&" to form this - -- unbounded wide string. - - Document(2) := Equiv('G') & - ASW.To_Unbounded_Wide_String(Equiv("o ")) & - ASW.To_Unbounded_Wide_String(Equiv("with")) & - Equiv(' ') & - Equiv("Ada!"); - - end Enter_Text_Into_Document; - - - ----- - - - procedure Create_Camera_Ready_Copy - (Document : in Document_Type; - Camera_Copy : out Camera_Ready_Copy_Type) is - begin - -- Break the unbounded wide strings into fixed lengths. - - -- Search the first unbounded wide string for portions of text that - -- are less than or equal to the length of a wide string in the - -- Camera_Ready_Copy_Type object. - - Camera_Copy(1) := -- Take characters 1-39, - ASW.Slice(Document(1), -- and append a blank space. - 1, - ASW.Index(ASW.To_Unbounded_Wide_String - (ASW.Slice(Document(1), - 1, - Line_Length)), - Ada.Strings.Wide_Maps.To_Set(Equiv(' ')), - Ada.Strings.Inside, - Ada.Strings.Backward)) & Equiv(' '); - - Camera_Copy(2) := -- Take characters 40-79. - ASW.Slice(Document(1), - 40, - (ASW.Index_Non_Blank -- Should return 79 - (ASW.To_Unbounded_Wide_String - (ASW.Slice(Document(1), -- Slice (40..79) - 40, - 79)), - Ada.Strings.Backward) + 39)); -- Increment since - -- this slice starts - -- at 40. - - Camera_Copy(3)(1..9) := ASW.Slice(Document(1), -- Characters 80-88 - 80, - ASW.Length(Document(1))); - - - -- Break the second unbounded wide string into the appropriate - -- length. It is only twelve characters in length, so the entire - -- unbounded wide string will be placed on one string of the output - -- object. - - Camera_Copy(4)(1..ASW.Length(Document(2))) := - ASW.To_Wide_String(ASW.Head(Document(2), - ASW.Length(Document(2)))); - - end Create_Camera_Ready_Copy; - - - ----- - - - function Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type) - return Boolean is - begin - - -- Evaluate wide strings for equality, using the operators defined - -- in package Ada.Strings.Wide_Unbounded. The less than/greater - -- than or equal comparisons should evaluate to "equals => True". - - if ASW.To_Unbounded_Wide_String(Draft(1)) = -- "="(WUnb,WUnb) - ASW.To_Unbounded_Wide_String(Master(1)) and - ASW.To_Unbounded_Wide_String(Draft(2)) <= -- "<="(WUnb,WUnb) - ASW.To_Unbounded_Wide_String(Master(2)) and - ASW.To_Unbounded_Wide_String(Draft(3)) >= -- ">="(WUnb,WUnb) - ASW.To_Unbounded_Wide_String(Master(3)) and - ASW.To_Unbounded_Wide_String(Draft(4)) = -- "="(WUnb,WUnb) - ASW.To_Unbounded_Wide_String(Master(4)) - then - return True; - else - return False; - end if; - - end Valid_Proofread; - - - ----- - - - begin - - -- Enter text into the unbounded wide string paragraphs of the document. - - Enter_Text_Into_Document (Pamphlet); - - - -- Reformat the unbounded wide strings into fixed wide string format. - - Create_Camera_Ready_Copy (Document => Pamphlet, - Camera_Copy => Camera_Ready_Copy); - - - -- Verify the conversion process. - - if not Valid_Proofread (Draft => Camera_Ready_Copy, - Master => TC_Finished_Product) - then - Report.Failed ("Incorrect unbounded wide string processing result"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4021; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a deleted file mode 100644 index 3c649a1a294..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a +++ /dev/null @@ -1,531 +0,0 @@ --- CXA4022.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 subprograms defined in package --- Ada.Strings.Wide_Unbounded are available, and that they produce --- correct results. Specifically, check the subprograms Count, Element, --- Index, Replace_Element, To_Unbounded_Wide_String, and "&", ">", "<". --- --- TEST DESCRIPTION: --- This test demonstrates the uses of many of the subprograms defined --- in package Ada.Strings.Wide_Unbounded for use with unbounded wide --- strings. The test simulates how unbounded wide strings --- will be processed in a user environment, using the subprograms --- provided in this package. --- --- Taken in conjunction with tests CXA4021 and CXA4023, this test will --- constitute a test of the functionality contained in package --- Ada.Strings.Wide Unbounded. This test uses a variety --- of the subprograms defined in the unbounded wide string package --- in ways typical of common usage, with different combinations of --- available subprograms being used to accomplish similar --- unbounded wide string processing goals. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 08 Nov 95 SAIC Corrected accessibility level, type visibility, --- and subtest acceptance criteria problems for --- ACVC 2.0.1 --- ---! - -with Ada.Characters.Handling; -with Ada.Strings; - -package CXA40220 is - - -- The following two functions are used to translate character and string - -- values to "Wide" values. They will be applied to all the Wide_Bounded - -- subprogram character and string parameters to simulate the use of non- - -- character Wide_Characters and Wide_Strings in actual practice. - -- Note: These functions do not actually return "equivalent" wide - -- characters to their character inputs, just "non-character" - -- wide characters. - - function Equiv (Ch : Character) return Wide_Character; - - function Equiv (Str : String) return Wide_String; - - - -- Functions and access-to-subprogram value used to supply mapping - -- capability to the appropriate versions of Count, Index, and - -- Translate. - - function AB_to_US_Mapping_Function (From : Wide_Character) - return Wide_Character; - - function AB_to_Blank_Mapping_Function (From : Wide_Character) - return Wide_Character; - -end CXA40220; - -package body CXA40220 is - - function Equiv (Ch : Character) return Wide_Character is - C : Character := Ch; - begin - if Ch = ' ' then - return Ada.Characters.Handling.To_Wide_Character(C); - else - return Wide_Character'Val(Character'Pos(Ch) + - Character'Pos(Character'Last) + 1); - end if; - end Equiv; - - - function Equiv (Str : String) return Wide_String is - WS : Wide_String(Str'First..Str'Last); - begin - for i in Str'First..Str'Last loop - WS(i) := Equiv(Str(i)); - end loop; - return WS; - end Equiv; - - - function AB_to_US_Mapping_Function (From : Wide_Character) - return Wide_Character is - UnderScore : constant Wide_Character := Equiv('_'); - begin - if From = Equiv('a') or From = Equiv('b') then - return UnderScore; - else - return From; - end if; - end AB_to_US_Mapping_Function; - - - function AB_to_Blank_Mapping_Function (From : Wide_Character) - return Wide_Character is - begin - if From = Equiv('a') or From = Equiv('b') then - return Ada.Strings.Wide_Space; - else - return From; - end if; - end AB_to_Blank_Mapping_Function; - -end CXA40220; - - -with CXA40220; -with Report; -with Ada.Characters.Handling; -with Ada.Strings.Wide_Maps; -with Ada.Strings.Wide_Unbounded; - -procedure CXA4022 is -begin - - Report.Test ("CXA4022", "Check that the subprograms defined in " & - "package Ada.Strings.Wide_Unbounded are " & - "available, and that they produce correct " & - "results"); - - Test_Block: - declare - - use CXA40220; - - package ASW renames Ada.Strings.Wide_Unbounded; - use Ada.Strings; - use type Wide_Maps.Wide_Character_Set; - use type ASW.Unbounded_Wide_String; - - Test_String : ASW.Unbounded_Wide_String; - AtoE_Str : ASW.Unbounded_Wide_String := - ASW.To_Unbounded_Wide_String(Equiv("abcde")); - - Complete_String : ASW.Unbounded_Wide_String := - ASW."&"(ASW.To_Unbounded_Wide_String(Equiv("Incomplete")), - ASW."&"(Ada.Strings.Wide_Space, - ASW.To_Unbounded_Wide_String(Equiv("String")))); - - Incomplete_String : ASW.Unbounded_Wide_String := - ASW.To_Unbounded_Wide_String - (Equiv("ncomplete Strin")); - - Incorrect_Spelling : ASW.Unbounded_Wide_String := - ASW.To_Unbounded_Wide_String(Equiv("Guob Dai")); - - Magic_String : ASW.Unbounded_Wide_String := - ASW.To_Unbounded_Wide_String(Equiv("abracadabra")); - - Incantation : ASW.Unbounded_Wide_String := Magic_String; - - - A_Small_G : Wide_Character := Equiv('g'); - A_Small_D : Wide_Character := Equiv('d'); - - ABCD_Set : Wide_Maps.Wide_Character_Set := - Wide_Maps.To_Set(Equiv("abcd")); - B_Set : Wide_Maps.Wide_Character_Set := - Wide_Maps.To_Set(Equiv('b')); - CD_Set : Wide_Maps.Wide_Character_Set := - Wide_Maps.To_Set(Equiv("cd")); - - CD_to_XY_Map : Wide_Maps.Wide_Character_Mapping := - Wide_Maps.To_Mapping(From => Equiv("cd"), - To => Equiv("xy")); - AB_to_YZ_Map : Wide_Maps.Wide_Character_Mapping := - Wide_Maps.To_Mapping(Equiv("ab"), Equiv("yz")); - - - Matching_Letters : Natural := 0; - Location, - Total_Count : Natural := 0; - - - Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function := - AB_to_US_Mapping_Function'Access; - - - begin - - - -- Function "&" - - -- Prepend an 'I' and append a 'g' to the wide string. - Incomplete_String := ASW."&"(Equiv('I'), - Incomplete_String); -- Ch & W Unb - Incomplete_String := ASW."&"(Incomplete_String, - A_Small_G); -- W Unb & Ch - - if ASW."<"(Incomplete_String, Complete_String) or - ASW.">"(Incomplete_String, Complete_String) or - Incomplete_String /= Complete_String - then - Report.Failed("Incorrect result from use of ""&"" operator"); - end if; - - - - -- Function Element - - -- Last element of the unbounded wide string should be a 'g'. - if ASW.Element(Incomplete_String, ASW.Length(Incomplete_String)) /= - A_Small_G - then - Report.Failed("Incorrect result from use of Function Element - 1"); - end if; - - if ASW.Element(Incomplete_String, 2) /= - ASW.Element(ASW.Tail(Incomplete_String, 2), 1) or - ASW.Element(ASW.Head(Incomplete_String, 4), 2) /= - ASW.Element(ASW.To_Unbounded_Wide_String(Equiv("wnqz")), 2) - then - Report.Failed("Incorrect result from use of Function Element - 2"); - end if; - - - - -- Procedure Replace_Element - - -- The unbounded wide string Incorrect_Spelling starts as "Guob Dai", - -- and is transformed by the following three procedure calls to - -- "Good Day". - - ASW.Replace_Element(Incorrect_Spelling, 2, Equiv('o')); - - ASW.Replace_Element(Incorrect_Spelling, - ASW.Index(Incorrect_Spelling, B_Set), - A_Small_D); - - ASW.Replace_Element(Source => Incorrect_Spelling, - Index => ASW.Length(Incorrect_Spelling), - By => Equiv('y')); - - if Incorrect_Spelling /= - ASW.To_Unbounded_Wide_String(Equiv("Good Day")) - then - Report.Failed("Incorrect result from Procedure Replace_Element"); - end if; - - - - -- Function Index with non-Identity map. - -- Evaluate the function Index with a non-identity map - -- parameter which will cause mapping of the source parameter - -- prior to the evaluation of the index position search. - - Location := ASW.Index(Source => ASW.To_Unbounded_Wide_String - (Equiv("abcdefghij")), - Pattern => Equiv("xy"), - Going => Ada.Strings.Forward, - Mapping => CD_to_XY_Map); -- change "cd" to "xy" - - if Location /= 3 then - Report.Failed("Incorrect result from Index, non-Identity map - 1"); - end if; - - Location := ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcdabcdab")), - Equiv("yz"), - Ada.Strings.Backward, - AB_to_YZ_Map); -- change all "ab" to "yz" - - if Location /= 9 then - Report.Failed("Incorrect result from Index, non-Identity map - 2"); - end if; - - -- A couple with identity maps (default) as well. - - if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcd")), -- Pat = Src - Equiv("abcd")) /= 1 or - ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abc")), -- Pat < Src - Equiv("abcd")) /= 0 or - ASW.Index(ASW.Null_Unbounded_Wide_String, -- Src = Null - Equiv("abc")) /= 0 - then - Report.Failed - ("Incorrect result from Index with wide string patterns"); - end if; - - - - -- Function Index (for Sets). - -- This version of Index uses Sets as the basis of the search. - - -- Test = Inside, Going = Forward (Default case). - Location := - ASW.Index(Source => ASW.To_Unbounded_Wide_String(Equiv("abcdeabcde")), - Set => CD_Set); -- set containing 'c' and 'd' - - if not (Location = 3) then -- position of first 'c' in source. - Report.Failed("Incorrect result from Index using Sets - 1"); - end if; - - -- Test = Inside, Going = Backward. - Location := - ASW.Index(Source => ASW."&"(AtoE_Str, AtoE_Str), - Set => CD_Set, -- set containing 'c' and 'd' - Test => Ada.Strings.Inside, - Going => Ada.Strings.Backward); - - if not (Location = 9) then -- position of last 'd' in source. - Report.Failed("Incorrect result from Index using Sets - 2"); - end if; - - -- Test = Outside, Going = Forward, Backward - if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")), - Wide_Maps.To_Set(Equiv("xydcgf")), - Test => Ada.Strings.Outside, - Going => Ada.Strings.Forward) /= 2 or - ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")), - Wide_Maps.To_Set(Equiv("xydcgf")), - Test => Ada.Strings.Outside, - Going => Ada.Strings.Backward) /= 5 or - ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")), - CD_Set, - Ada.Strings.Outside, - Ada.Strings.Backward) /= 5 - then - Report.Failed("Incorrect result from Index using Sets - 3"); - end if; - - -- Default direction (forward) and mapping (identity). - - if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("cd")), -- Source = Set - CD_Set) /= 1 or - ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("c")), -- Source < Set - CD_Set) /= 1 or - ASW.Index(ASW.Null_Unbounded_Wide_String, -- Source = Null - CD_Set) /= 0 or - ASW.Index(AtoE_Str, - Wide_Maps.Null_Set) /= 0 or -- Null set - ASW.Index(AtoE_Str, - Wide_Maps.To_Set(Equiv('x'))) /= 0 -- No match. - then - Report.Failed("Incorrect result from Index using Sets - 4"); - end if; - - - - -- Function Index using access-to-subprogram mapping. - -- Evaluate the function Index with an access value that supplies the - -- mapping function for this version of Index. - - Map_Ptr := AB_to_US_Mapping_Function'Access; - - Location := ASW.Index(Source => ASW.To_Unbounded_Wide_String - (Equiv("xAxabbxax xaax _cx")), - Pattern => Equiv("_x"), - Going => Ada.Strings.Forward, - Mapping => Map_Ptr); -- change 'a'or 'b' to '_' - - if Location /= 6 then -- location of "bx" substring - Report.Failed("Incorrect result from Index, access value map - 1"); - end if; - - Map_Ptr := AB_to_Blank_Mapping_Function'Access; - - Location := ASW.Index(ASW.To_Unbounded_Wide_String - (Equiv("ccacdcbbcdacc")), - Equiv("cd "), - Ada.Strings.Backward, - Map_Ptr); -- change 'a' or 'b' to ' ' - - if Location /= 9 then - Report.Failed("Incorrect result from Index, access value map - 2"); - end if; - - if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcd")), - Equiv(" cd"), - Ada.Strings.Forward, - Map_Ptr) /= 1 or - ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abc")), - Equiv(" c "), -- No match - Ada.Strings.Backward, - Map_Ptr) /= 0 - then - Report.Failed("Incorrect result from Index, access value map - 3"); - end if; - - - - -- Function Count - - -- Determine the number of characters in the unbounded wide string that - -- are contained in the set. - - Matching_Letters := ASW.Count(Source => Magic_String, - Set => ABCD_Set); - - if Matching_Letters /= 9 then - Report.Failed - ("Incorrect result from Function Count with Set parameter"); - end if; - - -- Determine the number of occurrences of the following pattern wide - -- strings in the unbounded wide string Magic_String. - - if ASW.Count(Magic_String, Equiv("ab")) /= - (ASW.Count(Magic_String, Equiv("ac")) + - ASW.Count(Magic_String, Equiv("ad"))) or - ASW.Count(Magic_String, Equiv("ab")) /= 2 - then - Report.Failed - ("Incorrect result from Function Count, wide string parameter"); - end if; - - - - -- Function Count with non-Identity mapping. - -- Evaluate the function Count with a non-identity map - -- parameter which will cause mapping of the source parameter - -- prior to the evaluation of the number of matching patterns. - - Total_Count := - ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("abbabbabbabba")), - Pattern => Equiv("yz"), - Mapping => AB_to_YZ_Map); - - if Total_Count /= 4 then - Report.Failed - ("Incorrect result from function Count, non-Identity map - 1"); - end if; - - if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("ADCBADABCD")), - Equiv("AB"), - Wide_Maps.To_Mapping(Equiv("CD"), Equiv("AB"))) /= 5 or - ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("dcccddcdccdddccccd")), - Equiv("xxy"), - CD_to_XY_Map) /= 3 - then - Report.Failed - ("Incorrect result from function Count, non-Identity map - 2"); - end if; - - -- And a few with identity Wide_Maps as well. - - if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("ABABABABAB")), - Equiv("ABA"), - Wide_Maps.Identity) /= 2 or - ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("aaaaaaaaaa")), - Equiv("aaa")) /= 3 or - ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("XX")), -- Src < Pat - Equiv("XXX"), - Wide_Maps.Identity) /= 0 or - ASW.Count(AtoE_Str, -- Source = Pattern - Equiv("abcde")) /= 1 or - ASW.Count(ASW.Null_Unbounded_Wide_String, -- Source = Null - Equiv(" ")) /= 0 - then - Report.Failed - ("Incorrect result from function Count, w,w/o mapping"); - end if; - - - - -- Function Count using access-to-subprogram mapping. - -- Evaluate the function Count with an access value specifying the - -- mapping that is going to occur to Source. - - Map_Ptr := AB_to_US_Mapping_Function'Access; - - Total_Count := - ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("abcbacbadbaAbbB")), - Pattern => Equiv("__"), - Mapping => Map_Ptr); -- change 'a' and 'b' to '_' - - if Total_Count /= 5 then - Report.Failed - ("Incorrect result from function Count, access value map - 1"); - end if; - - Map_Ptr := AB_to_Blank_Mapping_Function'Access; - - if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("cccaccBcbcaccacAc")), - Equiv("c c"), - Map_Ptr) /= 3 or - ASW.Count(ASW.To_Unbounded_Wide_String - (Equiv("aBBAAABaBBBBAaBABBABaBBbBB")), - Equiv(" BB"), - Map_Ptr) /= 4 or - ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("aaaaaaaaaa")), - Equiv(" "), - Map_Ptr) /= 3 or - ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("XX")), -- Src < Pat - Equiv("XX "), - Map_Ptr) /= 0 or - ASW.Count(AtoE_Str, -- Source'Length = Pattern'Length - Equiv(" cde"), - Map_Ptr) /= 1 - then - Report.Failed - ("Incorrect result from function Count, access value map - 3"); - end if; - - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4022; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a deleted file mode 100644 index d0325fc88ec..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a +++ /dev/null @@ -1,585 +0,0 @@ --- CXA4023.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 subprograms defined in package --- Ada.Strings.Wide_Unbounded are available, and that they produce --- correct results. Specifically, check the subprograms Delete, --- Find_Token, Translate, Trim, and "*". --- --- TEST DESCRIPTION: --- This test demonstrates the uses of many of the subprograms defined --- in package Ada.Strings.Wide_Unbounded for use with unbounded wide --- strings. The test simulates how unbounded wide strings --- will be processed in a user environment, using the subprograms --- provided in this package. --- --- This test, when taken in conjunction with tests CXA4021-22, will --- constitute a test of the functionality contained in package --- Ada.Strings.Wide_Unbounded. This test uses a variety --- of the subprograms defined in the unbounded wide string package --- in ways typical of common usage, with different combinations of --- available subprograms being used to accomplish similar --- unbounded wide string processing goals. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 08 Nov 95 SAIC Corrected accessibility level and type --- visibility problems for ACVC 2.0.1. --- ---! - -with Ada.Characters.Handling; -with Ada.Strings; - -package CXA40230 is - - -- The following two functions are used to translate character and string - -- values to non-character "Wide" values. They will be applied to all the - -- Wide_Bounded subprogram character and string parameters to simulate the - -- use of Wide_Characters and Wide_Strings in actual practice. - -- Note: These functions do not actually return "equivalent" wide - -- characters to their character inputs, just "non-character" - -- wide characters. - - function Equiv (Ch : Character) return Wide_Character; - - function Equiv (Str : String) return Wide_String; - - -- Functions and access-to-subprogram object used to supply mapping - -- capability to the appropriate versions of Translate. - - function AB_to_US_Mapping_Function (From : Wide_Character) - return Wide_Character; - - function AB_to_Blank_Mapping_Function (From : Wide_Character) - return Wide_Character; - -end CXA40230; - - -package body CXA40230 is - - function Equiv (Ch : Character) return Wide_Character is - C : Character := Ch; - begin - if Ch = ' ' then - return Ada.Characters.Handling.To_Wide_Character(C); - else - return Wide_Character'Val(Character'Pos(Ch) + - Character'Pos(Character'Last) + 1); - end if; - end Equiv; - - - function Equiv (Str : String) return Wide_String is - WS : Wide_String(Str'First..Str'Last); - begin - for i in Str'First..Str'Last loop - WS(i) := Equiv(Str(i)); - end loop; - return WS; - end Equiv; - - - function AB_to_US_Mapping_Function (From : Wide_Character) - return Wide_Character is - UnderScore : constant Wide_Character := Equiv('_'); - begin - if From = Equiv('a') or From = Equiv('b') then - return UnderScore; - else - return From; - end if; - end AB_to_US_Mapping_Function; - - - function AB_to_Blank_Mapping_Function (From : Wide_Character) - return Wide_Character is - begin - if From = Equiv('a') or From = Equiv('b') then - return Ada.Strings.Wide_Space; - else - return From; - end if; - end AB_to_Blank_Mapping_Function; - -end CXA40230; - - -with CXA40230; -with Report; -with Ada.Characters.Handling; -with Ada.Strings.Wide_Maps; -with Ada.Strings.Wide_Unbounded; - -procedure CXA4023 is -begin - - Report.Test ("CXA4023", "Check that the subprograms defined in " & - "package Ada.Strings.Wide_Unbounded are " & - "available, and that they produce correct " & - "results"); - - Test_Block: - declare - - use CXA40230; - - package ASW renames Ada.Strings.Wide_Unbounded; - use Ada.Strings; - use type Wide_Maps.Wide_Character_Set; - use type ASW.Unbounded_Wide_String; - - Test_String : ASW.Unbounded_Wide_String; - AtoE_Str : ASW.Unbounded_Wide_String := - ASW.To_Unbounded_Wide_String(Equiv("abcde")); - - Cad_String : ASW.Unbounded_Wide_String := - ASW.To_Unbounded_Wide_String(Equiv("cad")); - - Magic_String : ASW.Unbounded_Wide_String := - ASW.To_Unbounded_Wide_String(Equiv("abracadabra")); - - Incantation : ASW.Unbounded_Wide_String := Magic_String; - - - A_Small_G : Wide_Character := Equiv('g'); - - ABCD_Set : Wide_Maps.Wide_Character_Set := - Wide_Maps.To_Set(Equiv("abcd")); - B_Set : Wide_Maps.Wide_Character_Set := - Wide_Maps.To_Set(Equiv('b')); - AB_Set : Wide_Maps.Wide_Character_Set := - Wide_Maps."OR"(Wide_Maps.To_Set(Equiv('a')), B_Set); - - - AB_to_YZ_Map : Wide_Maps.Wide_Character_Mapping := - Wide_Maps.To_Mapping(From => Equiv("ab"), - To => Equiv("yz")); - Code_Map : Wide_Maps.Wide_Character_Mapping := - Wide_Maps.To_Mapping(Equiv("abcd"), Equiv("wxyz")); - Reverse_Code_Map : Wide_Maps.Wide_Character_Mapping := - Wide_Maps.To_Mapping(Equiv("wxyz"), Equiv("abcd")); - Non_Existent_Map : Wide_Maps.Wide_Character_Mapping := - Wide_Maps.To_Mapping(Equiv("jkl"), Equiv("mno")); - - - Token_Start : Positive; - Token_End : Natural := 0; - - Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function := - AB_to_US_Mapping_Function'Access; - - - begin - - -- Find_Token - - ASW.Find_Token(Magic_String, -- Find location of first "ab" equiv. - AB_Set, -- Should be (1..2). - Ada.Strings.Inside, - Token_Start, - Token_End); - - if Natural(Token_Start) /= ASW.To_Wide_String(Magic_String)'First or - Token_End /= ASW.Index(Magic_String, B_Set) or - Token_End /= 2 - then - Report.Failed("Incorrect result from Procedure Find_Token - 1"); - end if; - - - ASW.Find_Token(Source => Magic_String, -- Find location of char 'r'equiv - Set => ABCD_Set, -- in wide str, should be (3..3) - Test => Ada.Strings.Outside, - First => Token_Start, - Last => Token_End); - - if Natural(Token_Start) /= 3 or Token_End /= 3 then - Report.Failed("Incorrect result from Procedure Find_Token - 2"); - end if; - - - ASW.Find_Token(Magic_String, -- No 'g' "equivalent in - Wide_Maps.To_Set(A_Small_G), -- the wide str, so the - Ada.Strings.Inside, -- result params should be - First => Token_Start, -- First = Source'First and - Last => Token_End); -- Last = 0. - - - if Token_Start /= ASW.To_Wide_String(Magic_String)'First or - Token_End /= 0 - then - Report.Failed("Incorrect result from Procedure Find_Token - 3"); - end if; - - - ASW.Find_Token(ASW.To_Unbounded_Wide_String(Equiv("abpqpqrttrcpqr")), - Wide_Maps.To_Set(Equiv("trpq")), - Ada.Strings.Inside, - Token_Start, - Token_End); - - if Token_Start /= 3 or - Token_End /= 10 - then - Report.Failed("Incorrect result from Procedure Find_Token - 4"); - end if; - - ASW.Find_Token(ASW.To_Unbounded_Wide_String(Equiv("abpqpqrttrcpqr")), - Wide_Maps.To_Set(Equiv("abpq")), - Ada.Strings.Outside, - Token_Start, - Token_End); - - if Token_Start /= 7 or - Token_End /= 11 - then - Report.Failed("Incorrect result from Procedure Find_Token - 5"); - end if; - - - - -- Translate - - -- Use a mapping ("abcd" -> "wxyz") to transform the contents of - -- the unbounded wide string. - -- Magic_String = "abracadabra" - - Incantation := ASW.Translate(Magic_String, Code_Map); - - if Incantation /= - ASW.To_Unbounded_Wide_String(Equiv("wxrwywzwxrw")) - then - Report.Failed("Incorrect result from Function Translate - 1"); - end if; - - -- (Note: See below for additional testing of Function Translate) - - -- Use the inverse mapping of the one above to return the "translated" - -- unbounded wide string to its original form. - - ASW.Translate(Incantation, Reverse_Code_Map); - - -- The map contained in the following call to Translate contains three - -- elements, and these elements are not found in the unbounded wide - -- string, so this call to Translate should have no effect on it. - - if Incantation /= ASW.Translate(Magic_String, Non_Existent_Map) then - Report.Failed("Incorrect result from Procedure Translate - 1"); - end if; - - -- Partial mapping of source. - - Test_String := ASW.To_Unbounded_Wide_String(Equiv("abcdeabcab")); - - ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); - - if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("yzcdeyzcyz")) then - Report.Failed("Incorrect result from Procedure Translate - 2"); - end if; - - -- Total mapping of source. - - Test_String := ASW.To_Unbounded_Wide_String(Equiv("abbaaababb")); - - ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); - - if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("yzzyyyzyzz")) then - Report.Failed("Incorrect result from Procedure Translate - 3"); - end if; - - -- No mapping of source. - - Test_String := ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")); - - ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); - - if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")) then - Report.Failed("Incorrect result from Procedure Translate - 4"); - end if; - - -- Map > 2 characters, partial mapping. - - Test_String := ASW.To_Unbounded_Wide_String(Equiv("opabcdelmn")); - - ASW.Translate(Test_String, - Wide_Maps.To_Mapping(Equiv("abcde"), Equiv("lmnop"))); - - if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("oplmnoplmn")) then - Report.Failed("Incorrect result from Procedure Translate - 5"); - end if; - - - - -- Various degrees of mapping of source (full, partial, none) used - -- with Function Translate. - - if ASW.Translate( - ASW.To_Unbounded_Wide_String(Equiv("abcdeabcabbbaaacaa")), - AB_to_YZ_Map) /= - ASW.To_Unbounded_Wide_String(Equiv("yzcdeyzcyzzzyyycyy")) or - - ASW.Translate( - ASW.To_Unbounded_Wide_String(Equiv("abbaaababbaaaaba")), - AB_to_YZ_Map) /= - ASW.To_Unbounded_Wide_String(Equiv("yzzyyyzyzzyyyyzy")) or - - ASW.Translate(ASW.To_Unbounded_Wide_String(Equiv("cABcABBAc")), - Mapping => AB_to_YZ_Map) /= - ASW.To_Unbounded_Wide_String(Equiv("cABcABBAc")) or - - ASW.Translate(ASW.To_Unbounded_Wide_String("opabcdelmnddeaccabec"), - Wide_Maps.To_Mapping("abcde", "lmnop")) /= - ASW.To_Unbounded_Wide_String("oplmnoplmnooplnnlmpn") - then - Report.Failed("Incorrect result from Function Translate - 2"); - end if; - - - - -- Procedure Translate using access-to-subprogram mapping. - -- Partial mapping of source. - - Map_Ptr := AB_to_Blank_Mapping_Function'Access; - - Test_String := ASW.To_Unbounded_Wide_String(Equiv("abABaABbaBAbba")); - - ASW.Translate(Source => Test_String, -- change equivalent of 'a' and - Mapping => Map_Ptr); -- 'b' to ' ' - - if Test_String /= - ASW.To_Unbounded_Wide_String(Equiv(" AB AB BA ")) - then - Report.Failed - ("Incorrect result from Proc Translate, w/ access value map - 1"); - end if; - - -- Total mapping of source to blanks. - - Test_String := ASW.To_Unbounded_Wide_String(Equiv("abbbab")); - - ASW.Translate(Source => Test_String, - Mapping => Map_Ptr); - - if Test_String /= - ASW.To_Unbounded_Wide_String(Equiv(" ")) - then - Report.Failed - ("Incorrect result from Proc Translate, w/ access value map - 2"); - end if; - - -- No mapping of source. - - Map_Ptr := AB_to_US_Mapping_Function'Access; - - Test_String := ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")); - - ASW.Translate(Source => Test_String, - Mapping => Map_Ptr); - - if Test_String /= - ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")) -- no change - then - Report.Failed - ("Incorrect result from Proc Translate, w/ access value map - 3"); - end if; - - - -- Function Translate using access-to-subprogram mapping value. - - Map_Ptr := AB_to_Blank_Mapping_Function'Access; - - Test_String := ASW.To_Unbounded_Wide_String(Equiv("abAbBBAabbacD")); - - if ASW.Translate(ASW.Translate(Test_String, Map_Ptr), Map_Ptr) /= - ASW.To_Unbounded_Wide_String(Equiv(" A BBA cD")) - then - Report.Failed - ("Incorrect result from Function Translate, access value map - 1"); - end if; - - if ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("a")), - Mapping => Map_Ptr) /= - ASW.To_Unbounded_Wide_String(Equiv(" ")) or - ASW.Translate(ASW.To_Unbounded_Wide_String - (Equiv(" aa Aa A AAaaa a aA")), - Map_Ptr) /= - ASW.To_Unbounded_Wide_String(Equiv(" A A AA A")) or - ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("a ")), - Mapping => Map_Ptr) /= - ASW.To_Unbounded_Wide_String(Equiv(" ")) or - ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("xyz")), - Mapping => Map_Ptr) /= - ASW.To_Unbounded_Wide_String(Equiv("xyz")) - then - Report.Failed - ("Incorrect result from Function Translate, access value map - 2"); - end if; - - - - -- Trim - - Trim_Block: - declare - - XYZ_Set : Wide_Maps.Wide_Character_Set := - Wide_Maps.To_Set(Equiv("xyz")); - PQR_Set : Wide_Maps.Wide_Character_Set := - Wide_Maps.To_Set(Equiv("pqr")); - - Pad : constant ASW.Unbounded_Wide_String := - ASW.To_Unbounded_Wide_String(Equiv("Pad")); - - The_New_Ada : constant ASW.Unbounded_Wide_String := - ASW.To_Unbounded_Wide_String(Equiv("Ada9X")); - - Space_Array : array (1..4) of ASW.Unbounded_Wide_String := - (ASW.To_Unbounded_Wide_String(Equiv(" Pad ")), - ASW.To_Unbounded_Wide_String(Equiv("Pad ")), - ASW.To_Unbounded_Wide_String(Equiv(" Pad")), - Pad); - - String_Array : array (1..5) of ASW.Unbounded_Wide_String := - (ASW.To_Unbounded_Wide_String(Equiv("xyzxAda9Xpqr")), - ASW.To_Unbounded_Wide_String(Equiv("Ada9Xqqrp")), - ASW.To_Unbounded_Wide_String(Equiv("zxyxAda9Xqpqr")), - ASW.To_Unbounded_Wide_String(Equiv("xxxyAda9X")), - The_New_Ada); - - begin - - -- Examine the version of Trim that removes blanks from - -- the left and/or right of a wide string. - - for i in 1..4 loop - if ASW.Trim(Space_Array(i), Ada.Strings.Both) /= Pad then - Report.Failed("Incorrect result from Trim for spaces - " & - Integer'Image(i)); - end if; - end loop; - - -- Examine the version of Trim that removes set characters from - -- the left and right of a wide string. - - for i in 1..5 loop - if ASW.Trim(String_Array(i), - Left => XYZ_Set, - Right => PQR_Set) /= The_New_Ada then - Report.Failed - ("Incorrect result from Trim for set characters - " & - Integer'Image(i)); - end if; - end loop; - - -- No trimming. - - if ASW.Trim( - ASW.To_Unbounded_Wide_String(Equiv("prqqprAda9Xyzzxyzzyz")), - XYZ_Set, - PQR_Set) /= - ASW.To_Unbounded_Wide_String(Equiv("prqqprAda9Xyzzxyzzyz")) - then - Report.Failed - ("Incorrect result from Trim for set, no trimming"); - end if; - - end Trim_Block; - - - - -- Delete - - -- Use the Delete function to remove the first four and last four - -- characters from the wide string. - - if ASW.Delete(Source => ASW.Delete(Magic_String, - 8, - ASW.Length(Magic_String)), - From => ASW.To_Wide_String(Magic_String)'First, - Through => 4) /= - Cad_String - then - Report.Failed("Incorrect results from Function Delete"); - end if; - - - - -- Constructors ("*") - - Constructor_Block: - declare - - SOS : ASW.Unbounded_Wide_String; - - Dot : constant ASW.Unbounded_Wide_String := - ASW.To_Unbounded_Wide_String(Equiv("Dot_")); - Dash : constant Wide_String := Equiv("Dash_"); - - Distress : ASW.Unbounded_Wide_String := - ASW."&"(ASW.To_Unbounded_Wide_String - (Equiv("Dot_Dot_Dot_")), - ASW."&"(ASW.To_Unbounded_Wide_String - (Equiv("Dash_Dash_Dash_")), - ASW.To_Unbounded_Wide_String - (Equiv("Dot_Dot_Dot")))); - - Repeat : constant Natural := 3; - Separator : constant Wide_Character := Equiv('_'); - - Separator_Set : Wide_Maps.Wide_Character_Set := - Wide_Maps.To_Set(Separator); - - begin - - -- Use the following constructor forms to construct the wide string - -- "Dot_Dot_Dot_Dash_Dash_Dash_Dot_Dot_Dot". Note that the - -- trailing underscore in the wide string is removed in the call to - -- Trim in the If statement condition. - - SOS := ASW."*"(Repeat, Dot); -- "*"(#, W Unb Str) - - SOS := ASW."&"(SOS, - ASW."&"(ASW."*"(Repeat, Dash), -- "*"(#, W Str) - ASW."*"(Repeat, Dot))); -- "*"(#, W Unb Str) - - if ASW.Trim(SOS, Wide_Maps.Null_Set, Separator_Set) /= Distress then - Report.Failed("Incorrect results from Function ""*"""); - end if; - - end Constructor_Block; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4023; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a deleted file mode 100644 index 1b0af9ce978..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a +++ /dev/null @@ -1,350 +0,0 @@ --- CXA4024.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 function "-", To_Ranges, To_Domain, and To_Range are --- available in the package Ada.Strings.Maps, and that they produce --- correct results based on the Character_Set/Character_Mapping input --- provided. --- --- TEST DESCRIPTION: --- This test examines the operation of four functions from within the --- Ada.Strings.Maps package. A variety of Character_Sequence, --- Character_Set, and Character_Mapping objects are created and --- initialized for use with these functions. In each subtest of --- function operation, specific inputs are provided to the functions as --- input parameters, and the results are evaluated against expected --- values. Wherever appropriate, additional characteristics of the --- function results are verified against the prescribed result --- characteristics. --- --- --- CHANGE HISTORY: --- 03 Feb 95 SAIC Initial prerelease version --- 10 Mar 95 SAIC Incorporated reviewer comments. --- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- 05 Oct 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- ---! - -with Ada.Strings.Maps; -with Ada.Strings.Maps.Constants; -with Ada.Characters.Latin_1; -with Report; - -procedure CXA4024 is - -begin - - Report.Test ("CXA4024", "Check that the function ""-"", To_Ranges, " & - "To_Domain, and To_Range are available in " & - "the package Ada.Strings.Maps, and that " & - "they produce correct results"); - - Test_Block: - declare - - use Ada.Strings, Ada.Strings.Maps; - use type Maps.Character_Set; -- To allow logical set operator - -- infix notation. - package ACL1 renames Ada.Characters.Latin_1; - - MidPoint_Letter : constant := 13; - Last_Letter : constant := 26; - - Vowels : constant Maps.Character_Sequence := "aeiou"; - Quasi_Vowel : constant Character := 'y'; - - Alphabet : Maps.Character_Sequence (1..Last_Letter); - Half_Alphabet : Maps.Character_Sequence (1..MidPoint_Letter); - - Alphabet_Set, - Consonant_Set, - Vowel_Set, - First_Half_Set, - Second_Half_Set : Maps.Character_Set; - - - begin - - -- Load the alphabet strings for use in creating sets. - for i in 0..12 loop - Half_Alphabet(i+1) := Character'Val(Character'Pos('a') + i); - end loop; - - for i in 0..25 loop - Alphabet(i+1) := Character'Val(Character'Pos('a') + i); - end loop; - - -- Initialize a series of Character_Set objects. - - Alphabet_Set := Maps.To_Set(Alphabet); - Vowel_Set := Maps.To_Set(Vowels); - Consonant_Set := Vowel_Set XOR Alphabet_Set; - First_Half_Set := Maps.To_Set(Half_Alphabet); - Second_Half_Set := Alphabet_Set XOR First_Half_Set; - - - - -- Evaluation of Set operator "-". - - if Consonant_Set /= "-"(Alphabet_Set, Vowel_Set) or - Vowel_Set /= (Alphabet_Set - Consonant_Set) or - Alphabet_Set /= Alphabet_Set - Maps.Null_Set or - First_Half_Set /= "-"(Alphabet_Set, Second_Half_Set) or - (Alphabet_Set - Vowel_Set) /= "AND"(Alphabet_Set, "NOT"(Vowel_Set)) - then - Report.Failed("Incorrect result from ""-"" operator for sets"); - end if; - - - - -- Evaluation of Function "To_Ranges". - - declare - - use type Maps.Character_Range; - use type Maps.Character_Ranges; - - Set_A_to_C : Maps.Character_Set := Maps.To_Set("ABC"); - Set_J : Maps.Character_Set := Maps.To_Set("J"); - Set_M_to_P : Maps.Character_Set := Maps.To_Set("MNOP"); - Set_X_to_Z : Maps.Character_Set := Maps.To_Set("XYZ"); - Set_Of_Five : Maps.Character_Set := Set_A_to_C OR -- Union of the - Set_M_to_P OR -- five sets. - Set_X_to_Z OR - Set_J OR - Maps.Null_Set; - - TC_Range_A_to_C : Maps.Character_Range := (Low => 'A', High => 'C'); - TC_Range_J : Maps.Character_Range := ('J', 'J'); - TC_Range_M_to_P : Maps.Character_Range := ('M', 'P'); - TC_Range_X_to_Z : Maps.Character_Range := (Low => 'X', High => 'Z'); - - TC_Ranges : Maps.Character_Ranges (1..4) := - (1 => TC_Range_A_to_C, - 2 => TC_Range_J, - 3 => TC_Range_M_to_P, - 4 => TC_Range_X_to_Z); - - begin - - -- Based on input of a set containing four separate "spans" of - -- character sequences, Function To_Ranges is required to produce - -- the shortest array of contiguous ranges of Character values in - -- the input set, in increasing order of Low. - - declare - - -- This Character_Ranges constant should consist of array - -- components, each component being a Character_Range from Low - -- to High containing the appropriate characters. - - Ranges_Result : constant Maps.Character_Ranges := - Maps.To_Ranges(Set => Set_Of_Five); - begin - - -- Check the structure and components of the Character_Ranges - -- constant. - - if Ranges_Result(1) /= TC_Range_A_to_C or - Ranges_Result(1).Low /= TC_Ranges(1).Low or - Ranges_Result(2) /= TC_Range_J or - Ranges_Result(2).High /= TC_Ranges(2).High or - Ranges_Result(3) /= TC_Range_M_to_P or - Ranges_Result(3).Low /= TC_Ranges(3).Low or - Ranges_Result(3).High /= TC_Ranges(3).High or - Ranges_Result(4) /= TC_Range_X_To_Z or - Ranges_Result(4).Low /= TC_Ranges(4).Low or - Ranges_Result(4).High /= TC_Ranges(4).High - then - Report.Failed ("Incorrect structure or components in " & - "Character_Ranges constant"); - end if; - - exception - when others => - Report.Failed("Exception raised using the Function To_Ranges " & - "to initialize a Character_Ranges constant"); - end; - end; - - - - -- Evaluation of Functions To_Domain and To_Range. - - declare - - Null_Sequence : constant Maps.Character_Sequence := ""; - - TC_Upper_Case_Sequence : constant Maps.Character_Sequence := - "ZYXWVUTSRQPONMABCDEFGHIJKL"; - TC_Lower_Case_Sequence : constant Maps.Character_Sequence := - "zyxwvutsrqponmabcdefghijkl"; - TC_Unordered_Sequence : Maps.Character_Sequence(1..6) := - "BxACzy"; - - TC_Upper_to_Lower_Map : Maps.Character_Mapping := - Maps.To_Mapping(TC_Upper_Case_Sequence, - TC_Lower_Case_Sequence); - - TC_Lower_to_Upper_Map : Maps.Character_Mapping := - Maps.To_Mapping(TC_Lower_Case_Sequence, - TC_Upper_Case_Sequence); - - TC_Unordered_Map : Maps.Character_Mapping := - Maps.To_Mapping(TC_Unordered_Sequence, - "ikglja"); - begin - - declare - - TC_Domain_1 : constant Maps.Character_Sequence := - Maps.To_Domain(TC_Upper_to_Lower_Map); - - TC_Domain_2 : constant Maps.Character_Sequence := - Maps.To_Domain(TC_Lower_to_Upper_Map); - - TC_Domain_3 : Maps.Character_Sequence(1..6); - - TC_Range_1 : constant Maps.Character_Sequence := - Maps.To_Range(TC_Upper_to_Lower_Map); - - TC_Range_2 : constant Maps.Character_Sequence := - Maps.To_Range(TC_Lower_to_Upper_Map); - - TC_Range_3 : Maps.Character_Sequence(1..6); - - begin - - -- Function To_Domain returns the shortest Character_Sequence - -- value such that each character not in the result maps to - -- itself, and all characters in the result are in ascending - -- order. - - TC_Domain_3 := Maps.To_Domain(TC_Unordered_Map); - - -- Check contents of result of To_Domain, must be in ascending - -- order. - - if TC_Domain_1 /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then - Report.Failed("Incorrect result from To_Domain with " & - "TC_Upper_to_Lower_Map as input"); - end if; - - if TC_Domain_2 /= "abcdefghijklmnopqrstuvwxyz" then - Report.Failed("Incorrect result from To_Domain with " & - "TC_Lower_to_Upper_Map as input"); - end if; - - if TC_Domain_3 /= "ABCxyz" then - Report.Failed("Incorrect result from To_Domain with " & - "an unordered mapping as input"); - end if; - - - -- The lower bound on the returned Character_Sequence value - -- from To_Domain must be 1. - - if TC_Domain_1'First /= 1 or - TC_Domain_2'First /= 1 or - TC_Domain_3'First /= 1 - then - Report.Failed("Incorrect lower bound returned from To_Domain"); - end if; - - - -- Check contents of result of To_Range. - - TC_Range_3 := Maps.To_Range(TC_Unordered_Map); - - if TC_Range_1 /= "abcdefghijklmnopqrstuvwxyz" then - Report.Failed("Incorrect result from To_Range with " & - "TC_Upper_to_Lower_Map as input"); - end if; - - if TC_Range_2 /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then - Report.Failed("Incorrect result from To_Range with " & - "TC_Lower_to_Upper_Map as input"); - end if; - - if TC_Range_3 /= "gilkaj" then - Report.Failed("Incorrect result from To_Range with " & - "an unordered mapping as input"); - end if; - - - -- The lower bound on the returned Character_Sequence value - -- must be 1. - - if TC_Range_1'First /= 1 or - TC_Range_2'First /= 1 or - TC_Range_3'First /= 1 - then - Report.Failed("Incorrect lower bound returned from To_Range"); - end if; - - - -- The upper bound on the returned Character_Sequence value - -- must be Map'Length. - - if TC_Range_1'Last /= TC_Lower_Case_Sequence'Length or - TC_Range_2'Last /= TC_Upper_Case_Sequence'Length or - TC_Range_3'Last /= TC_Unordered_Sequence'Length - then - Report.Failed("Incorrect upper bound returned from To_Range"); - end if; - - end; - - -- Both function To_Domain and To_Range return the null string - -- when provided the Identity character map as an input parameter. - - if Maps.To_Domain(Maps.Identity) /= Null_Sequence then - Report.Failed("Function To_Domain did not return the null " & - "string when provided the Identity map as " & - "input"); - end if; - - if Maps.To_Range(Maps.Identity) /= Null_Sequence then - Report.Failed("Function To_Range did not return the null " & - "string when provided the Identity map as " & - "input"); - end if; - - exception - when others => - Report.Failed("Exception raised during the evaluation of " & - "Function To_Domain and To_Range"); - end; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4024; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a deleted file mode 100644 index 1665f7a46e8..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a +++ /dev/null @@ -1,376 +0,0 @@ --- CXA4025.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 functionality found in packages Ada.Strings.Wide_Maps, --- Ada.Strings.Wide_Fixed, and Ada.Strings.Wide_Maps.Wide_Constants --- is available and produces correct results. --- --- TEST DESCRIPTION: --- This test validates the subprograms found in the various Wide_Map --- and Wide_String packages. It is based on the tests CXA4024 and --- CXA4026, which are tests for the complementary "non-wide" packages. --- --- The functions found in CXA4025_0 provide mapping capability, when --- used in conjunction with Wide_Character_Mapping_Function objects. --- --- --- CHANGE HISTORY: --- 23 Jun 95 SAIC Initial prerelease version. --- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- ---! - -package CXA4025_0 is - -- Functions used to supply mapping capability. - function Map_To_Lower_Case (From : Wide_Character) return Wide_Character; - function Map_To_Upper_Case (From : Wide_Character) return Wide_Character; -end CXA4025_0; - -with Ada.Characters.Handling; -package body CXA4025_0 is - -- Function Map_To_Lower_Case will return the lower case form of - -- Wide_Characters in the range 'A'..'Z' only, and return the input - -- wide_character otherwise. - - function Map_To_Lower_Case (From : Wide_Character) - return Wide_Character is - begin - return Ada.Characters.Handling.To_Wide_Character( - Ada.Characters.Handling.To_Lower( - Ada.Characters.Handling.To_Character(From))); - end Map_To_Lower_Case; - - -- Function Map_To_Upper_Case will return the upper case form of - -- Wide_Characters in the range 'a'..'z', or whose position is in one - -- of the ranges 223..246 or 248..255, provided the wide_character has - -- an upper case form. - - function Map_To_Upper_Case (From : Wide_Character) - return Wide_Character is - begin - return Ada.Characters.Handling.To_Wide_Character( - Ada.Characters.Handling.To_Upper( - Ada.Characters.Handling.To_Character(From))); - end Map_To_Upper_Case; - -end CXA4025_0; - - -with CXA4025_0; -with Report; -with Ada.Characters.Handling; -with Ada.Characters.Latin_1; -with Ada.Exceptions; -with Ada.Strings; -with Ada.Strings.Wide_Maps; -with Ada.Strings.Wide_Maps.Wide_Constants; -with Ada.Strings.Wide_Fixed; - -procedure CXA4025 is -begin - Report.Test ("CXA4025", - "Check that subprograms defined in packages " & - "Ada.Strings.Wide_Maps and Ada.Strings.Wide_Fixed " & - "produce correct results"); - - Test_Block: - declare - - package ACL1 renames Ada.Characters.Latin_1; - - use Ada.Characters, Ada.Strings; - use Ada.Exceptions; - use type Wide_Maps.Wide_Character_Set; - - subtype LC_Characters is Wide_Character range 'a'..'z'; - - Last_Letter : constant := 26; - Vowels : constant Wide_Maps.Wide_Character_Sequence := "aeiou"; - TC_String : constant Wide_String := "A Standard String"; - - Alphabet : Wide_Maps.Wide_Character_Sequence (1..Last_Letter); - Alphabet_Set, - Consonant_Set, - Vowel_Set : Wide_Maps.Wide_Character_Set; - - String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST"; - String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" & - String_20; - String_80 : Wide_String(1..80) := String_40 & String_40; - TC_String_5 : Wide_String(1..5) := "ABCDE"; - - -- The following strings are used in examination of the Translation - -- subprograms. - New_Character_String : Wide_String(1..12) := - Handling.To_Wide_String( - ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong & - ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex & - ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde & - ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn & - ACL1.LC_German_Sharp_S & ACL1.LC_Y_Diaeresis); - - -- Note that there is no upper case version of the last two - -- characters from above. - - TC_New_Character_String : Wide_String(1..12) := - Handling.To_Wide_String( - ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong & - ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex & - ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde & - ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn & - ACL1.LC_German_Sharp_S & ACL1.LC_Y_Diaeresis); - - -- Access objects that will be provided as parameters to the - -- subprograms. - Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := - CXA4025_0.Map_To_Lower_Case'Access; - Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := - CXA4025_0.Map_To_Upper_Case'Access; - - begin - - -- - -- Testing of functionality found in Package Ada.Strings.Wide_Maps. - -- - - -- Load the alphabet strings for use in creating sets. - for i in 0..25 loop - Alphabet(i+1) := Wide_Character'Val(Wide_Character'Pos('a')+i); - end loop; - - -- Initialize a series of Character_Set objects. - Alphabet_Set := Wide_Maps.To_Set(Alphabet); - Vowel_Set := Wide_Maps.To_Set(Vowels); - Consonant_Set := Vowel_Set XOR Alphabet_Set; - - -- Evaluation of Set operator "-". - if - (Alphabet_Set - Consonant_Set) /= - "AND"(Alphabet_Set, "NOT"(Consonant_Set)) or - (Alphabet_Set - Vowel_Set) /= "AND"(Alphabet_Set, "NOT"(Vowel_Set)) - then - Report.Failed("Incorrect result from ""-"" operator for sets"); - end if; - - -- Evaluation of Functions To_Domain and To_Range. - declare - Null_Sequence : constant Wide_Maps.Wide_Character_Sequence := ""; - TC_UC_Sequence : constant Wide_Maps.Wide_Character_Sequence := - "ZYXWVUTSRQPONMABCDEFGHIJKL"; - TC_LC_Sequence : constant Wide_Maps.Wide_Character_Sequence := - "zyxwvutsrqponmabcdefghijkl"; - TC_Upper_to_Lower_Map : Wide_Maps.Wide_Character_Mapping := - Wide_Maps.To_Mapping(TC_UC_Sequence, - TC_LC_Sequence); - TC_Lower_to_Upper_Map : Wide_Maps.Wide_Character_Mapping := - Wide_Maps.To_Mapping(TC_LC_Sequence, - TC_UC_Sequence); - begin - declare - TC_Domain : constant Wide_Maps.Wide_Character_Sequence := - Wide_Maps.To_Domain(TC_Upper_to_Lower_Map); - TC_Range : constant Wide_Maps.Wide_Character_Sequence := - Wide_Maps.To_Range(TC_Lower_to_Upper_Map); - begin - -- Function To_Domain returns the shortest Wide_Character_Sequence - -- value such that each wide character not in the result maps to - -- itself, and all wide characters in the result are in ascending - -- order. - if TC_Domain /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then - Report.Failed("Incorrect result from To_Domain with " & - "TC_Upper_to_Lower_Map as input"); - end if; - - -- The lower bound on the returned Wide_Character_Sequence value - -- from To_Domain must be 1. - if TC_Domain'First /= 1 then - Report.Failed("Incorrect lower bound returned from To_Domain"); - end if; - - -- Check contents of result of To_Range. - if TC_Range /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then - Report.Failed("Incorrect result from To_Range with " & - "TC_Lower_to_Upper_Map as input"); - end if; - - -- The lower bound on the returned Character_Sequence value - -- must be 1. - if TC_Range'First /= 1 then - Report.Failed("Incorrect lower bound returned from To_Range"); - end if; - - if TC_Range'Last /= TC_LC_Sequence'Length then - Report.Failed("Incorrect upper bound returned from To_Range"); - end if; - end; - - -- Both function To_Domain and To_Range return the null string - -- when provided the Identity character map as an input parameter. - if Wide_Maps.To_Domain(Wide_Maps.Identity) /= Null_Sequence or - Wide_Maps.To_Range(Wide_Maps.Identity) /= Null_Sequence - then - Report.Failed("Null sequence not returned from To_Domain or " & - "To_Range when provided the Identity map as input"); - end if; - exception - when others => - Report.Failed("Exception raised during the evaluation of " & - "Function To_Domain and To_Range"); - end; - - -- Testing of functionality found in Package Ada.Strings.Wide_Fixed. - -- - -- Function Index, Forward direction search. - - if Wide_Fixed.Index("CoMpLeTeLy MiXeD CaSe StRiNg", - "MIXED CASE STRING", - Ada.Strings.Forward, - Map_To_Upper_Case_Ptr) /= 12 or - Wide_Fixed.Index("STRING WITH NO MATCHING PATTERNS", - "WITH", - Ada.Strings.Forward, - Map_To_Lower_Case_Ptr) /= 0 - then - Report.Failed("Incorrect results from Function Index, going " & - "in Forward direction, using a Character Mapping " & - "Function parameter"); - end if; - - -- Function Index, Backward direction search. - if Wide_Fixed.Index("Case of a Mixed Case String", - "case", - Ada.Strings.Backward, - Map_To_Lower_Case_Ptr) /= 17 or - Wide_Fixed.Index("WOULD MATCH BUT FOR THE CASE", - "WOULD MATCH BUT FOR THE CASE", - Ada.Strings.Backward, - Map_To_Lower_Case_Ptr) /= 0 - then - Report.Failed("Incorrect results from Function Index, going " & - "in Backward direction, using a Character Mapping " & - "Function parameter"); - end if; - - -- Function Count. - if Wide_Fixed.Count("ABABABA", "ABA", Map_To_Upper_Case_Ptr) /= 2 or - Wide_Fixed.Count("", "match", Map_To_Lower_Case_Ptr) /= 0 - then - Report.Failed("Incorrect results from Function Count, using " & - "a Character Mapping Function parameter"); - end if; - - -- Function Translate. - if Wide_Fixed.Translate(Source => "A Sample Mixed Case String", - Mapping => Map_To_Lower_Case_Ptr) /= - "a sample mixed case string" or - Wide_Fixed.Translate(New_Character_String, - Map_To_Upper_Case_Ptr) /= - TC_New_Character_String - then - Report.Failed("Incorrect results from Function Translate, using " & - "a Wide_Character Mapping Function parameter"); - end if; - - -- Procedure Translate. - declare - use Ada.Strings.Wide_Fixed; - Str : Wide_String(1..19) := "A Mixed Case String"; - begin - Translate(Source => Str, Mapping => Map_To_Lower_Case_Ptr); - if Str /= "a mixed case string" then - Report.Failed("Incorrect result from Procedure Translate - 1"); - end if; - - Translate(New_Character_String, Map_To_Upper_Case_Ptr); - if New_Character_String /= TC_New_Character_String then - Report.Failed("Incorrect result from Procedure Translate - 2"); - end if; - end; - - -- Procedure Trim. - declare - use Ada.Strings.Wide_Fixed; - Trim_String : Wide_String(1..30) := " A string of characters "; - begin - Trim(Trim_String, Ada.Strings.Left, Ada.Strings.Right, 'x'); - if Trim_String /= "xxxxA string of characters " then - Report.Failed("Incorrect result from Procedure Trim, trim " & - "side = left, justify = right, pad = x"); - end if; - - Trim(Trim_String, Ada.Strings.Right, Ada.Strings.Center); - if Trim_String /= " xxxxA string of characters " then - Report.Failed("Incorrect result from Procedure Trim, trim " & - "side = right, justify = center, default pad"); - end if; - end; - - -- Procedure Head. - declare - Fixed_String : Wide_String(1..20) := "A sample test string"; - begin - Wide_Fixed.Head(Source => Fixed_String, Count => 14, - Justify => Ada.Strings.Center, Pad => '$'); - if Fixed_String /= "$$$A sample test $$$" then - Report.Failed("Incorrect result from Procedure Head, " & - "justify = center, pad = $"); - end if; - - Wide_Fixed.Head(Fixed_String, 11, Ada.Strings.Right); - if Fixed_String /= " $$$A sample" then - Report.Failed("Incorrect result from Procedure Head, " & - "justify = right, default pad"); - end if; - end; - - -- Procedure Tail. - declare - use Ada.Strings.Wide_Fixed; - Tail_String : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST"; - begin - -- Default left justify. - Tail(Source => Tail_String, Count => 10, Pad => '-'); - if Tail_String /= "KLMNOPQRST----------" then - Report.Failed("Incorrect result from Procedure Tail, " & - "default justify, pad = -"); - end if; - - Tail(Tail_String, 6, Ada.Strings.Center, 'a'); - if Tail_String /= "aaaaaaa------aaaaaaa" then - Report.Failed("Incorrect result from Procedure Tail, " & - "justify = center, pad = a"); - end if; - end; - - exception - when The_Error : others => - Report.Failed ("The following exception was raised in the " & - "Test_Block: " & Exception_Name(The_Error)); - end Test_Block; - - Report.Result; - -end CXA4025; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a deleted file mode 100644 index 766979ad057..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a +++ /dev/null @@ -1,526 +0,0 @@ --- CXA4026.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 Ada.Strings.Fixed procedures Head, Tail, and Trim, as well --- as the versions of subprograms Translate (procedure and function), --- Index, and Count, available in the package which use a --- Maps.Character_Mapping_Function input parameter, produce correct --- results. --- --- TEST DESCRIPTION: --- This test examines the operation of several subprograms contained in --- the Ada.Strings.Fixed package. --- This includes procedure versions of Head, Tail, and Trim, as well as --- four subprograms that use a Character_Mapping_Function as a parameter --- to provide the mapping capability. --- --- Two functions are defined to provide the mapping. Access values --- are defined to refer to these functions. One of the functions will --- map upper case characters in the range 'A'..'Z' to their lower case --- counterparts, while the other function will map lower case characters --- ('a'..'z', or a character whose position is in one of the ranges --- 223..246 or 248..255, provided the character has an upper case form) --- to their upper case form. --- --- Function Index uses the mapping function access value to map the input --- string prior to searching for the appropriate index value to return. --- Function Count uses the mapping function access value to map the input --- string prior to counting the occurrences of the pattern string. --- Both the Procedure and Function version of Translate use the mapping --- function access value to perform the translation. --- --- Results of all subprograms are compared with expected results. --- --- --- CHANGE HISTORY: --- 10 Feb 95 SAIC Initial prerelease version --- 21 Apr 95 SAIC Modified definition of string variable Str_2. --- ---! - - -package CXA4026_0 is - - -- Function Map_To_Lower_Case will return the lower case form of - -- Characters in the range 'A'..'Z' only, and return the input - -- character otherwise. - - function Map_To_Lower_Case (From : Character) return Character; - - - -- Function Map_To_Upper_Case will return the upper case form of - -- Characters in the range 'a'..'z', or whose position is in one - -- of the ranges 223..246 or 248..255, provided the character has - -- an upper case form. - - function Map_To_Upper_Case (From : Character) return Character; - -end CXA4026_0; - - -with Ada.Characters.Handling; -package body CXA4026_0 is - - function Map_To_Lower_Case (From : Character) return Character is - begin - if From in 'A'..'Z' then - return Character'Val(Character'Pos(From) - - (Character'Pos('A') - Character'Pos('a'))); - else - return From; - end if; - end Map_To_Lower_Case; - - function Map_To_Upper_Case (From : Character) return Character is - begin - return Ada.Characters.Handling.To_Upper(From); - end Map_To_Upper_Case; - -end CXA4026_0; - - -with CXA4026_0; -with Ada.Strings.Fixed; -with Ada.Strings.Maps; -with Ada.Characters.Handling; -with Ada.Characters.Latin_1; -with Report; - -procedure CXA4026 is - -begin - - Report.Test ("CXA4026", "Check that procedures Trim, Head, and Tail, " & - "as well as the versions of subprograms " & - "Translate, Index, and Count, which use the " & - "Character_Mapping_Function input parameter," & - "produce correct results"); - - Test_Block: - declare - - use Ada.Strings, CXA4026_0; - - -- The following strings are used in examination of the Translation - -- subprograms. - - New_Character_String : String(1..10) := - Ada.Characters.Latin_1.LC_A_Grave & - Ada.Characters.Latin_1.LC_A_Ring & - Ada.Characters.Latin_1.LC_AE_Diphthong & - Ada.Characters.Latin_1.LC_C_Cedilla & - Ada.Characters.Latin_1.LC_E_Acute & - Ada.Characters.Latin_1.LC_I_Circumflex & - Ada.Characters.Latin_1.LC_Icelandic_Eth & - Ada.Characters.Latin_1.LC_N_Tilde & - Ada.Characters.Latin_1.LC_O_Oblique_Stroke & - Ada.Characters.Latin_1.LC_Icelandic_Thorn; - - - TC_New_Character_String : String(1..10) := - Ada.Characters.Latin_1.UC_A_Grave & - Ada.Characters.Latin_1.UC_A_Ring & - Ada.Characters.Latin_1.UC_AE_Diphthong & - Ada.Characters.Latin_1.UC_C_Cedilla & - Ada.Characters.Latin_1.UC_E_Acute & - Ada.Characters.Latin_1.UC_I_Circumflex & - Ada.Characters.Latin_1.UC_Icelandic_Eth & - Ada.Characters.Latin_1.UC_N_Tilde & - Ada.Characters.Latin_1.UC_O_Oblique_Stroke & - Ada.Characters.Latin_1.UC_Icelandic_Thorn; - - - -- Functions used to supply mapping capability. - - - -- Access objects that will be provided as parameters to the - -- subprograms. - - Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function := - Map_To_Lower_Case'Access; - - Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function := - Map_To_Upper_Case'Access; - - - begin - - -- Function Index, Forward direction search. - -- Note: Several of the following cases use the default value - -- Forward for the Going parameter. - - if Fixed.Index(Source => "The library package Strings.Fixed", - Pattern => "fix", - Going => Ada.Strings.Forward, - Mapping => Map_To_Lower_Case_Ptr) /= 29 or - Fixed.Index("THE RAIN IN SPAIN FALLS MAINLY ON THE PLAIN", - "ain", - Mapping => Map_To_Lower_Case_Ptr) /= 6 or - Fixed.Index("maximum number", - "um", - Ada.Strings.Forward, - Map_To_Lower_Case_Ptr) /= 6 or - Fixed.Index("CoMpLeTeLy MiXeD CaSe StRiNg", - "MIXED CASE STRING", - Ada.Strings.Forward, - Map_To_Upper_Case_Ptr) /= 12 or - Fixed.Index("STRING WITH NO MATCHING PATTERNS", - "WITH", - Ada.Strings.Forward, - Map_To_Lower_Case_Ptr) /= 0 or - Fixed.Index("THIS STRING IS IN UPPER CASE", - "IS", - Ada.Strings.Forward, - Map_To_Upper_Case_Ptr) /= 3 or - Fixed.Index("", -- Null string. - "is", - Mapping => Map_To_Lower_Case_Ptr) /= 0 or - Fixed.Index("AAABBBaaabbb", - "aabb", - Mapping => Map_To_Lower_Case_Ptr) /= 2 - then - Report.Failed("Incorrect results from Function Index, going " & - "in Forward direction, using a Character Mapping " & - "Function parameter"); - end if; - - - - -- Function Index, Backward direction search. - - if Fixed.Index("Case of a Mixed Case String", - "case", - Ada.Strings.Backward, - Map_To_Lower_Case_Ptr) /= 17 or - Fixed.Index("Case of a Mixed Case String", - "CASE", - Ada.Strings.Backward, - Map_To_Upper_Case_Ptr) /= 17 or - Fixed.Index("rain, Rain, and more RAIN", - "rain", - Ada.Strings.Backward, - Map_To_Lower_Case_Ptr) /= 22 or - Fixed.Index("RIGHT place, right time", - "RIGHT", - Ada.Strings.Backward, - Map_To_Upper_Case_Ptr) /= 14 or - Fixed.Index("WOULD MATCH BUT FOR THE CASE", - "WOULD MATCH BUT FOR THE CASE", - Ada.Strings.Backward, - Map_To_Lower_Case_Ptr) /= 0 - then - Report.Failed("Incorrect results from Function Index, going " & - "in Backward direction, using a Character Mapping " & - "Function parameter"); - end if; - - - - -- Function Index, Pattern_Error if Pattern = Null_String - - declare - use Ada.Strings.Fixed; - Null_Pattern_String : constant String := ""; - TC_Natural : Natural := 1000; - begin - TC_Natural := Index("A Valid String", - Null_Pattern_String, - Ada.Strings.Forward, - Map_To_Lower_Case_Ptr); - Report.Failed("Pattern_Error not raised by Function Index when " & - "given a null pattern string"); - exception - when Pattern_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by Function Index " & - "using a Character Mapping Function parameter " & - "when given a null pattern string"); - end; - - - - -- Function Count. - - if Fixed.Count(Source => "ABABABA", - Pattern => "aba", - Mapping => Map_To_Lower_Case_Ptr) /= 2 or - Fixed.Count("ABABABA", "ABA", Map_To_Lower_Case_Ptr) /= 0 or - Fixed.Count("This IS a MISmatched issue", - "is", - Map_To_Lower_Case_Ptr) /= 4 or - Fixed.Count("ABABABA", "ABA", Map_To_Upper_Case_Ptr) /= 2 or - Fixed.Count("This IS a MISmatched issue", - "is", - Map_To_Upper_Case_Ptr) /= 0 or - Fixed.Count("She sells sea shells by the sea shore", - "s", - Map_To_Lower_Case_Ptr) /= 8 or - Fixed.Count("", -- Null string. - "match", - Map_To_Upper_Case_Ptr) /= 0 - then - Report.Failed("Incorrect results from Function Count, using " & - "a Character Mapping Function parameter"); - end if; - - - - -- Function Count, Pattern_Error if Pattern = Null_String - - declare - use Ada.Strings.Fixed; - Null_Pattern_String : constant String := ""; - TC_Natural : Natural := 1000; - begin - TC_Natural := Count("A Valid String", - Null_Pattern_String, - Map_To_Lower_Case_Ptr); - Report.Failed("Pattern_Error not raised by Function Count using " & - "a Character Mapping Function parameter when " & - "given a null pattern string"); - exception - when Pattern_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by Function Count " & - "using a Character Mapping Function parameter " & - "when given a null pattern string"); - end; - - - - -- Function Translate. - - if Fixed.Translate(Source => "A Sample Mixed Case String", - Mapping => Map_To_Lower_Case_Ptr) /= - "a sample mixed case string" or - - Fixed.Translate("ALL LOWER CASE", - Map_To_Lower_Case_Ptr) /= - "all lower case" or - - Fixed.Translate("end with lower case", - Map_To_Lower_Case_Ptr) /= - "end with lower case" or - - Fixed.Translate("", Map_To_Lower_Case_Ptr) /= - "" or - - Fixed.Translate("start with lower case", - Map_To_Upper_Case_Ptr) /= - "START WITH LOWER CASE" or - - Fixed.Translate("ALL UPPER CASE STRING", - Map_To_Upper_Case_Ptr) /= - "ALL UPPER CASE STRING" or - - Fixed.Translate("LoTs Of MiXeD CaSe ChArAcTeRs", - Map_To_Upper_Case_Ptr) /= - "LOTS OF MIXED CASE CHARACTERS" or - - Fixed.Translate("", Map_To_Upper_Case_Ptr) /= - "" or - - Fixed.Translate(New_Character_String, - Map_To_Upper_Case_Ptr) /= - TC_New_Character_String - then - Report.Failed("Incorrect results from Function Translate, using " & - "a Character Mapping Function parameter"); - end if; - - - - -- Procedure Translate. - - declare - - use Ada.Strings.Fixed; - - Str_1 : String(1..24) := "AN ALL UPPER CASE STRING"; - Str_2 : String(1..19) := "A Mixed Case String"; - Str_3 : String(1..32) := "a string with lower case letters"; - TC_Str_1 : constant String := Str_1; - TC_Str_3 : constant String := Str_3; - - begin - - Translate(Source => Str_1, Mapping => Map_To_Lower_Case_Ptr); - - if Str_1 /= "an all upper case string" then - Report.Failed("Incorrect result from Procedure Translate - 1"); - end if; - - Translate(Source => Str_1, Mapping => Map_To_Upper_Case_Ptr); - - if Str_1 /= TC_Str_1 then - Report.Failed("Incorrect result from Procedure Translate - 2"); - end if; - - Translate(Source => Str_2, Mapping => Map_To_Lower_Case_Ptr); - - if Str_2 /= "a mixed case string" then - Report.Failed("Incorrect result from Procedure Translate - 3"); - end if; - - Translate(Source => Str_2, Mapping => Map_To_Upper_Case_Ptr); - - if Str_2 /= "A MIXED CASE STRING" then - Report.Failed("Incorrect result from Procedure Translate - 4"); - end if; - - Translate(Source => Str_3, Mapping => Map_To_Lower_Case_Ptr); - - if Str_3 /= TC_Str_3 then - Report.Failed("Incorrect result from Procedure Translate - 5"); - end if; - - Translate(Source => Str_3, Mapping => Map_To_Upper_Case_Ptr); - - if Str_3 /= "A STRING WITH LOWER CASE LETTERS" then - Report.Failed("Incorrect result from Procedure Translate - 6"); - end if; - - Translate(New_Character_String, Map_To_Upper_Case_Ptr); - - if New_Character_String /= TC_New_Character_String then - Report.Failed("Incorrect result from Procedure Translate - 6"); - end if; - - end; - - - -- Procedure Trim. - - declare - Use Ada.Strings.Fixed; - Trim_String : String(1..30) := " A string of characters "; - begin - - Trim(Source => Trim_String, - Side => Ada.Strings.Left, - Justify => Ada.Strings.Right, - Pad => 'x'); - - if Trim_String /= "xxxxA string of characters " then - Report.Failed("Incorrect result from Procedure Trim, trim " & - "side = left, justify = right, pad = x"); - end if; - - Trim(Trim_String, Ada.Strings.Right, Ada.Strings.Center); - - if Trim_String /= " xxxxA string of characters " then - Report.Failed("Incorrect result from Procedure Trim, trim " & - "side = right, justify = center, default pad"); - end if; - - Trim(Trim_String, Ada.Strings.Both, Pad => '*'); - - if Trim_String /= "xxxxA string of characters****" then - Report.Failed("Incorrect result from Procedure Trim, trim " & - "side = both, default justify, pad = *"); - end if; - - end; - - - -- Procedure Head. - - declare - Fixed_String : String(1..20) := "A sample test string"; - begin - - Fixed.Head(Source => Fixed_String, - Count => 14, - Justify => Ada.Strings.Center, - Pad => '$'); - - if Fixed_String /= "$$$A sample test $$$" then - Report.Failed("Incorrect result from Procedure Head, " & - "justify = center, pad = $"); - end if; - - Fixed.Head(Fixed_String, 11, Ada.Strings.Right); - - if Fixed_String /= " $$$A sample" then - Report.Failed("Incorrect result from Procedure Head, " & - "justify = right, default pad"); - end if; - - Fixed.Head(Fixed_String, 9, Pad => '*'); - - if Fixed_String /= " ***********" then - Report.Failed("Incorrect result from Procedure Head, " & - "default justify, pad = *"); - end if; - - end; - - - -- Procedure Tail. - - declare - Use Ada.Strings.Fixed; - Tail_String : String(1..20) := "ABCDEFGHIJKLMNOPQRST"; - begin - - Tail(Source => Tail_String, Count => 10, Pad => '-'); - - if Tail_String /= "KLMNOPQRST----------" then - Report.Failed("Incorrect result from Procedure Tail, " & - "default justify, pad = -"); - end if; - - Tail(Tail_String, 6, Justify => Ada.Strings.Center, Pad => 'a'); - - if Tail_String /= "aaaaaaa------aaaaaaa" then - Report.Failed("Incorrect result from Procedure Tail, " & - "justify = center, pad = a"); - end if; - - Tail(Tail_String, 1, Ada.Strings.Right); - - if Tail_String /= " a" then - Report.Failed("Incorrect result from Procedure Tail, " & - "justify = right, default pad"); - end if; - - Tail(Tail_String, 19, Ada.Strings.Right, 'A'); - - if Tail_String /= "A a" then - Report.Failed("Incorrect result from Procedure Tail, " & - "justify = right, pad = A"); - end if; - - end; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end CXA4026; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a deleted file mode 100644 index 05c66d4cc9f..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a +++ /dev/null @@ -1,342 +0,0 @@ --- CXA4027.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 versions of Ada.Strings.Bounded subprograms Translate, --- (procedure and function), Index, and Count, which use the --- Maps.Character_Mapping_Function input parameter, produce correct --- results. --- --- TEST DESCRIPTION: --- This test examines the operation of several subprograms from within --- the Ada.Strings.Bounded package that use the --- Character_Mapping_Function mapping parameter to provide a mapping --- capability. --- --- Two functions are defined to provide the mapping. Access values --- are defined to refer to these functions. One of the functions will --- map upper case characters in the range 'A'..'Z' to their lower case --- counterparts, while the other function will map lower case characters --- ('a'..'z', or a character whose position is in one of the ranges --- 223..246 or 248..255, provided the character has an upper case form) --- to their upper case form. --- --- Function Index uses the mapping function access value to map the input --- string prior to searching for the appropriate index value to return. --- Function Count uses the mapping function access value to map the input --- string prior to counting the occurrences of the pattern string. --- Both the Procedure and Function version of Translate use the mapping --- function access value to perform the translation. --- --- --- CHANGE HISTORY: --- 16 FEB 95 SAIC Initial prerelease version --- 17 Jul 95 SAIC Incorporated reviewer comments. Replaced two --- internally declared functions with two library --- level functions to eliminate accessibility --- problems. --- ---! - - --- Function CXA4027_0 will return the lower case form of --- the character input if it is in upper case, and return the input --- character otherwise. - -with Ada.Characters.Handling; -function CXA4027_0 (From : Character) return Character; - -function CXA4027_0 (From : Character) return Character is -begin - return Ada.Characters.Handling.To_Lower(From); -end CXA4027_0; - - - --- Function CXA4027_1 will return the upper case form of --- Characters in the range 'a'..'z', or whose position is in one --- of the ranges 223..246 or 248..255, provided the character has --- an upper case form. - -with Ada.Characters.Handling; -function CXA4027_1 (From : Character) return Character; - -function CXA4027_1 (From : Character) return Character is -begin - return Ada.Characters.Handling.To_Upper(From); -end CXA4027_1; - - -with CXA4027_0, CXA4027_1; -with Ada.Strings.Bounded; -with Ada.Strings.Maps; -with Ada.Characters.Handling; -with Report; - -procedure CXA4027 is -begin - - Report.Test ("CXA4027", "Check that Ada.Strings.Bounded subprograms " & - "Translate, Index, and Count, which use the " & - "Character_Mapping_Function input parameter, " & - "produce correct results"); - - Test_Block: - declare - - use Ada.Strings; - - -- Functions used to supply mapping capability. - - function Map_To_Lower_Case (From : Character) return Character - renames CXA4027_0; - - function Map_To_Upper_Case (From : Character) return Character - renames CXA4027_1; - - Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function := - Map_To_Lower_Case'Access; - - Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function := - Map_To_Upper_Case'Access; - - - -- Instantiations of Bounded String generic package. - - package BS1 is new Ada.Strings.Bounded.Generic_Bounded_Length(1); - package BS20 is new Ada.Strings.Bounded.Generic_Bounded_Length(20); - package BS40 is new Ada.Strings.Bounded.Generic_Bounded_Length(40); - package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80); - - use type BS1.Bounded_String, BS20.Bounded_String, - BS40.Bounded_String, BS80.Bounded_String; - - String_1 : String(1..1) := "A"; - String_20 : String(1..20) := "ABCDEFGHIJKLMNOPQRST"; - String_40 : String(1..40) := "abcdefghijklmnopqrst" & String_20; - String_80 : String(1..80) := String_40 & String_40; - - BString_1 : BS1.Bounded_String := BS1.Null_Bounded_String; - BString_20 : BS20.Bounded_String := BS20.Null_Bounded_String; - BString_40 : BS40.Bounded_String := BS40.Null_Bounded_String; - BString_80 : BS80.Bounded_String := BS80.Null_Bounded_String; - - - begin - - -- Function Index. - - if BS40.Index(BS40.To_Bounded_String("Package Strings.Bounded"), - Pattern => "s.b", - Going => Ada.Strings.Forward, - Mapping => Map_To_Lower_Case_Ptr) /= 15 or - BS80.Index(BS80.To_Bounded_String("STRING TRANSLATIONS SUBPROGRAMS"), - "tr", - Mapping => Map_To_Lower_Case_Ptr) /= 2 or - BS20.Index(BS20.To_Bounded_String("maximum number"), - "um", - Ada.Strings.Backward, - Map_To_Lower_Case_Ptr) /= 10 or - BS80.Index(BS80.To_Bounded_String("CoMpLeTeLy MiXeD CaSe StRiNg"), - "MIXED CASE STRING", - Ada.Strings.Forward, - Map_To_Upper_Case_Ptr) /= 12 or - BS40.Index(BS40.To_Bounded_String("STRING WITH NO MATCHING PATTERN"), - "WITH", - Ada.Strings.Backward, - Map_To_Lower_Case_Ptr) /= 0 or - BS80.Index(BS80.To_Bounded_String("THIS STRING IS IN UPPER CASE"), - "I", - Ada.Strings.Backward, - Map_To_Upper_Case_Ptr) /= 16 or - BS1.Index(BS1.Null_Bounded_String, - "i", - Mapping => Map_To_Lower_Case_Ptr) /= 0 or - BS40.Index(BS40.To_Bounded_String("AAABBBaaabbb"), - "aabb", - Mapping => Map_To_Lower_Case_Ptr) /= 2 or - BS80.Index(BS80.To_Bounded_String("WOULD MATCH BUT FOR THE CASE"), - "WOULD MATCH BUT FOR THE CASE", - Ada.Strings.Backward, - Map_To_Lower_Case_Ptr) /= 0 - then - Report.Failed("Incorrect results from Function Index, using a " & - "Character Mapping Function parameter"); - end if; - - - -- Function Index, Pattern_Error if Pattern = Null_String - - declare - use BS20; - TC_Natural : Natural := 1000; - begin - TC_Natural := Index(To_Bounded_String("A Valid String"), - "", - Ada.Strings.Forward, - Map_To_Lower_Case_Ptr); - Report.Failed("Pattern_Error not raised by Function Index when " & - "given a null pattern string"); - exception - when Pattern_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by Function Index " & - "using a Character_Mapping_Function parameter " & - "when given a null pattern string"); - end; - - - -- Function Count. - - if BS20.Count(BS20.To_Bounded_String("ABABABA"), - Pattern => "aba", - Mapping => Map_To_Lower_Case_Ptr) /= 2 or - BS20.Count(BS20.To_Bounded_String("ABABABA"), - "ABA", - Map_To_Lower_Case_Ptr) /= 0 or - BS40.Count(BS40.To_Bounded_String("This IS a MISmatched issue"), - "is", - Map_To_Lower_Case_Ptr) /= 4 or - BS80.Count(BS80.To_Bounded_String("ABABABA"), - "ABA", - Map_To_Upper_Case_Ptr) /= 2 or - BS40.Count(BS40.To_Bounded_String("This IS a MISmatched issue"), - "is", - Map_To_Upper_Case_Ptr) /= 0 or - BS80.Count(BS80.To_Bounded_String - ("Peter Piper and his Pickled Peppers"), - "p", - Map_To_Lower_Case_Ptr) /= 7 or - BS20.Count(BS20.To_Bounded_String("She sells sea shells"), - "s", - Map_To_Upper_Case_Ptr) /= 0 or - BS80.Count(BS80.To_Bounded_String("No matches what-so-ever"), - "matches", - Map_To_Upper_Case_Ptr) /= 0 - then - Report.Failed("Incorrect results from Function Count, using " & - "a Character_Mapping_Function parameter"); - end if; - - - -- Function Count, Pattern_Error if Pattern = Null_String - - declare - use BS80; - TC_Natural : Natural := 1000; - begin - TC_Natural := Count(To_Bounded_String("A Valid String"), - "", - Map_To_Lower_Case_Ptr); - Report.Failed("Pattern_Error not raised by Function Count using " & - "a Character_Mapping_Function parameter when " & - "given a null pattern string"); - exception - when Pattern_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by Function Count " & - "using a Character_Mapping_Function parameter " & - "when given a null pattern string"); - end; - - - -- Function Translate. - - if BS40.Translate(BS40.To_Bounded_String("A Mixed Case String"), - Mapping => Map_To_Lower_Case_Ptr) /= - BS40.To_Bounded_String("a mixed case string") or - - BS20."/="(BS20.Translate(BS20.To_Bounded_String("ALL LOWER CASE"), - Map_To_Lower_Case_Ptr), - "all lower case") or - - BS20."/="("end with lower case", - BS20.Translate( - BS20.To_Bounded_String("end with lower case"), - Map_To_Lower_Case_Ptr)) or - - BS1.Translate(BS1.Null_Bounded_String, - Map_To_Lower_Case_Ptr) /= - BS1.Null_Bounded_String or - - BS80."/="(BS80.Translate(BS80.To_Bounded_String - ("start with lower case, end with upper case"), - Map_To_Upper_Case_Ptr), - "START WITH LOWER CASE, END WITH UPPER CASE") or - - BS40.Translate(BS40.To_Bounded_String("ALL UPPER CASE STRING"), - Map_To_Upper_Case_Ptr) /= - BS40.To_Bounded_String("ALL UPPER CASE STRING") or - - BS80."/="(BS80.Translate(BS80.To_Bounded_String - ("LoTs Of MiXeD CaSe ChArAcTeRs In ThE StRiNg"), - Map_To_Upper_Case_Ptr), - "LOTS OF MIXED CASE CHARACTERS IN THE STRING") - - then - Report.Failed("Incorrect results from Function Translate, using " & - "a Character_Mapping_Function parameter"); - end if; - - - -- Procedure Translate. - - BString_1 := BS1.To_Bounded_String("A"); - - BS1.Translate(Source => BString_1, Mapping => Map_To_Lower_Case_Ptr); - - if not BS1."="(BString_1, "a") then -- "=" for Bounded_String, String - Report.Failed("Incorrect result from Procedure Translate - 1"); - end if; - - BString_20 := BS20.To_Bounded_String(String_20); - BS20.Translate(BString_20, Mapping => Map_To_Lower_Case_Ptr); - - if BString_20 /= BS20.To_Bounded_String("abcdefghijklmnopqrst") then - Report.Failed("Incorrect result from Procedure Translate - 2"); - end if; - - BString_40 := BS40.To_Bounded_String("String needing highlighting"); - BS40.Translate(BString_40, Map_To_Upper_Case_Ptr); - - if not (BString_40 = "STRING NEEDING HIGHLIGHTING") then - Report.Failed("Incorrect result from Procedure Translate - 3"); - end if; - - BString_80 := BS80.Null_Bounded_String; - BS80.Translate(BString_80, Map_To_Upper_Case_Ptr); - - if not (BString_80 = BS80.Null_Bounded_String) then - Report.Failed("Incorrect result from Procedure Translate - 4"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA4027; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a deleted file mode 100644 index bc6cac14c5e..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a +++ /dev/null @@ -1,331 +0,0 @@ --- CXA4028.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 Ada.Strings.Bounded procedures Append, Head, Tail, and --- Trim, and relational operator functions "=", ">", ">=", "<", "<=" --- with parameter combinations of type String and Bounded_String, --- produce correct results. --- --- TEST DESCRIPTION: --- This test examines the operation of several subprograms from within --- the Ada.Strings.Bounded package. Four different instantiations of --- Ada.Strings.Bounded.Generic_Bounded_Length provide packages defined --- to manipulate bounded strings of lengths 1, 20, 40, and 80. --- Examples of the above mentioned procedures and relational operators --- from each of these instantiations are tested, with results compared --- against expected output. --- --- Testing of the function versions of many of the subprograms tested --- here is performed in tests CXA4006-CXA4009. --- --- --- CHANGE HISTORY: --- 16 Feb 95 SAIC Initial prerelease version --- 10 Mar 95 SAIC Incorporated reviewer comments. --- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- ---! - -with Ada.Exceptions; -with Ada.Strings.Bounded; -with Report; - -procedure CXA4028 is - -begin - - Report.Test ("CXA4028", "Check that Ada.Strings.Bounded procedures " & - "Append, Head, Tail, and Trim, and relational " & - "operator functions =, >, >=, <, <= with " & - "parameter combinations of type String and " & - "Bounded_String, produce correct results"); - - Test_Block: - declare - - use Ada.Exceptions; - use Ada.Strings; - - -- Instantiations of Bounded String generic package. - - package BS1 is new Ada.Strings.Bounded.Generic_Bounded_Length(1); - package BS20 is new Ada.Strings.Bounded.Generic_Bounded_Length(20); - package BS40 is new Ada.Strings.Bounded.Generic_Bounded_Length(40); - package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80); - - use type BS1.Bounded_String, BS20.Bounded_String, - BS40.Bounded_String, BS80.Bounded_String; - - String_1 : String(1..1) := "A"; - String_20 : String(1..20) := "ABCDEFGHIJKLMNOPQRST"; - String_40 : String(1..40) := "abcdefghijklmnopqrst" & String_20; - String_80 : String(1..80) := String_40 & String_40; - - BString_1 : BS1.Bounded_String := BS1.Null_Bounded_String; - BString_20 : BS20.Bounded_String := BS20.Null_Bounded_String; - BString_40 : BS40.Bounded_String := BS40.Null_Bounded_String; - BString_80 : BS80.Bounded_String := BS80.Null_Bounded_String; - - begin - - -- Procedure Append. - - declare - use BS1, BS20; - begin - Append(Source => BString_1, New_Item => To_Bounded_String("A")); - Append(BString_1, "B", Ada.Strings.Left); - Append(BString_1, 'C', Drop => Ada.Strings.Right); -- Drop appended - -- character. - if BString_1 /= To_Bounded_String("B") then - Report.Failed("Incorrect results from BS1 versions of " & - "procedure Append"); - end if; - - Append(BString_20, 'T'); -- Character. - Append(BString_20, "his string"); -- String. - Append(BString_20, - To_Bounded_String(" is complete."), -- Bounded string. - Drop => Ada.Strings.Right); -- Drop 4 characters. - - if BString_20 /= To_Bounded_String("This string is compl") then - Report.Failed("Incorrect results from BS20 versions of " & - "procedure Append"); - end if; - end; - - - -- Operator "=". - - BString_40 := BS40.To_Bounded_String(String_40); - BString_80 := BS80.To_Bounded_String( - BS40.To_String(BString_40) & - BS40.To_String(BString_40)); - - if not (BString_40 = String_40 and -- (Bounded_String, String) - BS80."="(String_80, BString_80)) -- (String, Bounded_String) - then - Report.Failed("Incorrect results from function ""="" with " & - "string - bounded string parameter combinations"); - end if; - - - -- Operator "<". - - BString_1 := BS1.To_Bounded_String("cat", -- string "c" only. - Drop => Ada.Strings.Right); - BString_20 := BS20.To_Bounded_String("Santa Claus"); - - if BString_1 < "C" or -- (Bounded_String, String) - BS1."<"(BString_1,"c") or -- (Bounded_String, String) - "x" < BString_1 or -- (String, Bounded_String) - BString_20 < "Santa " or -- (Bounded_String, String) - "Santa and his Elves" < BString_20 -- (String, Bounded_String) - then - Report.Failed("Incorrect results from function ""<"" with " & - "string - bounded string parameter combinations"); - end if; - - - -- Operator "<=". - - BString_20 := BS20.To_Bounded_String("Sample string"); - - if BString_20 <= "Sample strin" or -- (Bounded_String, String) - "sample string" <= BString_20 or -- (String, Bounded_String) - not("Sample string" <= BString_20) -- (String, Bounded_String) - then - Report.Failed("Incorrect results from function ""<="" with " & - "string - bounded string parameter combinations"); - end if; - - - -- Operator ">". - - BString_40 := BS40.To_Bounded_String("A MUCH LONGER SAMPLE STRING."); - - if BString_40 > "A much longer sample string" or -- (Bnd_Str, Str) - String_20 > BS40.To_Bounded_String(String_40) or -- (Str, Bnd_Str) - BS40.To_Bounded_String("ABCDEFGH") > "abcdefgh" -- (Str, Bnd_Str) - then - Report.Failed("Incorrect results from function "">"" with " & - "string - bounded string parameter combinations"); - end if; - - - -- Operator ">=". - - BString_80 := BS80.To_Bounded_String(String_80); - - if not (BString_80 >= String_80 and - BS80.To_Bounded_String("Programming") >= "PROGRAMMING" and - "test" >= BS80.To_Bounded_String("tess")) - then - Report.Failed("Incorrect results from function "">="" with " & - "string - bounded string parameter combinations"); - end if; - - - -- Procedure Trim - - BString_20 := BS20.To_Bounded_String(" Left Spaces "); - BS20.Trim(Source => BString_20, - Side => Ada.Strings.Left); - - if "Left Spaces " /= BString_20 then - Report.Failed("Incorrect results from Procedure Trim with " & - "Side = Left"); - end if; - - BString_40 := BS40.To_Bounded_String(" Right Spaces "); - BS40.Trim(BString_40, Side => Ada.Strings.Right); - - if BString_40 /= " Right Spaces" then - Report.Failed("Incorrect results from Procedure Trim with " & - "Side = Right"); - end if; - - BString_20 := BS20.To_Bounded_String(" Both Sides "); - BS20.Trim(BString_20, Ada.Strings.Both); - - if BString_20 /= BS20.To_Bounded_String("Both Sides") then - Report.Failed("Incorrect results from Procedure Trim with " & - "Side = Both"); - end if; - - BString_80 := BS80.To_Bounded_String("Centered Spaces"); - BS80.Trim(BString_80, Ada.Strings.Both); - - if BString_80 /= BS80.To_Bounded_String("Centered Spaces") then - Report.Failed("Incorrect results from Procedure Trim with " & - "no blank spaces on the ends of the string"); - end if; - - - -- Procedure Head - - BString_40 := BS40.To_Bounded_String("Test String"); - BS40.Head(Source => BString_40, - Count => 4); -- Count < Source'Length - - if BString_40 /= BS40.To_Bounded_String("Test") then - Report.Failed("Incorrect results from Procedure Head with " & - "the Count parameter less than Source'Length"); - end if; - - BString_1 := BS1.To_Bounded_String("X"); - BS1.Head(BString_1, BS1.Length(BString_1)); -- Count = Source'Length - - if BString_1 /= "X" then - Report.Failed("Incorrect results from Procedure Head with " & - "the Count parameter equal to Source'Length"); - end if; - - BString_20 := BS20.To_Bounded_String("Sample string"); - BS20.Head(BString_20, - Count => BS20.Max_Length, -- Count > Source'Length - Pad => '*'); - - if BString_20 /= BS20.To_Bounded_String("Sample string*******") then - Report.Failed("Incorrect results from Procedure Head with " & - "the Count parameter greater than Source'Length"); - end if; - - BString_20 := BS20.To_Bounded_String("Twenty Characters 20"); - BS20.Head(BString_20, 22, Pad => '*', Drop => Ada.Strings.Left); - - if BString_20 /= "enty Characters 20**" then - Report.Failed("Incorrect results from Procedure Head with " & - "the Count parameter greater than Source'Length, " & - "and the Drop parameter = Left"); - end if; - - BString_20 := BS20.To_Bounded_String("Short String"); - BS20.Head(BString_20, 23, '-', Ada.Strings.Right); - - if ("Short String--------") /= BString_20 then - Report.Failed("Incorrect results from Procedure Head with " & - "the Count parameter greater than Source'Length, " & - "and the Drop parameter = Right"); - end if; - - - -- Procedure Tail - - BString_40 := BS40.To_Bounded_String("Test String"); - BS40.Tail(Source => BString_40, - Count => 6); -- Count < Source'Length - - if BString_40 /= BS40.To_Bounded_String("String") then - Report.Failed("Incorrect results from Procedure Tail with " & - "the Count parameter less than Source'Length"); - end if; - - BString_1 := BS1.To_Bounded_String("X"); - BS1.Tail(BString_1, BS1.Length(BString_1)); -- Count = Source'Length - - if BString_1 /= "X" then - Report.Failed("Incorrect results from Procedure Tail with " & - "the Count parameter equal to Source'Length"); - end if; - - BString_20 := BS20.To_Bounded_String("Sample string"); - BS20.Tail(BString_20, - Count => BS20.Max_Length, -- Count > Source'Length - Pad => '*'); - - if BString_20 /= BS20.To_Bounded_String("*******Sample string") then - Report.Failed("Incorrect results from Procedure Tail with " & - "the Count parameter greater than Source'Length"); - end if; - - BString_20 := BS20.To_Bounded_String("Twenty Characters"); -- Len = 17 - BS20.Tail(BString_20, 22, Pad => '*', Drop => Ada.Strings.Left); - - if BString_20 /= "***Twenty Characters" then - Report.Failed("Incorrect results from Procedure Tail with " & - "the Count parameter greater than Source'Length, " & - "and the Drop parameter = Left"); - end if; - - BString_20 := BS20.To_Bounded_String("Maximum Length Chars"); - BS20.Tail(BString_20, 23, '-', Ada.Strings.Right); - - if ("---Maximum Length Ch") /= BString_20 then - Report.Failed("Incorrect results from Procedure Tail with " & - "the Count parameter greater than Source'Length, " & - "and the Drop parameter = Right"); - end if; - - exception - when The_Error : others => - Report.Failed ("The following exception was raised in the " & - "Test_Block: " & Exception_Name(The_Error)); - end Test_Block; - - Report.Result; - -end CXA4028; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a deleted file mode 100644 index 7140674544a..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a +++ /dev/null @@ -1,333 +0,0 @@ --- CXA4029.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 functionality found in packages Ada.Strings.Wide_Maps, --- Ada.Strings.Wide_Bounded, and Ada.Strings.Wide_Maps.Wide_Constants --- is available and produces correct results. --- --- TEST DESCRIPTION: --- This test tests the subprograms found in the --- Ada.Strings.Wide_Bounded package. It is based on the tests --- CXA4027-28, which are tests for the complementary "non-wide" --- packages. --- --- The functions found in CXA4029_0 provide mapping capability, when --- used in conjunction with Wide_Character_Mapping_Function objects. --- --- --- CHANGE HISTORY: --- 23 Jun 95 SAIC Initial prerelease version. --- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- ---! - -package CXA4029_0 is - -- Functions used to supply mapping capability. - function Map_To_Lower_Case (From : Wide_Character) return Wide_Character; - function Map_To_Upper_Case (From : Wide_Character) return Wide_Character; -end CXA4029_0; - -with Ada.Characters.Handling; -package body CXA4029_0 is - -- Function Map_To_Lower_Case will return the lower case form of - -- Wide_Characters in the range 'A'..'Z' only, and return the input - -- wide_character otherwise. - - function Map_To_Lower_Case (From : Wide_Character) - return Wide_Character is - begin - return Ada.Characters.Handling.To_Wide_Character( - Ada.Characters.Handling.To_Lower( - Ada.Characters.Handling.To_Character(From))); - end Map_To_Lower_Case; - - -- Function Map_To_Upper_Case will return the upper case form of - -- Wide_Characters in the range 'a'..'z', or whose position is in one - -- of the ranges 223..246 or 248..255, provided the wide_character has - -- an upper case form. - - function Map_To_Upper_Case (From : Wide_Character) - return Wide_Character is - begin - return Ada.Characters.Handling.To_Wide_Character( - Ada.Characters.Handling.To_Upper( - Ada.Characters.Handling.To_Character(From))); - end Map_To_Upper_Case; - -end CXA4029_0; - - -with CXA4029_0; -with Report; -with Ada.Characters.Handling; -with Ada.Characters.Latin_1; -with Ada.Strings; -with Ada.Strings.Wide_Maps; -with Ada.Strings.Wide_Maps.Wide_Constants; -with Ada.Strings.Wide_Fixed; -with Ada.Strings.Wide_Bounded; - -procedure CXA4029 is -begin - Report.Test ("CXA4029", - "Check that subprograms defined in package " & - "Ada.Strings.Wide_Bounded produce correct results"); - - Test_Block: - declare - - package ACL1 renames Ada.Characters.Latin_1; - package BS1 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(1); - package BS20 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(20); - package BS40 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(40); - package BS80 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(80); - - subtype LC_Characters is Wide_Character range 'a'..'z'; - - use Ada.Characters, Ada.Strings; - use type Wide_Maps.Wide_Character_Set; - use type BS1.Bounded_Wide_String, BS20.Bounded_Wide_String, - BS40.Bounded_Wide_String, BS80.Bounded_Wide_String; - - TC_String : constant Wide_String := "A Standard String"; - - BString_1 : BS1.Bounded_Wide_String := - BS1.Null_Bounded_Wide_String; - BString_20 : BS20.Bounded_Wide_String := - BS20.Null_Bounded_Wide_String; - BString_40 : BS40.Bounded_Wide_String := - BS40.Null_Bounded_Wide_String; - BString_80 : BS80.Bounded_Wide_String := - BS80.Null_Bounded_Wide_String; - String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST"; - String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" & - String_20; - String_80 : Wide_String(1..80) := String_40 & String_40; - TC_String_5 : Wide_String(1..5) := "ABCDE"; - - -- The following strings are used in examination of the Translation - -- subprograms. - New_Character_String : Wide_String(1..10) := - Handling.To_Wide_String( - ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong & - ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex & - ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde & - ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn); - - TC_New_Character_String : Wide_String(1..10) := - Handling.To_Wide_String( - ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong & - ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex & - ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde & - ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn); - - -- Access objects that will be provided as parameters to the - -- subprograms. - Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := - CXA4029_0.Map_To_Lower_Case'Access; - Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := - CXA4029_0.Map_To_Upper_Case'Access; - - begin - - -- Testing of functionality found in Package Ada.Strings.Wide_Bounded. - -- - -- Function Index. - - if BS80.Index(BS80.To_Bounded_Wide_String("CoMpLeTeLy MiXeD CaSe"), - "MIXED CASE", - Ada.Strings.Forward, - Map_To_Upper_Case_Ptr) /= 12 or - BS1.Index(BS1.Null_Bounded_Wide_String, - "i", - Mapping => Map_To_Lower_Case_Ptr) /= 0 - then - Report.Failed("Incorrect results from BND Function Index, going " & - "in Forward direction, using a Character Mapping " & - "Function parameter"); - end if; - - -- Function Count. - if BS40.Count(BS40.To_Bounded_Wide_String("This IS a MISmatched issue"), - "is", - Map_To_Lower_Case_Ptr) /= 4 or - BS80.Count(BS80.To_Bounded_Wide_String("ABABABA"), - "ABA", - Map_To_Upper_Case_Ptr) /= 2 - then - Report.Failed("Incorrect results from BND Function Count, using " & - "a Character_Mapping_Function parameter"); - end if; - - -- Function Translate. - if BS40.Translate(BS40.To_Bounded_Wide_String("A Mixed Case String"), - Mapping => Map_To_Lower_Case_Ptr) /= - BS40.To_Bounded_Wide_String("a mixed case string") or - BS20."/="("end with lower case", - BS20.Translate( - BS20.To_Bounded_Wide_String("end with lower case"), - Map_To_Lower_Case_Ptr)) - then - Report.Failed("Incorrect results from BND Function Translate, " & - "using a Character_Mapping_Function parameter"); - end if; - - -- Procedure Translate. - BString_20 := BS20.To_Bounded_Wide_String(String_20); - BS20.Translate(BString_20, Mapping => Map_To_Lower_Case_Ptr); - if BString_20 /= BS20.To_Bounded_Wide_String("abcdefghijklmnopqrst") - then - Report.Failed("Incorrect result from BND Procedure Translate - 1"); - end if; - - BString_80 := BS80.Null_Bounded_Wide_String; - BS80.Translate(BString_80, Map_To_Upper_Case_Ptr); - if not (BString_80 = BS80.Null_Bounded_Wide_String) then - Report.Failed("Incorrect result from BND Procedure Translate - 2"); - end if; - - -- Procedure Append. - declare - use BS20; - begin - BString_20 := BS20.Null_Bounded_Wide_String; - Append(BString_20, 'T'); - Append(BString_20, "his string"); - Append(BString_20, - To_Bounded_Wide_String(" is complete."), - Drop => Ada.Strings.Right); -- Drop 4 characters. - if BString_20 /= To_Bounded_Wide_String("This string is compl") then - Report.Failed("Incorrect results from BS20 versions of " & - "procedure Append"); - end if; - exception - when others => Report.Failed("Exception raised in block checking " & - "BND Procedure Append"); - end; - - -- Operator "=". - BString_40 := BS40.To_Bounded_Wide_String(String_40); - BString_80 := BS80.To_Bounded_Wide_String( - BS40.To_Wide_String(BString_40) & - BS40.To_Wide_String(BString_40)); - if not (BString_40 = String_40 and - BS80."="(String_80, BString_80)) then - Report.Failed("Incorrect results from BND Function ""="" with " & - "string - bounded string parameter combinations"); - end if; - - -- Operator "<". - BString_1 := BS1.To_Bounded_Wide_String("cat", - Drop => Ada.Strings.Right); - BString_20 := BS20.To_Bounded_Wide_String("Santa Claus"); - if BString_1 < "C" or - BS1."<"(BString_1,"c") or - BS1."<"("x", BString_1) or - BS20."<"(BString_20,"Santa ") or - BS20."<"("Santa and his Elves", BString_20) - then - Report.Failed("Incorrect results from BND Function ""<"" with " & - "string - bounded string parameter combinations"); - end if; - - -- Operator "<=". - BString_20 := BS20.To_Bounded_Wide_String("Sample string"); - if BS20."<="(BString_20,"Sample strin") or - not(BS20."<="("Sample string",BString_20)) - then - Report.Failed("Incorrect results from BND Function ""<="" with " & - "string - bounded string parameter combinations"); - end if; - - -- Operator ">". - BString_40 := BS40.To_Bounded_Wide_String( - "A MUCH LONGER SAMPLE STRING."); - if BString_40 > "A much longer sample string" or - BS40.To_Bounded_Wide_String("ABCDEFGH") > "abcdefgh" - then - Report.Failed("Incorrect results from BND Function "">"" with " & - "string - bounded string parameter combinations"); - end if; - - -- Operator ">=". - BString_80 := BS80.To_Bounded_Wide_String(String_80); - if not (BString_80 >= String_80 and - BS80.To_Bounded_Wide_String("Programming") >= "PROGRAMMING" and - BS80.">="("test", BS80.To_Bounded_Wide_String("tess"))) - then - Report.Failed("Incorrect results from BND Function "">="" with " & - "string - bounded string parameter combinations"); - end if; - - -- Procedure Trim - BString_20 := BS20.To_Bounded_Wide_String(" Both Sides "); - BS20.Trim(BString_20, Ada.Strings.Both); - if BString_20 /= BS20.To_Bounded_Wide_String("Both Sides") then - Report.Failed("Incorrect results from BND Procedure Trim with " & - "Side = Both"); - end if; - - -- Procedure Head - BString_40 := BS40.To_Bounded_Wide_String("Test String"); - BS40.Head(Source => BString_40, - Count => 4); -- Count < Source'Length - if BString_40 /= BS40.To_Bounded_Wide_String("Test") then - Report.Failed("Incorrect results from BND Procedure Head with " & - "the Count parameter less than Source'Length"); - end if; - - BString_20 := BS20.To_Bounded_Wide_String("Short String"); - BS20.Head(BString_20, 23, '-', Ada.Strings.Right); - if BS20.To_Bounded_Wide_String("Short String--------") /= BString_20 then - Report.Failed("Incorrect results from BND Procedure Head with " & - "the Count parameter greater than Source'Length, " & - "and the Drop parameter = Right"); - end if; - - -- Procedure Tail - BString_40 := BS40.To_Bounded_Wide_String("Test String"); - BS40.Tail(Source => BString_40, - Count => 6); - if BString_40 /= BS40.To_Bounded_Wide_String("String") then - Report.Failed("Incorrect results from BND Procedure Tail with " & - "the Count parameter less than Source'Length"); - end if; - - BString_20 := BS20.To_Bounded_Wide_String("Maximum Length Chars"); - BS20.Tail(BString_20, 23, '-', Ada.Strings.Right); - if BS20.To_Bounded_Wide_String("---Maximum Length Ch") /= BString_20 then - Report.Failed("Incorrect results from BND Procedure Tail with " & - "the Count parameter greater than Source'Length, " & - "and the Drop parameter = Right"); - end if; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA4029; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a deleted file mode 100644 index 475d0089921..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a +++ /dev/null @@ -1,414 +0,0 @@ --- CXA4030.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 Ada.Strings.Unbounded versions of subprograms Translate --- (procedure and function), Index, and Count, which use a --- Maps.Character_Mapping_Function input parameter, produce correct --- results. --- --- TEST DESCRIPTION: --- This test examines the operation of the four subprograms contained --- in the Ada.Strings.Unbounded package that use a --- Character_Mapping_Function parameter to provide the mapping --- capability. --- Two Character_Mapping_Function objects are defined that reference --- subprograms contained in the Ada.Characters.Handling package; --- To_Lower will return the lower-case form of the character provided --- as the input parameter, To_Upper will return the upper-case form --- of the character input parameter (provided there is an upper-case --- form). --- In several instances in this test, the character handling functions --- are referenced directly in the parameter list of the subprograms --- under test, demonstrating another form of expected common usage. --- --- Results of all subprograms are compared with expected results. --- --- This test, when taken in conjunction with tests CXA4010, CXA4011, --- CXA4031, and CXA4032 will constitute a test of all the functionality --- contained in package Ada.Strings.Unbounded. This test uses a variety --- of the subprograms defined in the unbounded string package in ways --- typical of common usage. --- --- --- CHANGE HISTORY: --- 21 Feb 95 SAIC Initial prerelease version --- 21 Apr 95 SAIC Modified header commentary. --- ---! - -with Ada.Strings.Unbounded; -with Ada.Strings.Maps; -with Ada.Characters.Handling; -with Ada.Characters.Latin_1; -with Report; - -procedure CXA4030 is - -begin - - Report.Test ("CXA4030", "Check that Ada.Strings.Unbounded versions " & - "of subprograms Translate (procedure and " & - "function), Index, and Count, which use a " & - "Maps.Character_Mapping_Function input " & - "parameter, produce correct results"); - - Test_Block: - declare - - package Unb renames Ada.Strings.Unbounded; - use type Unb.Unbounded_String; - use Ada.Strings; - use Ada.Characters; - - - -- The following strings are used in examination of the Translation - -- subprograms. - - New_Character_String : Unb.Unbounded_String := - Unb.To_Unbounded_String( - Latin_1.LC_A_Grave & - Latin_1.LC_A_Ring & - Latin_1.LC_AE_Diphthong & - Latin_1.LC_C_Cedilla & - Latin_1.LC_E_Acute & - Latin_1.LC_I_Circumflex & - Latin_1.LC_Icelandic_Eth & - Latin_1.LC_N_Tilde & - Latin_1.LC_O_Oblique_Stroke & - Latin_1.LC_Icelandic_Thorn); - - - TC_New_Character_String : Unb.Unbounded_String := - Unb.To_Unbounded_String( - Latin_1.UC_A_Grave & - Latin_1.UC_A_Ring & - Latin_1.UC_AE_Diphthong & - Latin_1.UC_C_Cedilla & - Latin_1.UC_E_Acute & - Latin_1.UC_I_Circumflex & - Latin_1.UC_Icelandic_Eth & - Latin_1.UC_N_Tilde & - Latin_1.UC_O_Oblique_Stroke & - Latin_1.UC_Icelandic_Thorn); - - - -- In this test, access objects are defined to refer to two functions - -- from the Ada.Characters.Handling package. These access objects - -- will be provided as parameters to the subprograms under test. - -- Note: There will be several examples in this test of these character - -- handling functions being referenced directly within the - -- parameter list of the subprograms under test. - - Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function := - Handling.To_Lower'Access; - - Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function := - Handling.To_Upper'Access; - - begin - - -- Function Index, Forward direction search. - -- Note: Several of the following cases use the default value - -- Forward for the Going parameter. - - if Unb.Index(Source => Unb.To_Unbounded_String( - "The library package Strings.Unbounded"), - Pattern => "unb", - Going => Ada.Strings.Forward, - Mapping => Map_To_Lower_Case_Ptr) /= 29 or - - Unb.Index(Unb.To_Unbounded_String( - "THE RAIN IN SPAIN FALLS MAINLY ON THE PLAIN"), - "ain", - Mapping => Map_To_Lower_Case_Ptr) /= 6 or - - Unb.Index(Unb.To_Unbounded_String("maximum number"), - "um", - Ada.Strings.Forward, - Handling.To_Lower'Access) /= 6 or - - Unb.Index(Unb.To_Unbounded_String("CoMpLeTeLy MiXeD CaSe StRiNg"), - "MIXED CASE STRING", - Ada.Strings.Forward, - Map_To_Upper_Case_Ptr) /= 12 or - - Unb.Index(Unb.To_Unbounded_String( - "STRING WITH NO MATCHING PATTERNS"), - "WITH", - Mapping => Map_To_Lower_Case_Ptr) /= 0 or - - Unb.Index(Unb.To_Unbounded_String("THIS STRING IS IN UPPER CASE"), - "IS", - Ada.Strings.Forward, - Handling.To_Upper'Access) /= 3 or - - Unb.Index(Unb.Null_Unbounded_String, - "is", - Mapping => Map_To_Lower_Case_Ptr) /= 0 or - - Unb.Index(Unb.To_Unbounded_String("AAABBBaaabbb"), - "aabb", - Mapping => Handling.To_Lower'Access) /= 2 - then - Report.Failed("Incorrect results from Function Index, going " & - "in Forward direction, using a Character Mapping " & - "Function parameter"); - end if; - - - - -- Function Index, Backward direction search. - - if Unb.Index(Unb.To_Unbounded_String("Case of a Mixed Case String"), - "case", - Ada.Strings.Backward, - Map_To_Lower_Case_Ptr) /= 17 or - - Unb.Index(Unb.To_Unbounded_String("Case of a Mixed Case String"), - "CASE", - Ada.Strings.Backward, - Mapping => Map_To_Upper_Case_Ptr) /= 17 or - - Unb.Index(Unb.To_Unbounded_String("rain, Rain, and more RAIN"), - "rain", - Ada.Strings.Backward, - Handling.To_Lower'Access) /= 22 or - - Unb.Index(Unb.To_Unbounded_String("RIGHT place, right time"), - "RIGHT", - Ada.Strings.Backward, - Handling.To_Upper'Access) /= 14 or - - Unb.Index(Unb.To_Unbounded_String("WOULD MATCH BUT FOR THE CASE"), - "WOULD MATCH BUT FOR THE CASE", - Going => Ada.Strings.Backward, - Mapping => Map_To_Lower_Case_Ptr) /= 0 - then - Report.Failed("Incorrect results from Function Index, going " & - "in Backward direction, using a Character Mapping " & - "Function parameter"); - end if; - - - - -- Function Index, Pattern_Error if Pattern = Null_String - - declare - use Unbounded; - Null_String : constant String := ""; - TC_Natural : Natural := 1000; - begin - TC_Natural := Index(To_Unbounded_String("A Valid Unbounded String"), - Null_String, - Going => Ada.Strings.Forward, - Mapping => Handling.To_Lower'Access); - Report.Failed("Pattern_Error not raised by Function Index when " & - "given a null pattern string"); - exception - when Pattern_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by Function Index " & - "using a Character Mapping Function parameter " & - "when given a null pattern string"); - end; - - - - -- Function Count. - - if Unb.Count(Source => Unb.To_Unbounded_String("ABABABA"), - Pattern => "aba", - Mapping => Map_To_Lower_Case_Ptr) /= 2 or - - Unb.Count(Unb.To_Unbounded_String("ABABABA"), - "ABA", - Mapping => Map_To_Lower_Case_Ptr) /= 0 or - - Unb.Count(Unb.To_Unbounded_String("This IS a MISmatched issue"), - "is", - Handling.To_Lower'Access) /= 4 or - - Unb.Count(Unb.To_Unbounded_String("ABABABA"), - "ABA", - Map_To_Upper_Case_Ptr) /= 2 or - - Unb.Count(Unb.To_Unbounded_String("This IS a MISmatched issue"), - "is", - Mapping => Map_To_Upper_Case_Ptr) /= 0 or - - Unb.Count(Unb.To_Unbounded_String( - "She sells sea shells by the sea shore"), - "s", - Handling.To_Lower'Access) /= 8 or - - Unb.Count(Unb.Null_Unbounded_String, - "match", - Map_To_Upper_Case_Ptr) /= 0 - then - Report.Failed("Incorrect results from Function Count, using " & - "a Character Mapping Function parameter"); - end if; - - - - -- Function Count, Pattern_Error if Pattern = Null_String - - declare - use Ada.Strings.Unbounded; - Null_Pattern_String : constant String := ""; - TC_Natural : Natural := 1000; - begin - TC_Natural := Count(To_Unbounded_String("A Valid String"), - Null_Pattern_String, - Map_To_Lower_Case_Ptr); - Report.Failed("Pattern_Error not raised by Function Count using " & - "a Character Mapping Function parameter when " & - "given a null pattern string"); - exception - when Pattern_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by Function Count " & - "using a Character Mapping Function parameter " & - "when given a null pattern string"); - end; - - - - -- Function Translate. - - if Unb.Translate(Source => Unb.To_Unbounded_String( - "A Sample Mixed Case String"), - Mapping => Map_To_Lower_Case_Ptr) /= - Unb.To_Unbounded_String("a sample mixed case string") or - - Unb.Translate(Unb.To_Unbounded_String("ALL LOWER CASE"), - Handling.To_Lower'Access) /= - Unb.To_Unbounded_String("all lower case") or - - Unb.Translate(Unb.To_Unbounded_String("end with lower case"), - Map_To_Lower_Case_Ptr) /= - Unb.To_Unbounded_String("end with lower case") or - - Unb.Translate(Unb.Null_Unbounded_String, - Handling.To_Lower'Access) /= - Unb.Null_Unbounded_String or - - Unb.Translate(Unb.To_Unbounded_String("start with lower case"), - Map_To_Upper_Case_Ptr) /= - Unb.To_Unbounded_String("START WITH LOWER CASE") or - - Unb.Translate(Unb.To_Unbounded_String("ALL UPPER CASE STRING"), - Handling.To_Upper'Access) /= - Unb.To_Unbounded_String("ALL UPPER CASE STRING") or - - Unb.Translate(Unb.To_Unbounded_String( - "LoTs Of MiXeD CaSe ChArAcTeRs"), - Map_To_Upper_Case_Ptr) /= - Unb.To_Unbounded_String("LOTS OF MIXED CASE CHARACTERS") or - - Unb.Translate(New_Character_String, - Handling.To_Upper'Access) /= - TC_New_Character_String - - then - Report.Failed("Incorrect results from Function Translate, using " & - "a Character Mapping Function parameter"); - end if; - - - - -- Procedure Translate. - - declare - - use Ada.Strings.Unbounded; - use Ada.Characters.Handling; - - Str_1 : Unbounded_String := - To_Unbounded_String("AN ALL UPPER CASE STRING"); - Str_2 : Unbounded_String := - To_Unbounded_String("A Mixed Case String"); - Str_3 : Unbounded_String := - To_Unbounded_String("a string with lower case letters"); - TC_Str_1 : constant Unbounded_String := Str_1; - TC_Str_3 : constant Unbounded_String := Str_3; - - begin - - Translate(Source => Str_1, Mapping => Map_To_Lower_Case_Ptr); - - if Str_1 /= To_Unbounded_String("an all upper case string") then - Report.Failed("Incorrect result from Procedure Translate - 1"); - end if; - - Translate(Source => Str_1, Mapping => Map_To_Upper_Case_Ptr); - - if Str_1 /= TC_Str_1 then - Report.Failed("Incorrect result from Procedure Translate - 2"); - end if; - - Translate(Str_2, Mapping => Map_To_Lower_Case_Ptr); - - if Str_2 /= To_Unbounded_String("a mixed case string") then - Report.Failed("Incorrect result from Procedure Translate - 3"); - end if; - - Translate(Str_2, Mapping => To_Upper'Access); - - if Str_2 /= To_Unbounded_String("A MIXED CASE STRING") then - Report.Failed("Incorrect result from Procedure Translate - 4"); - end if; - - Translate(Str_3, To_Lower'Access); - - if Str_3 /= TC_Str_3 then - Report.Failed("Incorrect result from Procedure Translate - 5"); - end if; - - Translate(Str_3, To_Upper'Access); - - if Str_3 /= - To_Unbounded_String("A STRING WITH LOWER CASE LETTERS") - then - Report.Failed("Incorrect result from Procedure Translate - 6"); - end if; - - Translate(New_Character_String, Map_To_Upper_Case_Ptr); - - if New_Character_String /= TC_New_Character_String then - Report.Failed("Incorrect result from Procedure Translate - 6"); - end if; - - end; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA4030; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a deleted file mode 100644 index 91bc68ce6e7..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a +++ /dev/null @@ -1,291 +0,0 @@ --- CXA4031.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 subprograms defined in package Ada.Strings.Unbounded --- are available, and that they produce correct results. Specifically, --- check the functions To_Unbounded_String (version with Length --- parameter), "=", "<", "<=", ">", ">=" (all with String-Unbounded --- String parameter mix), as well as three versions of Procedure Append. --- --- TEST DESCRIPTION: --- This test demonstrates the uses of many of the subprograms defined --- in package Ada.Strings.Unbounded for use with unbounded strings. --- The test simulates how unbounded strings could be processed in a --- user environment, using the subprograms provided in this package. --- --- This test, when taken in conjunction with tests CXA4010, CXA4011, --- CXA4030, and CXA4032 will constitute a test of all the functionality --- contained in package Ada.Strings.Unbounded. This test uses a variety --- of the subprograms defined in the unbounded string package in ways --- typical of common usage. --- --- --- CHANGE HISTORY: --- 27 Feb 95 SAIC Initial prerelease version. --- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- ---! - -with Report; -with Ada.Exceptions; -with Ada.Strings.Maps; -with Ada.Strings.Unbounded; - -procedure CXA4031 is -begin - - Report.Test ("CXA4031", "Check that the subprograms defined in " & - "package Ada.Strings.Unbounded are available, " & - "and that they produce correct results"); - - Test_Block: - declare - - package Unb renames Ada.Strings.Unbounded; - use Unb; - use Ada.Exceptions; - - subtype LC_Characters is Character range 'a'..'z'; - - Null_String : constant String := ""; - TC_String : constant String := "A Standard String"; - - TC_Unb_String, - TC_New_Unb_String : Unb.Unbounded_String := Unb.Null_Unbounded_String; - - begin - - -- Function To_Unbounded_String (version with Length parameter) - -- returns an unbounded string that represents an uninitialized String - -- whose length is Length. - -- Note: Unbounded_String length can vary conceptually between 0 and - -- Natural'Last. - - if Unb.Length(Unb.To_Unbounded_String(Length => 10)) /= 10 or - Unb.Length(Unb.To_Unbounded_String(1)) /= 1 or - Unb.Length(Unb.To_Unbounded_String(0)) /= 0 or - Unb.Length(Unb."&"(Unb.To_Unbounded_String(Length => 10), - Unb."&"(Unb.To_Unbounded_String(1), - Unb.To_Unbounded_String(0) ))) /= 10+1+0 - then - Report.Failed - ("Incorrect results from Function To_Unbounded_String with " & - "Length parameter"); - end if; - - - -- Procedure Append (Unbounded - Unbounded) - -- Note: For each of the Append procedures, the resulting string - -- represented by the Source parameter is given by the - -- concatenation of the original value of Source and the value - -- of New_Item. - - TC_Unb_String := Unb.To_Unbounded_String("Sample string of length L"); - TC_New_Unb_String := Unb.To_Unbounded_String(" and then some"); - - Unb.Append(Source => TC_Unb_String, New_Item => TC_New_Unb_String); - - if TC_Unb_String /= - Unb.To_Unbounded_String("Sample string of length L and then some") - then - Report.Failed("Incorrect results from Procedure Append with " & - "unbounded string parameters - 1"); - end if; - - - TC_Unb_String := Unb.To_Unbounded_String("Sample string of length L"); - TC_New_Unb_String := Unb.Null_Unbounded_String; - - Unb.Append(TC_Unb_String, TC_New_Unb_String); - - if TC_Unb_String /= - Unb.To_Unbounded_String("Sample string of length L") - then - Report.Failed("Incorrect results from Procedure Append with " & - "unbounded string parameters - 2"); - end if; - - - TC_Unb_String := Unb.Null_Unbounded_String; - - Unb.Append(TC_Unb_String, - Unb.To_Unbounded_String("New Unbounded String")); - - if TC_Unb_String /= - Unb.To_Unbounded_String("New Unbounded String") - then - Report.Failed("Incorrect results from Procedure Append with " & - "unbounded string parameters - 3"); - end if; - - - -- Procedure Append (Unbounded - String) - - TC_Unb_String := Unb.To_Unbounded_String("An Unbounded String and "); - - Unb.Append(Source => TC_Unb_String, New_Item => TC_String); - - if TC_Unb_String /= - Unb.To_Unbounded_String("An Unbounded String and A Standard String") - then - Report.Failed("Incorrect results from Procedure Append with " & - "an unbounded string parameter and a string " & - "parameter - 1"); - end if; - - - TC_Unb_String := Unb.To_Unbounded_String("An Unbounded String"); - - Unb.Append(TC_Unb_String, New_Item => Null_String); - - if TC_Unb_String /= - Unb.To_Unbounded_String("An Unbounded String") - then - Report.Failed("Incorrect results from Procedure Append with " & - "an unbounded string parameter and a string " & - "parameter - 2"); - end if; - - - TC_Unb_String := Unb.Null_Unbounded_String; - - Unb.Append(TC_Unb_String, TC_String); - - if TC_Unb_String /= Unb.To_Unbounded_String("A Standard String") then - Report.Failed("Incorrect results from Procedure Append with " & - "an unbounded string parameter and a string " & - "parameter - 3"); - end if; - - - -- Procedure Append (Unbounded - Character) - - TC_Unb_String := Unb.To_Unbounded_String("Lower Case = "); - - for i in LC_Characters'Range loop - Unb.Append(Source => TC_Unb_String, New_Item => LC_Characters(i)); - end loop; - - if TC_Unb_String /= - Unb.To_Unbounded_String("Lower Case = abcdefghijklmnopqrstuvwxyz") - then - Report.Failed("Incorrect results from Procedure Append with " & - "an unbounded string parameter and a character " & - "parameter - 1"); - end if; - - - TC_Unb_String := Unb.Null_Unbounded_String; - - Unb.Append(TC_Unb_String, New_Item => 'a'); - - if TC_Unb_String /= Unb.To_Unbounded_String("a") then - Report.Failed("Incorrect results from Procedure Append with " & - "an unbounded string parameter and a character " & - "parameter - 2"); - end if; - - - -- Function "=" - - TC_Unb_String := Unb.To_Unbounded_String(TC_String); - - if not (TC_Unb_String = TC_String) or -- (Unb_Str, Str) - not Unb."="("A Standard String", TC_Unb_String) or -- (Str, Unb_Str) - not ((Unb.Null_Unbounded_String = "") and -- (Unb_Str, Str) - ("Test String" = -- (Str, Unb_Str) - Unb.To_Unbounded_String("Test String"))) - then - Report.Failed("Incorrect results from function ""="" with " & - "string - unbounded string parameter combinations"); - end if; - - - -- Function "<" - - if not ("Extra Space" < Unb.To_Unbounded_String("Extra Space ") and - Unb.To_Unbounded_String("tess") < "test" and - Unb.To_Unbounded_String("best") < "test") or - Unb.Null_Unbounded_String < Null_String or - " leading blank" < Unb.To_Unbounded_String(" leading blank") or - "ending blank " < Unb.To_Unbounded_String("ending blank ") - then - Report.Failed("Incorrect results from function ""<"" with " & - "string - unbounded string parameter combinations"); - end if; - - - -- Function "<=" - - TC_Unb_String := Unb.To_Unbounded_String("Sample string"); - - if TC_Unb_String <= "Sample strin" or -- (Unb_Str, Str) - "sample string" <= TC_Unb_String or -- (Str, Unb_Str) - not(Unb.Null_Unbounded_String <= "") or -- (Unb_Str, Str) - not("Sample string" <= TC_Unb_String) -- (Str, Unb_Str) - then - Report.Failed("Incorrect results from function ""<="" with " & - "string - unbounded string parameter combinations"); - end if; - - - -- Function ">" - - TC_Unb_String := Unb.To_Unbounded_String("A MUCH LONGER STRING"); - - if not ("A much longer string" > TC_Unb_String and - Unb.To_Unbounded_String(TC_String) > "A Standard Strin" and - "abcdefgh" > Unb.To_Unbounded_String("ABCDEFGH")) or - Unb.Null_Unbounded_String > Null_String - then - Report.Failed("Incorrect results from function "">"" with " & - "string - unbounded string parameter combinations"); - end if; - - - -- Function ">=" - - TC_Unb_String := Unb.To_Unbounded_String(TC_String); - - if not (TC_Unb_String >= TC_String and - Null_String >= Unb.Null_Unbounded_String and - "test" >= Unb.To_Unbounded_String("tess") and - Unb.To_Unbounded_String("Programming") >= "PROGRAMMING") - then - Report.Failed("Incorrect results from function "">="" with " & - "string - unbounded string parameter combinations"); - end if; - - - exception - when The_Error : others => - Report.Failed ("The following exception was raised in the " & - "Test_Block: " & Exception_Name(The_Error)); - end Test_Block; - - Report.Result; - -end CXA4031; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a deleted file mode 100644 index 031d01c6cb7..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a +++ /dev/null @@ -1,457 +0,0 @@ --- CXA4032.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 procedures defined in package Ada.Strings.Unbounded --- are available, and that they produce correct results. Specifically, --- check the procedures Replace_Slice, Insert, Overwrite, Delete, --- Trim (2 versions), Head, and Tail. --- --- TEST DESCRIPTION: --- This test demonstrates the uses of many of the procedures defined --- in package Ada.Strings.Unbounded for use with unbounded strings. --- The test simulates how unbounded strings could be processed in a --- user environment, using the procedures provided in this package. --- --- This test, when taken in conjunction with tests CXA4010, CXA4011, --- CXA4030, and CXA4031 will constitute a test of all the functionality --- contained in package Ada.Strings.Unbounded. This test uses a variety --- of the procedures defined in the unbounded string package in ways --- typical of common usage. --- --- --- CHANGE HISTORY: --- 02 Mar 95 SAIC Initial prerelease version. --- ---! - -with Report; -with Ada.Strings; -with Ada.Strings.Maps; -with Ada.Strings.Maps.Constants; -with Ada.Strings.Unbounded; - -procedure CXA4032 is -begin - - Report.Test ("CXA4032", "Check that the subprograms defined in " & - "package Ada.Strings.Unbounded are available, " & - "and that they produce correct results"); - - Test_Block: - declare - - package Unb renames Ada.Strings.Unbounded; - use Unb; - use Ada.Strings; - - TC_Null_String : constant String := ""; - TC_String_5 : String(1..5) := "ABCDE"; - - TC_Unb_String : Unb.Unbounded_String := - Unb.To_Unbounded_String("Test String"); - - begin - - -- Procedure Replace_Slice - - begin -- Low > Source'Last+1 - Unb.Replace_Slice(Source => TC_Unb_String, - Low => Unb.Length(TC_Unb_String) + 2, - High => Unb.Length(TC_Unb_String), - By => TC_String_5); - Report.Failed("Index_Error not raised by Replace_Slice when Low " & - "> Source'Last+1"); - exception - when Index_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Replace_Slice" & - "when Low > Source'Last+1"); - end; - - -- High >= Low - - TC_Unb_String := Unb.To_Unbounded_String("Test String"); - - Unb.Replace_Slice(TC_Unb_String, 5, 5, TC_String_5); - - if TC_Unb_String /= Unb.To_Unbounded_String("TestABCDEString") then - Report.Failed("Incorrect results from Replace_Slice - 1"); - end if; - - Unb.Replace_Slice(TC_Unb_String, 1, 4, TC_String_5); - - if TC_Unb_String /= Unb.To_Unbounded_String("ABCDEABCDEString") then - Report.Failed("Incorrect results from Replace_Slice - 2"); - end if; - - Unb.Replace_Slice(TC_Unb_String, - 11, - Unb.Length(TC_Unb_String), - TC_Null_String); - - if TC_Unb_String /= Unb.To_Unbounded_String("ABCDEABCDE") then - Report.Failed("Incorrect results from Replace_Slice - 3"); - end if; - - -- High < Low - - Unb.Replace_Slice(TC_Unb_String, Low => 4, High => 1, By => "xxx"); - - if TC_Unb_String /= Unb.To_Unbounded_String("ABCxxxDEABCDE") then - Report.Failed("Incorrect results from Replace_Slice - 4"); - end if; - - Unb.Replace_Slice(TC_Unb_String, Low => 1, High => 0, By => "yyy"); - - if TC_Unb_String /= Unb.To_Unbounded_String("yyyABCxxxDEABCDE") then - Report.Failed("Incorrect results from Replace_Slice - 5"); - end if; - - Unb.Replace_Slice(TC_Unb_String, - Unb.Length(TC_Unb_String) + 1, - Unb.Length(TC_Unb_String), - By => "zzz"); - - if TC_Unb_String /= Unb.To_Unbounded_String("yyyABCxxxDEABCDEzzz") then - Report.Failed("Incorrect results from Replace_Slice - 6"); - end if; - - - -- Procedure Insert - - TC_Unb_String := Unb.To_Unbounded_String("Test String"); - - begin -- Before not in Source'First..Source'Last + 1 - Unb.Insert(Source => TC_Unb_String, - Before => Unb.Length(TC_Unb_String) + 2, - New_Item => TC_String_5); - Report.Failed("Index_Error not raised by Insert when Before " & - "not in the range Source'First..Source'Last+1"); - exception - when Index_Error => null; -- OK, expected exception. - when others => - Report.Failed - ("Unexpected exception raised by Insert when Before not in " & - "the range Source'First..Source'Last+1"); - end; - - Unb.Insert(TC_Unb_String, 1, "**"); - - if TC_Unb_String /= Unb.To_Unbounded_String("**Test String") then - Report.Failed("Incorrect results from Insert - 1"); - end if; - - Unb.Insert(TC_Unb_String, Unb.Length(TC_Unb_String)+1, "**"); - - if TC_Unb_String /= Unb.To_Unbounded_String("**Test String**") then - Report.Failed("Incorrect results from Insert - 2"); - end if; - - Unb.Insert(TC_Unb_String, 8, "---"); - - if TC_Unb_String /= Unb.To_Unbounded_String("**Test ---String**") then - Report.Failed("Incorrect results from Insert - 3"); - end if; - - Unb.Insert(TC_Unb_String, 3, TC_Null_String); - - if TC_Unb_String /= Unb.To_Unbounded_String("**Test ---String**") then - Report.Failed("Incorrect results from Insert - 4"); - end if; - - - -- Procedure Overwrite - - begin -- Position not in Source'First..Source'Last + 1 - Unb.Overwrite(Source => TC_Unb_String, - Position => Unb.Length(TC_Unb_String) + 2, - New_Item => TC_String_5); - Report.Failed("Index_Error not raised by Overwrite when Position " & - "not in the range Source'First..Source'Last+1"); - exception - when Index_Error => null; -- OK, expected exception. - when others => - Report.Failed - ("Unexpected exception raised by Overwrite when Position not " & - "in the range Source'First..Source'Last+1"); - end; - - TC_Unb_String := Unb.To_Unbounded_String("Test String"); - - Unb.Overwrite(Source => TC_Unb_String, - Position => 1, - New_Item => "XXXX"); - - if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String") then - Report.Failed("Incorrect results from Overwrite - 1"); - end if; - - Unb.Overwrite(TC_Unb_String, Unb.Length(TC_Unb_String)+1, "**"); - - if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String**") then - Report.Failed("Incorrect results from Overwrite - 2"); - end if; - - Unb.Overwrite(TC_Unb_String, 3, TC_Null_String); - - if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String**") then - Report.Failed("Incorrect results from Overwrite - 3"); - end if; - - Unb.Overwrite(TC_Unb_String, 1, "abcdefghijklmn"); - - if TC_Unb_String /= Unb.To_Unbounded_String("abcdefghijklmn") then - Report.Failed("Incorrect results from Overwrite - 4"); - end if; - - - -- Procedure Delete - - TC_Unb_String := Unb.To_Unbounded_String("Test String"); - - -- From > Through (No change to Source) - - Unb.Delete(Source => TC_Unb_String, - From => Unb.Length(TC_Unb_String), - Through => Unb.Length(TC_Unb_String)-1); - - if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then - Report.Failed("Incorrect results from Delete - 1"); - end if; - - Unb.Delete(TC_Unb_String, 1, 0); - - if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then - Report.Failed("Incorrect results from Delete - 2"); - end if; - - -- From <= Through - - Unb.Delete(TC_Unb_String, 1, 5); - - if TC_Unb_String /= Unb.To_Unbounded_String("String") then - Report.Failed("Incorrect results from Delete - 3"); - end if; - - Unb.Delete(TC_Unb_String, 3, 3); - - if TC_Unb_String /= Unb.To_Unbounded_String("Sting") then - Report.Failed("Incorrect results from Delete - 4"); - end if; - - - -- Procedure Trim - - TC_Unb_String := Unb.To_Unbounded_String("No Spaces"); - - Unb.Trim(Source => TC_Unb_String, Side => Ada.Strings.Both); - - if TC_Unb_String /= Unb.To_Unbounded_String("No Spaces") then - Report.Failed("Incorrect results from Trim - 1"); - end if; - - TC_Unb_String := Unb.To_Unbounded_String(" Leading Spaces "); - - Unb.Trim(TC_Unb_String, Ada.Strings.Left); - - if TC_Unb_String /= Unb.To_Unbounded_String("Leading Spaces ") then - Report.Failed("Incorrect results from Trim - 2"); - end if; - - TC_Unb_String := Unb.To_Unbounded_String(" Ending Spaces "); - - Unb.Trim(TC_Unb_String, Ada.Strings.Right); - - if TC_Unb_String /= Unb.To_Unbounded_String(" Ending Spaces") then - Report.Failed("Incorrect results from Trim - 3"); - end if; - - TC_Unb_String := - Unb.To_Unbounded_String(" Spaces on both ends "); - - Unb.Trim(TC_Unb_String, Ada.Strings.Both); - - if TC_Unb_String /= - Unb.To_Unbounded_String("Spaces on both ends") - then - Report.Failed("Incorrect results from Trim - 4"); - end if; - - - -- Procedure Trim (with Character Set parameters) - - TC_Unb_String := Unb.To_Unbounded_String("lowerCASEletters"); - - Unb.Trim(Source => TC_Unb_String, - Left => Ada.Strings.Maps.Constants.Lower_Set, - Right => Ada.Strings.Maps.Constants.Lower_Set); - - if TC_Unb_String /= Unb.To_Unbounded_String("CASE") then - Report.Failed("Incorrect results from Trim with Sets - 1"); - end if; - - TC_Unb_String := Unb.To_Unbounded_String("lowerCASEletters"); - - Unb.Trim(TC_Unb_String, - Ada.Strings.Maps.Constants.Upper_Set, - Ada.Strings.Maps.Constants.Upper_Set); - - if TC_Unb_String /= Unb.To_Unbounded_String("lowerCASEletters") then - Report.Failed("Incorrect results from Trim with Sets - 2"); - end if; - - TC_Unb_String := Unb.To_Unbounded_String("012abcdefghGFEDCBA789ab"); - - Unb.Trim(TC_Unb_String, - Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set, - Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set); - - if TC_Unb_String /= Unb.To_Unbounded_String("ghG") then - Report.Failed("Incorrect results from Trim with Sets - 3"); - end if; - - - -- Procedure Head - - -- Count <= Source'Length - - TC_Unb_String := Unb.To_Unbounded_String("Test String"); - - Unb.Head(Source => TC_Unb_String, - Count => 0, - Pad => '*'); - - if TC_Unb_String /= Unb.Null_Unbounded_String then - Report.Failed("Incorrect results from Head - 1"); - end if; - - TC_Unb_String := Unb.To_Unbounded_String("Test String"); - - Unb.Head(Source => TC_Unb_String, - Count => 4, - Pad => '*'); - - if TC_Unb_String /= Unb.To_Unbounded_String("Test") then - Report.Failed("Incorrect results from Head - 2"); - end if; - - TC_Unb_String := Unb.To_Unbounded_String("Test String"); - - Unb.Head(Source => TC_Unb_String, - Count => Unb.Length(TC_Unb_String), - Pad => '*'); - - if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then - Report.Failed("Incorrect results from Head - 3"); - end if; - - -- Count > Source'Length - - TC_Unb_String := Unb.To_Unbounded_String("Test String"); - - Unb.Head(Source => TC_Unb_String, - Count => Unb.Length(TC_Unb_String) + 4, - Pad => '*'); - - if TC_Unb_String /= Unb.To_Unbounded_String("Test String****") then - Report.Failed("Incorrect results from Head - 4"); - end if; - - TC_Unb_String := Unb.Null_Unbounded_String; - - Unb.Head(Source => TC_Unb_String, - Count => Unb.Length(TC_Unb_String) + 3, - Pad => '*'); - - if TC_Unb_String /= Unb.To_Unbounded_String("***") then - Report.Failed("Incorrect results from Head - 5"); - end if; - - - -- Procedure Tail - - -- Count <= Source'Length - - TC_Unb_String := Unb.To_Unbounded_String("Test String"); - - Unb.Tail(Source => TC_Unb_String, - Count => 0, - Pad => '*'); - - if TC_Unb_String /= Unb.Null_Unbounded_String then - Report.Failed("Incorrect results from Tail - 1"); - end if; - - TC_Unb_String := Unb.To_Unbounded_String("Test String"); - - Unb.Tail(Source => TC_Unb_String, - Count => 6, - Pad => '*'); - - if TC_Unb_String /= Unb.To_Unbounded_String("String") then - Report.Failed("Incorrect results from Tail - 2"); - end if; - - TC_Unb_String := Unb.To_Unbounded_String("Test String"); - - Unb.Tail(Source => TC_Unb_String, - Count => Unb.Length(TC_Unb_String), - Pad => '*'); - - if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then - Report.Failed("Incorrect results from Tail - 3"); - end if; - - -- Count > Source'Length - - TC_Unb_String := Unb.To_Unbounded_String("Test String"); - - Unb.Tail(Source => TC_Unb_String, - Count => Unb.Length(TC_Unb_String) + 5, - Pad => 'x'); - - if TC_Unb_String /= Unb.To_Unbounded_String("xxxxxTest String") then - Report.Failed("Incorrect results from Tail - 4"); - end if; - - TC_Unb_String := Unb.Null_Unbounded_String; - - Unb.Tail(Source => TC_Unb_String, - Count => Unb.Length(TC_Unb_String) + 3, - Pad => 'X'); - - if TC_Unb_String /= Unb.To_Unbounded_String("XXX") then - Report.Failed("Incorrect results from Tail - 5"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA4032; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a deleted file mode 100644 index 8f39b4cff05..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a +++ /dev/null @@ -1,405 +0,0 @@ --- CXA4033.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 functionality found in packages Ada.Strings.Wide_Maps, --- Ada.Strings.Wide_Unbounded, and Ada.Strings.Wide_Maps.Wide_Constants --- is available and produces correct results. --- --- TEST DESCRIPTION: --- This test tests the subprograms found in the --- Ada.Strings.Wide_Unbounded package. It is based on the tests --- CXA4030-32, which are tests for the complementary "non-wide" --- packages. --- --- The functions found in CXA4033_0 provide mapping capability, when --- used in conjunction with Wide_Character_Mapping_Function objects. --- --- --- CHANGE HISTORY: --- 23 Jun 95 SAIC Initial prerelease version. --- 24 Feb 97 PWB.CTA Removed attempt to create wide string of length --- Natural'Last ---! - -package CXA4033_0 is - -- Functions used to supply mapping capability. - function Map_To_Lower_Case (From : Wide_Character) return Wide_Character; - function Map_To_Upper_Case (From : Wide_Character) return Wide_Character; -end CXA4033_0; - -with Ada.Characters.Handling; -package body CXA4033_0 is - -- Function Map_To_Lower_Case will return the lower case form of - -- Wide_Characters in the range 'A'..'Z' only, and return the input - -- wide_character otherwise. - - function Map_To_Lower_Case (From : Wide_Character) - return Wide_Character is - begin - return Ada.Characters.Handling.To_Wide_Character( - Ada.Characters.Handling.To_Lower( - Ada.Characters.Handling.To_Character(From))); - end Map_To_Lower_Case; - - -- Function Map_To_Upper_Case will return the upper case form of - -- Wide_Characters in the range 'a'..'z', or whose position is in one - -- of the ranges 223..246 or 248..255, provided the wide_character has - -- an upper case form. - - function Map_To_Upper_Case (From : Wide_Character) - return Wide_Character is - begin - return Ada.Characters.Handling.To_Wide_Character( - Ada.Characters.Handling.To_Upper( - Ada.Characters.Handling.To_Character(From))); - end Map_To_Upper_Case; - -end CXA4033_0; - - -with CXA4033_0; -with Report; -with Ada.Characters.Handling; -with Ada.Characters.Latin_1; -with Ada.Strings; -with Ada.Strings.Wide_Maps; -with Ada.Strings.Wide_Maps.Wide_Constants; -with Ada.Strings.Wide_Fixed; -with Ada.Strings.Wide_Unbounded; - -procedure CXA4033 is -begin - Report.Test ("CXA4033", - "Check that subprograms defined in the package " & - "Ada.Strings.Wide_Unbounded produce correct results"); - - Test_Block: - declare - - package ACL1 renames Ada.Characters.Latin_1; - package Unb renames Ada.Strings.Wide_Unbounded; - - subtype LC_Characters is Wide_Character range 'a'..'z'; - - use Ada.Characters, Ada.Strings, Unb; - use type Wide_Maps.Wide_Character_Set; - - TC_String : constant Wide_String := "A Standard String"; - - String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST"; - String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" & - String_20; - String_80 : Wide_String(1..80) := String_40 & String_40; - TC_String_5 : Wide_String(1..5) := "ABCDE"; - TC_Unb_String : Unbounded_Wide_String := Null_Unbounded_Wide_String; - - -- The following strings are used in examination of the Translation - -- subprograms. - New_Character_String : Wide_String(1..10) := - Handling.To_Wide_String( - ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong & - ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex & - ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde & - ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn); - - TC_New_Character_String : Wide_String(1..10) := - Handling.To_Wide_String( - ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong & - ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex & - ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde & - ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn); - - New_UB_Character_String : Unbounded_Wide_String := - To_Unbounded_Wide_String(New_Character_String); - - TC_New_UB_Character_String : Unbounded_Wide_String := - To_Unbounded_Wide_String(TC_New_Character_String); - - -- Access objects that will be provided as parameters to the - -- subprograms. - Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := - CXA4033_0.Map_To_Lower_Case'Access; - Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := - CXA4033_0.Map_To_Upper_Case'Access; - - begin - - -- Testing functionality found in Package Ada.Strings.Wide_Unbounded. - -- - -- Function Index. - - if Index(To_Unbounded_Wide_String("AAABBBaaabbb"), - "aabb", - Mapping => Map_To_Lower_Case_Ptr) /= 2 or - Index(To_Unbounded_Wide_String("Case of a Mixed Case String"), - "case", - Ada.Strings.Backward, - Map_To_Lower_Case_Ptr) /= 17 - then - Report.Failed("Incorrect results from Function Index, " & - "using a Wide Character Mapping Function parameter"); - end if; - - -- Function Count. - if Count(Source => To_Unbounded_Wide_String("ABABABA"), - Pattern => "aba", - Mapping => Map_To_Lower_Case_Ptr) /= 2 or - Count(Null_Unbounded_Wide_String, "mat", Map_To_Upper_Case_Ptr) /= 0 - then - Report.Failed("Incorrect results from Function Count, using " & - "a Character Mapping Function parameter"); - end if; - - -- Function Translate. - if Translate(To_Unbounded_Wide_String("A Sample Mixed Case String"), - Mapping => Map_To_Lower_Case_Ptr) /= - To_Unbounded_Wide_String("a sample mixed case string") or - Translate(New_UB_Character_String, Map_To_Upper_Case_Ptr) /= - TC_New_UB_Character_String - then - Report.Failed("Incorrect results from Function Translate, " & - "using a Character Mapping Function parameter"); - end if; - - -- Procedure Translate. - declare - use Ada.Characters.Handling; - Str : Unbounded_Wide_String := - To_Unbounded_Wide_String("AN ALL UPPER CASE STRING"); - begin - Translate(Source => Str, Mapping => Map_To_Lower_Case_Ptr); - if Str /= To_Unbounded_Wide_String("an all upper case string") then - Report.Failed("Incorrect result from Procedure Translate 1"); - end if; - - Translate(New_UB_Character_String, Map_To_Upper_Case_Ptr); - if New_UB_Character_String /= TC_New_UB_Character_String then - Report.Failed("Incorrect result from Procedure Translate 2"); - end if; - end; - - -- Function To_Unbounded_Wide_String (version with Length parameter) - if Length(To_Unbounded_Wide_String(Length => 10)) /= 10 or - Length(To_Unbounded_Wide_String(0)) /= 0 or - Length( To_Unbounded_Wide_String(10) & - To_Unbounded_Wide_String(1) & - To_Unbounded_Wide_String(0) ) /= 10 + 1 + 0 - then - Report.Failed - ("Incorrect results from Function To_Unbounded_Wide_String " & - "with Length parameter"); - end if; - - -- Procedure Append (Wide_Unbounded - Wide_Unbounded) - TC_Unb_String := Null_Unbounded_Wide_String; - Append(TC_Unb_String, To_Unbounded_Wide_String("New Unbounded String")); - if TC_Unb_String /= To_Unbounded_Wide_String("New Unbounded String") - then - Report.Failed("Incorrect results from Procedure Append with " & - "unbounded wide string parameters"); - end if; - - - -- Procedure Append (Wide_Unbounded - Wide_String) - TC_Unb_String := To_Unbounded_Wide_String("An Unbounded String and "); - Append(Source => TC_Unb_String, New_Item => TC_String); - if TC_Unb_String /= - To_Unbounded_Wide_String("An Unbounded String and A Standard String") - then - Report.Failed("Incorrect results from Procedure Append with " & - "an unbounded wide string parameter and a wide " & - "string parameter"); - end if; - - -- Procedure Append (Wide_Unbounded - Wide_Character) - TC_Unb_String := To_Unbounded_Wide_String("Lower Case = "); - for i in LC_Characters'Range loop - Append(Source => TC_Unb_String, New_Item => LC_Characters(i)); - end loop; - if TC_Unb_String /= - Unb.To_Unbounded_Wide_String - ("Lower Case = abcdefghijklmnopqrstuvwxyz") - then - Report.Failed("Incorrect results from Procedure Append with " & - "an unbounded wide string parameter and a wide " & - "character parameter"); - end if; - - -- Function "=" - TC_Unb_String := To_Unbounded_Wide_String(TC_String); - if not (TC_Unb_String = TC_String) or - not "="("A Standard String", TC_Unb_String) or - not ((Null_Unbounded_Wide_String = "") and - ("Test String" = To_Unbounded_Wide_String("Test String"))) - then - Report.Failed("Incorrect results from Function ""="" with " & - "wide_string - unbounded wide string parameters"); - end if; - - -- Function "<" - if not ("Extra Space" < To_Unbounded_Wide_String("Extra Space ") and - To_Unbounded_Wide_String("tess") < "test" and - To_Unbounded_Wide_String("best") < "test") - then - Report.Failed("Incorrect results from Function ""<"" with " & - "wide string - unbounded wide string parameters"); - end if; - - -- Function "<=" - TC_Unb_String := To_Unbounded_Wide_String("Sample string"); - if TC_Unb_String <= "Sample strin" or - not("Sample string" <= TC_Unb_String) - then - Report.Failed("Incorrect results from Function ""<="" with " & - "wide string - unbounded wide string parameters"); - end if; - - -- Function ">" - TC_Unb_String := To_Unbounded_Wide_String("A MUCH LONGER STRING"); - if not ("A much longer string" > TC_Unb_String and - To_Unbounded_Wide_String(TC_String) > "A Standard Strin" and - "abcdefgh" > To_Unbounded_Wide_String("ABCDEFGH")) - then - Report.Failed("Incorrect results from Function "">"" with " & - "wide string - unbounded wide string parameters"); - end if; - - -- Function ">=" - TC_Unb_String := To_Unbounded_Wide_String(TC_String); - if not (TC_Unb_String >= TC_String and - "test" >= To_Unbounded_Wide_String("tess") and - To_Unbounded_Wide_String("Programming") >= "PROGRAMMING") - then - Report.Failed("Incorrect results from Function "">="" with " & - "wide string - unbounded wide string parameters"); - end if; - - -- Procedure Replace_Slice - TC_Unb_String := To_Unbounded_Wide_String("Test String"); - Replace_Slice(TC_Unb_String, 5, 5, TC_String_5); - if TC_Unb_String /= To_Unbounded_Wide_String("TestABCDEString") then - Report.Failed("Incorrect results from Replace_Slice - 1"); - end if; - - Replace_Slice(TC_Unb_String, 1, 4, TC_String_5); - if TC_Unb_String /= To_Unbounded_Wide_String("ABCDEABCDEString") then - Report.Failed("Incorrect results from Replace_Slice - 2"); - end if; - - -- Procedure Insert - TC_Unb_String := To_Unbounded_Wide_String("Test String"); - Insert(TC_Unb_String, 1, "**"); - if TC_Unb_String /= To_Unbounded_Wide_String("**Test String") then - Report.Failed("Incorrect results from Procedure Insert - 1"); - end if; - - Insert(TC_Unb_String, Length(TC_Unb_String)+1, "**"); - if TC_Unb_String /= To_Unbounded_Wide_String("**Test String**") then - Report.Failed("Incorrect results from Procedure Insert - 2"); - end if; - - -- Procedure Overwrite - TC_Unb_String := To_Unbounded_Wide_String("Test String"); - Overwrite(TC_Unb_String, 1, New_Item => "XXXX"); - if TC_Unb_String /= To_Unbounded_Wide_String("XXXX String") then - Report.Failed("Incorrect results from Procedure Overwrite - 1"); - end if; - - Overwrite(TC_Unb_String, Length(TC_Unb_String)+1, "**"); - if TC_Unb_String /= To_Unbounded_Wide_String("XXXX String**") then - Report.Failed("Incorrect results from Procedure Overwrite - 2"); - end if; - - -- Procedure Delete - TC_Unb_String := To_Unbounded_Wide_String("Test String"); - Delete(TC_Unb_String, 1, 0); - if TC_Unb_String /= To_Unbounded_Wide_String("Test String") then - Report.Failed("Incorrect results from Procedure Delete - 1"); - end if; - - Delete(TC_Unb_String, 1, 5); - if TC_Unb_String /= To_Unbounded_Wide_String("String") then - Report.Failed("Incorrect results from Procedure Delete - 2"); - end if; - - -- Procedure Trim - TC_Unb_String := To_Unbounded_Wide_String(" Leading Spaces "); - Trim(TC_Unb_String, Ada.Strings.Left); - if TC_Unb_String /= To_Unbounded_Wide_String("Leading Spaces ") then - Report.Failed("Incorrect results from Procedure Trim - 1"); - end if; - - TC_Unb_String := - To_Unbounded_Wide_String(" Spaces on both ends "); - Trim(TC_Unb_String, Ada.Strings.Both); - if TC_Unb_String /= - To_Unbounded_Wide_String("Spaces on both ends") - then - Report.Failed("Incorrect results from Procedure Trim - 2"); - end if; - - -- Procedure Trim (with Wide_Character_Set parameters) - TC_Unb_String := To_Unbounded_Wide_String("012abcdefghGFEDCBA789ab"); - Trim(TC_Unb_String, - Ada.Strings.Wide_Maps.Wide_Constants.Hexadecimal_Digit_Set, - Ada.Strings.Wide_Maps.Wide_Constants.Hexadecimal_Digit_Set); - if TC_Unb_String /= To_Unbounded_Wide_String("ghG") then - Report.Failed("Incorrect results from Procedure Trim with Sets"); - end if; - - -- Procedure Head - TC_Unb_String := To_Unbounded_Wide_String("Test String"); - Head(Source => TC_Unb_String, Count => 0, Pad => '*'); - if TC_Unb_String /= Null_Unbounded_Wide_String then - Report.Failed("Incorrect results from Procedure Head - 1"); - end if; - - TC_Unb_String := To_Unbounded_Wide_String("Test String"); - Head(Source => TC_Unb_String, Count => 4, Pad => '*'); - if TC_Unb_String /= To_Unbounded_Wide_String("Test") then - Report.Failed("Incorrect results from Procedure Head - 2"); - end if; - - -- Procedure Tail - TC_Unb_String := To_Unbounded_Wide_String("Test String"); - Tail(Source => TC_Unb_String, Count => 0, Pad => '*'); - if TC_Unb_String /= Null_Unbounded_Wide_String then - Report.Failed("Incorrect results from Procedure Tail - 1"); - end if; - - TC_Unb_String := To_Unbounded_Wide_String("Test String"); - Tail(TC_Unb_String, Length(TC_Unb_String) + 5, 'x'); - if TC_Unb_String /= To_Unbounded_Wide_String("xxxxxTest String") then - Report.Failed("Incorrect results from Procedure Tail - 2"); - end if; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA4033; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a deleted file mode 100644 index a1ed53de0f7..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a +++ /dev/null @@ -1,281 +0,0 @@ --- CXA4034.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 Ada.Strings.Bounded.Slice raises Index_Error if --- High > Length (Source) or Low > Length (Source) + 1. --- (Defect Report 8652/0049). --- --- Check that Ada.Strings.Wide_Bounded.Slice raises Index_Error if --- High > Length (Source) or Low > Length (Source) + 1. --- --- CHANGE HISTORY: --- 12 FEB 2001 PHL Initial version --- 14 MAR 2001 RLB Added Wide_Bounded subtest. --- ---! -with Ada.Exceptions; -use Ada.Exceptions; -with Ada.Strings.Bounded; -with Ada.Strings.Wide_Bounded; -use Ada.Strings; -with Report; -use Report; -procedure CXA4034 is - - package Bs is new Ada.Strings.Bounded.Generic_Bounded_Length (40); - - package WBs is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length (32); - - Source : String (Ident_Int (1) .. Ident_Int (30)); - - Wide_Source : Wide_String (Ident_Int (1) .. Ident_Int (24)); - - X : Bs.Bounded_String; - - WX : WBs.Bounded_Wide_String; - -begin - Test ("CXA4034", - "Check that Slice raises Index_Error if either Low or High is " & - "greater than the Length(Source) for Ada.Strings.Bounded and " & - "Ada.Strings.Wide_Bounded"); - - -- Fill Source with "ABC..." - for I in Source'Range loop - Source (I) := Ident_Char (Character'Val (I + - Character'Pos ('A') - Source'First)); - end loop; - -- and W with "ABC..." - for I in Wide_Source'Range loop - Wide_Source (I) := Ident_Wide_Char (Wide_Character'Val (I + - Wide_Character'Pos ('A') - Wide_Source'First)); - end loop; - - X := Bs.To_Bounded_String (Source); - - begin - declare - S : constant String := - Bs.Slice (X, Low => Ident_Int (28), High => Ident_Int (41)); - begin - Failed ("No exception raised by Slice - 1"); - if S = Source then - Comment ("Don't optimize S"); - end if; - end; - exception - when Index_Error => - null; -- Expected exception. - when E: others => - Failed ("Exception raised - " & Exception_Name (E) & - " - " & Exception_Message (E) & " - 1"); - end; - - begin - declare - S : constant String := - Bs.Slice (X, Low => Ident_Int (8), High => Ident_Int (31)); - begin - Failed ("No exception raised by Slice - 2"); - if S = Source then - Comment ("Don't optimize S"); - end if; - end; - exception - when Index_Error => - null; -- Expected exception. - when E: others => - Failed ("Exception raised - " & Exception_Name (E) & - " - " & Exception_Message (E) & " - 2"); - end; - - begin - declare - S : constant String := - Bs.Slice (X, Low => Ident_Int (15), High => Ident_Int (30)); - begin - if S /= Source(15..30) then - Failed ("Wrong result - 3"); - end if; - end; - exception - when E: others => - Failed ("Exception raised - " & Exception_Name (E) & - " - " & Exception_Message (E) & " - 3"); - end; - - begin - declare - S : constant String := - Bs.Slice (X, Low => Ident_Int (42), High => Ident_Int (28)); - begin - Failed ("No exception raised by Slice - 4"); - if S = Source then - Comment ("Don't optimize S"); - end if; - end; - exception - when Index_Error => - null; -- Expected exception. - when E: others => - Failed ("Exception raised - " & Exception_Name (E) & - " - " & Exception_Message (E) & " - 4"); - end; - - begin - declare - S : constant String := - Bs.Slice (X, Low => Ident_Int (31), High => Ident_Int (28)); - begin - if S /= "" then - Failed ("Wrong result - 5"); - end if; - end; - exception - when E: others => - Failed ("Exception raised - " & Exception_Name (E) & - " - " & Exception_Message (E) & " - 5"); - end; - - begin - declare - S : constant String := - Bs.Slice (X, Low => Ident_Int (30), High => Ident_Int (30)); - begin - if S /= Source(30..30) then - Failed ("Wrong result - 6"); - end if; - end; - exception - when E: others => - Failed ("Exception raised - " & Exception_Name (E) & - " - " & Exception_Message (E) & " - 6"); - end; - - WX := WBs.To_Bounded_Wide_String (Wide_Source); - - begin - declare - W : constant Wide_String := - WBs.Slice (WX, Low => Ident_Int (21), High => Ident_Int (33)); - begin - Failed ("No exception raised by Slice - 7"); - if W = Wide_Source then - Comment ("Don't optimize W"); - end if; - end; - exception - when Index_Error => - null; -- Expected exception. - when E: others => - Failed ("Exception raised - " & Exception_Name (E) & - " - " & Exception_Message (E) & " - 7"); - end; - - begin - declare - W : constant Wide_String := - WBs.Slice (WX, Low => Ident_Int (8), High => Ident_Int (25)); - begin - Failed ("No exception raised by Slice - 8"); - if W = Wide_Source then - Comment ("Don't optimize W"); - end if; - end; - exception - when Index_Error => - null; -- Expected exception. - when E: others => - Failed ("Exception raised - " & Exception_Name (E) & - " - " & Exception_Message (E) & " - 8"); - end; - - begin - declare - W : constant Wide_String := - WBs.Slice (WX, Low => Ident_Int (15), High => Ident_Int (24)); - begin - if W /= Wide_Source(15..24) then - Failed ("Wrong result - 8"); - end if; - end; - exception - when E: others => - Failed ("Exception raised - " & Exception_Name (E) & - " - " & Exception_Message (E) & " - 9"); - end; - - begin - declare - W : constant Wide_String := - WBs.Slice (WX, Low => Ident_Int (36), High => Ident_Int (20)); - begin - Failed ("No exception raised by Slice - 10"); - if W = Wide_Source then - Comment ("Don't optimize W"); - end if; - end; - exception - when Index_Error => - null; -- Expected exception. - when E: others => - Failed ("Exception raised - " & Exception_Name (E) & - " - " & Exception_Message (E) & " - 10"); - end; - - begin - declare - W : constant Wide_String := - WBs.Slice (WX, Low => Ident_Int (25), High => Ident_Int (21)); - begin - if W /= "" then - Failed ("Wrong result - 11"); - end if; - end; - exception - when E: others => - Failed ("Exception raised - " & Exception_Name (E) & - " - " & Exception_Message (E) & " - 11"); - end; - - begin - declare - W : constant Wide_String := - WBs.Slice (WX, Low => Ident_Int (24), High => Ident_Int (24)); - begin - if W /= Wide_Source(24..24) then - Failed ("Wrong result - 12"); - end if; - end; - exception - when E: others => - Failed ("Exception raised - " & Exception_Name (E) & - " - " & Exception_Message (E) & " - 12"); - end; - - Result; -end CXA4034; - diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a deleted file mode 100644 index c9a007e524f..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a +++ /dev/null @@ -1,471 +0,0 @@ --- CXA5011.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, for both Float_Random and Discrete_Random packages, --- the following are true: --- 1) two objects of type Generator are initialized to the same state. --- 2) when the Function Reset is used to reset two generators --- to different time-dependent states, the resulting random values --- from each generator are different. --- 3) when the Function Reset uses the same integer initiator --- to reset two generators to the same state, the resulting random --- values from each generator are identical. --- 4) when the Function Reset uses different integer initiator --- values to reset two generators, the resulting random numbers are --- different. --- --- TEST DESCRIPTION: --- This test evaluates components of the Ada.Numerics.Float_Random and --- Ada.Numerics.Discrete_Random packages. --- This test checks to see that objects of type Generator are initialized --- to the same state. In addition, the functionality of Function Reset is --- validated. --- For each of the objectives above, evaluation of the various generators --- is performed using each of the following techniques. When the states of --- two generators are to be compared, each state is saved, then --- transformed to a bounded-string variable. The bounded-strings can --- then be compared for equality. In this case, matching bounded-strings --- are evidence that the states of two generators are the same. --- In addition, two generators are compared by evaluating a series of --- random numbers they produce. A matching series of random numbers --- implies that the generators were in the same state prior to producing --- the numbers. --- --- --- CHANGE HISTORY: --- 20 Apr 95 SAIC Initial prerelease version. --- 07 Jul 95 SAIC Incorporated reviewer comments/suggestions. --- 22 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- 17 Aug 96 SAIC Deleted Subtest #2. --- 09 Feb 01 RLB Repaired to work on implementations with a 16-bit --- Integer. - ---! - -with Ada.Exceptions; -with Ada.Numerics.Float_Random; -with Ada.Numerics.Discrete_Random; -with Ada.Strings.Bounded; -with ImpDef; -with Report; - -procedure CXA5011 is -begin - - Report.Test ("CXA5011", "Check the effect of Function Reset on the " & - "state of random number generators"); - - Test_Block: - declare - - use Ada.Exceptions; - use Ada.Numerics; - use Ada.Strings.Bounded; - - -- Declare an modular subtype, and use it to instantiate the discrete - -- random number generator generic package. - - type Discrete_Range is mod 2**(Integer'Size-1); - package Discrete_Package is new Discrete_Random(Discrete_Range); - - -- Declaration of random number generator objects. - - Discrete_Generator_1, - Discrete_Generator_2 : Discrete_Package.Generator; - Float_Generator_1, - Float_Generator_2 : Float_Random.Generator; - - -- Declaration of bounded string packages instantiated with the - -- value of Max_Image_Width constant from each random number generator - -- package, and bounded string variables used to hold the image of - -- random number generator states. - - package Discrete_String_Pack is - new Generic_Bounded_Length(Discrete_Package.Max_Image_Width); - - package Float_String_Pack is - new Generic_Bounded_Length(Float_Random.Max_Image_Width); - - use Discrete_String_Pack, Float_String_Pack; - - TC_Seed : Integer; - TC_Max_Loop_Count : constant Natural := 1000; - Allowed_Matches : constant Natural := 2; - -- - -- In a sequence of TC_Max_Loop_Count random numbers that should - -- not match, some may match by chance. Up to Allowed_Matches - -- numbers may match before the test is considered to fail. - -- - - - procedure Check_Float_State (Gen_1, Gen_2 : Float_Random.Generator; - Sub_Test : Integer; - States_Should_Match : Boolean) is - - use type Float_Random.State; - - State_1, - State_2 : Float_Random.State; - - State_String_1, - State_String_2 : Float_String_Pack.Bounded_String := - Float_String_Pack.Null_Bounded_String; - begin - - Float_Random.Save(Gen => Gen_1, To_State => State_1); - Float_Random.Save(Gen_2, State_2); - - State_String_1 := - Float_String_Pack.To_Bounded_String(Source => - Float_Random.Image(Of_State => State_1)); - - State_String_2 := - Float_String_Pack.To_Bounded_String(Float_Random.Image(State_2)); - - case States_Should_Match is - when True => - if State_1 /= State_2 then - Report.Failed("Subtest #" & Integer'Image(Sub_Test) & - " State values from Float generators " & - "are not the same"); - end if; - if State_String_1 /= State_String_2 then - Report.Failed("Subtest #" & Integer'Image(Sub_Test) & - " State strings from Float generators " & - "are not the same"); - end if; - when False => - if State_1 = State_2 then - Report.Failed("Subtest #" & Integer'Image(Sub_Test) & - " State values from Float generators " & - "are the same"); - end if; - if State_String_1 = State_String_2 then - Report.Failed("Subtest #" & Integer'Image(Sub_Test) & - " State strings from Float generators " & - "are the same"); - end if; - end case; - end Check_Float_State; - - - - procedure Check_Discrete_State (Gen_1, - Gen_2 : Discrete_Package.Generator; - Sub_Test : Integer; - States_Should_Match : Boolean) is - - use type Discrete_Package.State; - - State_1, State_2 : Discrete_Package.State; - - State_String_1, - State_String_2 : Discrete_String_Pack.Bounded_String := - Discrete_String_Pack.Null_Bounded_String; - begin - - Discrete_Package.Save(Gen => Gen_1, - To_State => State_1); - Discrete_Package.Save(Gen_2, To_State => State_2); - - State_String_1 := - Discrete_String_Pack.To_Bounded_String(Source => - Discrete_Package.Image(Of_State => State_1)); - - State_String_2 := - Discrete_String_Pack.To_Bounded_String(Source => - Discrete_Package.Image(Of_State => State_2)); - - case States_Should_Match is - when True => - if State_1 /= State_2 then - Report.Failed("Subtest #" & Integer'Image(Sub_Test) & - " State values from Discrete " & - "generators are not the same"); - end if; - if State_String_1 /= State_String_2 then - Report.Failed("Subtest #" & Integer'Image(Sub_Test) & - " State strings from Discrete " & - "generators are not the same"); - end if; - when False => - if State_1 = State_2 then - Report.Failed("Subtest #" & Integer'Image(Sub_Test) & - " State values from Discrete " & - "generators are the same"); - end if; - if State_String_1 = State_String_2 then - Report.Failed("Subtest #" & Integer'Image(Sub_Test) & - " State strings from Discrete " & - "generators are the same"); - end if; - end case; - end Check_Discrete_State; - - - - procedure Check_Float_Values (Gen_1, Gen_2 : Float_Random.Generator; - Sub_Test : Integer; - Values_Should_Match : Boolean) is - Matches : Natural := 0; - Check_Failed : Boolean := False; - begin - case Values_Should_Match is - when True => - for i in 1..TC_Max_Loop_Count loop - if Float_Random.Random(Gen_1) /= Float_Random.Random(Gen_2) - then - Check_Failed := True; - exit; - end if; - end loop; - if Check_Failed then - Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) & - " Random numbers from Float generators " & - "Failed check"); - end if; - when False => - for i in 1..TC_Max_Loop_Count loop - if Float_Random.Random(Gen_1) = Float_Random.Random(Gen_2) - then - Matches := Matches + 1; - end if; - end loop; - end case; - - if (Values_Should_Match and Check_Failed) or - (not Values_Should_Match and Matches > Allowed_Matches) - then - Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) & - " Random numbers from Float generators " & - "Failed check"); - end if; - - end Check_Float_Values; - - - - procedure Check_Discrete_Values (Gen_1, - Gen_2 : Discrete_Package.Generator; - Sub_Test : Integer; - Values_Should_Match : Boolean) is - Matches : Natural := 0; - Check_Failed : Boolean := False; - begin - case Values_Should_Match is - when True => - for i in 1..TC_Max_Loop_Count loop - if Discrete_Package.Random(Gen_1) /= - Discrete_Package.Random(Gen_2) - then - Check_Failed := True; - exit; - end if; - end loop; - when False => - for i in 1..TC_Max_Loop_Count loop - if Discrete_Package.Random(Gen_1) = - Discrete_Package.Random(Gen_2) - then - Matches := Matches + 1; - end if; - end loop; - end case; - - if (Values_Should_Match and Check_Failed) or - (not Values_Should_Match and Matches > Allowed_Matches) - then - Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) & - " Random numbers from Discrete generators " & - "Failed check"); - end if; - - end Check_Discrete_Values; - - - - begin - - Sub_Test_1: - -- Check that two objects of type Generator are initialized to the - -- same state. - begin - - -- Since the discrete and float random generators are in the initial - -- state, using Procedure Save to save the states of the generator - -- objects, and transforming these states into strings using - -- Function Image, should yield identical strings. - - Check_Discrete_State (Discrete_Generator_1, - Discrete_Generator_2, - Sub_Test => 1, - States_Should_Match => True); - - Check_Float_State (Float_Generator_1, - Float_Generator_2, - Sub_Test => 1, - States_Should_Match => True); - - -- Since the two random generator objects are in their initial - -- state, the values produced from each (upon calls to Random) - -- should be identical. - - Check_Discrete_Values (Discrete_Generator_1, - Discrete_Generator_2, - Sub_Test => 1, - Values_Should_Match => True); - - Check_Float_Values (Float_Generator_1, - Float_Generator_2, - Sub_Test => 1, - Values_Should_Match => True); - - end Sub_Test_1; - - - - Sub_Test_3: - -- Check that when the Function Reset uses the same integer - -- initiator to reset two generators to the same state, the - -- resulting random values and the state from each generator - -- are identical. - declare - use Discrete_Package, Float_Random; - begin - - -- Reset the generators to the same states, using the version of - -- Function Reset with both generator parameter and initiator - -- specified. - - TC_Seed := Integer(Random(Discrete_Generator_1)); - Reset(Gen => Discrete_Generator_1, Initiator => TC_Seed); - Reset(Discrete_Generator_2, Initiator => TC_Seed); - Reset(Float_Generator_1, TC_Seed); - Reset(Float_Generator_2, TC_Seed); - - -- Since the random generators have been reset to identical states, - -- bounded string images of these states should yield identical - -- strings. - - Check_Discrete_State (Discrete_Generator_1, - Discrete_Generator_2, - Sub_Test => 3, - States_Should_Match => True); - - Check_Float_State (Float_Generator_1, - Float_Generator_2, - Sub_Test => 3, - States_Should_Match => True); - - -- Since the random generators have been reset to identical states, - -- the values produced from each (upon calls to Random) should - -- be identical. - - Check_Discrete_Values (Discrete_Generator_1, - Discrete_Generator_2, - Sub_Test => 3, - Values_Should_Match => True); - - Check_Float_Values (Float_Generator_1, - Float_Generator_2, - Sub_Test => 3, - Values_Should_Match => True); - - end Sub_Test_3; - - - - Sub_Test_4: - -- Check that when the Function Reset uses different integer - -- initiator values to reset two generators, the resulting random - -- numbers and states are different. - begin - - -- Reset the generators to different states. - - TC_Seed := - Integer(Discrete_Package.Random(Discrete_Generator_1)); - - Discrete_Package.Reset(Gen => Discrete_Generator_1, - Initiator => TC_Seed); - - -- Set the seed value to a different value for the second call - -- to Reset. - -- Note: A second call to Random could be made, as above, but that - -- would not ensure that the resulting seed value was - -- different from the first. - - if TC_Seed /= Integer'Last then - TC_Seed := TC_Seed + 1; - else - TC_Seed := TC_Seed - 1; - end if; - - Discrete_Package.Reset(Gen => Discrete_Generator_2, - Initiator => TC_Seed); - - Float_Random.Reset(Float_Generator_1, 16#FF#); -- 255 - Float_Random.Reset(Float_Generator_2, 2#1110_0000#); -- 224 - - -- Since the two float random generators are in different - -- states, the bounded string images depicting their states should - -- differ. - - Check_Discrete_State (Discrete_Generator_1, - Discrete_Generator_2, - Sub_Test => 4, - States_Should_Match => False); - - Check_Float_State (Float_Generator_1, - Float_Generator_2, - Sub_Test => 4, - States_Should_Match => False); - - -- Since the two discrete random generator objects were reset - -- to different states, the values produced from each (upon calls - -- to Random) should differ. - - Check_Discrete_Values (Discrete_Generator_1, - Discrete_Generator_2, - Sub_Test => 4, - Values_Should_Match => False); - - Check_Float_Values (Float_Generator_1, - Float_Generator_2, - Sub_Test => 4, - Values_Should_Match => False); - - end Sub_Test_4; - - exception - when The_Error : others => - Report.Failed ("The following exception was raised in the " & - "Test_Block: " & Exception_Name(The_Error)); - end Test_Block; - - Report.Result; - -end CXA5011; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a deleted file mode 100644 index a286fa71ed0..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a +++ /dev/null @@ -1,536 +0,0 @@ --- CXA5012.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, for both Float_Random and Discrete_Random packages, --- the following are true: --- 1) the procedures Save and Reset can be used to save the --- specific state of a random number generator, and then restore --- the specific state to the generator following some intermediate --- generator activity. --- 2) the Function Image can be used to obtain a string --- representation of the state of a generator; and that the --- Function Value will transform a string representation of the --- state of a random number generator into the actual state object. --- 3) a call to Function Value, with a string value that is --- not the image of any generator state, is a bounded error. This --- error either raises Constraint_Error or Program_Error, or is --- accepted. (See Technical Corrigendum 1). --- --- TEST DESCRIPTION: --- This test evaluates components of the Ada.Numerics.Float_Random and --- Ada.Numerics.Discrete_Random packages. --- The first objective block of this test uses Procedure Save to --- save the particular state of a random number generator. The random --- number generator then generates a series of random numbers. The --- saved state variable is then used to reset (using Procedure Reset) --- the generator back to the state it was in at the point of the call --- to Save. Random values are then generated from this restored --- generator, and compared with expected values. --- The second objective block of this test uses Function Image to --- provide a string representation of a state code. This string is --- then transformed back to a state code value, and used to reset a --- random number generator to the saved state. Random values are --- likewise generated from this restored generator, and compared with --- expected values. --- --- --- CHANGE HISTORY: --- 25 Apr 95 SAIC Initial prerelease version. --- 17 Jul 95 SAIC Incorporated reviewer comments. --- 17 Dec 97 EDS Change subtype upper limit from 100_000 to 10_000. --- 16 Sep 99 RLB Updated objective 3 for Technical Corrigendum 1 --- changes. - ---! - -with Ada.Numerics.Float_Random; -with Ada.Numerics.Discrete_Random; -with Ada.Strings.Bounded; -with ImpDef; -with Report; - -procedure CXA5012 is - -begin - - Report.Test ("CXA5012", "Check the effect of Procedures Save and " & - "Reset, and Functions Image and Value " & - "from the Ada.Numerics.Discrete_Random " & - "and Float_Random packages"); - - Test_Block: - declare - - use Ada.Numerics, Ada.Strings.Bounded; - - -- Declare an integer subtype and an enumeration subtype, and use them - -- to instantiate the discrete random number generator generic package. - - subtype Discrete_Range is Integer range 1..10_000; - type Suit_Of_Cards is (Ace, One, Two, Three, Four, Five, Six, - Seven, Eight, Nine, Ten, Jack, Queen, King); - package Discrete_Pack is new Discrete_Random(Discrete_Range); - package Card_Pack is new Discrete_Random(Suit_Of_Cards); - - -- Declaration of random number generator objects. - - DGen_1, DGen_2 : Discrete_Pack.Generator; - EGen_1, EGen_2 : Card_Pack.Generator; - FGen_1, FGen_2 : Float_Random.Generator; - - -- Variables declared to hold random numbers over the inclusive range - -- of their corresponding type. - - DVal_1, DVal_2 : Discrete_Range; - EVal_1, EVal_2 : Suit_Of_Cards; - FVal_1, FVal_2 : Float_Random.Uniformly_Distributed; - - -- Declaration of State variables used to hold the state of the - -- random number generators. - - DState_1, DState_2 : Discrete_Pack.State; - EState_1, EState_2 : Card_Pack.State; - FState_1, FState_2 : Float_Random.State; - - -- Declaration of bounded string packages instantiated with the - -- value of Max_Image_Width constant, and bounded string variables - -- used to hold the image of random number generator states. - - package DString_Pack is - new Generic_Bounded_Length(Discrete_Pack.Max_Image_Width); - package EString_Pack is - new Generic_Bounded_Length(Card_Pack.Max_Image_Width); - package FString_Pack is - new Generic_Bounded_Length(Float_Random.Max_Image_Width); - - use DString_Pack, EString_Pack, FString_Pack; - - DString_1, DString_2 : DString_Pack.Bounded_String := - DString_Pack.Null_Bounded_String; - EString_1, EString_2 : EString_Pack.Bounded_String := - EString_Pack.Null_Bounded_String; - FString_1, FString_2 : FString_Pack.Bounded_String := - FString_Pack.Null_Bounded_String; - - -- Test variables. - - TC_Count : Natural; - TC_Discrete_Check_Failed, - TC_Enum_Check_Failed, - TC_Float_Check_Failed : Boolean := False; - TC_Seed : Integer; - - begin - - Objective_1: - -- Check that the procedures Save and Reset can be used to save the - -- specific state of a random number generator, and then restore the - -- specific state to the generator following some intermediate - -- generator activity. - declare - - First_Row : constant := 1; - Second_Row : constant := 2; - TC_Max_Values : constant := 100; - - TC_Discrete_Array : array (First_Row..Second_Row, 1..TC_Max_Values) - of Discrete_Range; - TC_Enum_Array : array (First_Row..Second_Row, 1..TC_Max_Values) - of Suit_Of_Cards; - TC_Float_Array : array (First_Row..Second_Row, 1..TC_Max_Values) - of Float_Random.Uniformly_Distributed; - begin - - -- The state of the random number generators are saved to state - -- variables using the procedure Save. - - Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1); - Card_Pack.Save (Gen => EGen_1, To_State => EState_1); - Float_Random.Save (Gen => FGen_1, To_State => FState_1); - - -- Random number generators are used to fill the first half of the - -- first row of the arrays with randomly generated values. - - for i in 1..TC_Max_Values/2 loop - TC_Discrete_Array(First_Row, i) := Discrete_Pack.Random(DGen_1); - TC_Enum_Array(First_Row, i) := Card_Pack.Random(EGen_1); - TC_Float_Array(First_Row, i) := Float_Random.Random(FGen_1); - end loop; - - -- The random number generators are reset to the states saved in the - -- state variables, using the procedure Reset. - - Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1); - Card_Pack.Reset (Gen => EGen_1, From_State => EState_1); - Float_Random.Reset (Gen => FGen_1, From_State => FState_1); - - -- The same random number generators are used to fill the first half - -- of the second row of the arrays with randomly generated values. - - for i in 1..TC_Max_Values/2 loop - TC_Discrete_Array(Second_Row, i) := Discrete_Pack.Random(DGen_1); - TC_Enum_Array(Second_Row, i) := Card_Pack.Random(EGen_1); - TC_Float_Array(Second_Row, i) := Float_Random.Random(FGen_1); - end loop; - - -- Run the random number generators many times (not using results). - - for i in Discrete_Range'Range loop - DVal_1 := Discrete_Pack.Random(DGen_1); - EVal_1 := Card_Pack.Random(EGen_1); - FVal_1 := Float_Random.Random(FGen_1); - end loop; - - -- The states of the random number generators are saved to state - -- variables using the procedure Save. - - Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1); - Card_Pack.Save(Gen => EGen_1, To_State => EState_1); - Float_Random.Save (Gen => FGen_1, To_State => FState_1); - - -- The last half of the first row of the arrays are filled with - -- values generated from the same random number generators. - - for i in (TC_Max_Values/2 + 1)..TC_Max_Values loop - TC_Discrete_Array(First_Row, i) := Discrete_Pack.Random(DGen_1); - TC_Enum_Array(First_Row, i) := Card_Pack.Random(EGen_1); - TC_Float_Array(First_Row, i) := Float_Random.Random(FGen_1); - end loop; - - -- The random number generators are reset to the states saved in the - -- state variables, using the procedure Reset. - - Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1); - Card_Pack.Reset(Gen => EGen_1, From_State => EState_1); - Float_Random.Reset (Gen => FGen_1, From_State => FState_1); - - -- The last half of the second row of the arrays are filled with - -- values generated from the same random number generator. - -- These values should exactly mirror the values in the last half - -- of the first row of the arrays that had been previously generated. - - for i in (TC_Max_Values/2 + 1)..TC_Max_Values loop - TC_Discrete_Array(Second_Row, i) := Discrete_Pack.Random(DGen_1); - TC_Enum_Array(Second_Row, i) := Card_Pack.Random(EGen_1); - TC_Float_Array(Second_Row, i) := Float_Random.Random(FGen_1); - end loop; - - -- Check that the values in the two rows of the arrays are identical. - - for i in 1..TC_Max_Values loop - if TC_Discrete_Array(First_Row,i) /= - TC_Discrete_Array(Second_Row,i) - then - TC_Discrete_Check_Failed := True; - exit; - end if; - end loop; - - for i in 1..TC_Max_Values loop - if TC_Enum_Array(First_Row,i) /= TC_Enum_Array(Second_Row,i) then - TC_Enum_Check_Failed := True; - exit; - end if; - end loop; - - for i in 1..TC_Max_Values loop - if TC_Float_Array(First_Row,i) /= TC_Float_Array(Second_Row,i) - then - TC_Float_Check_Failed := True; - exit; - end if; - end loop; - - if TC_Discrete_Check_Failed then - Report.Failed("Discrete random values generated following use " & - "of procedures Save and Reset were not the same"); - TC_Discrete_Check_Failed := False; - end if; - - if TC_Enum_Check_Failed then - Report.Failed("Enumeration random values generated following " & - "use of procedures Save and Reset were not the " & - "same"); - TC_Enum_Check_Failed := False; - end if; - - if TC_Float_Check_Failed then - Report.Failed("Float random values generated following use " & - "of procedures Save and Reset were not the same"); - TC_Float_Check_Failed := False; - end if; - - end Objective_1; - - - - Objective_2: - -- Check that the Function Image can be used to obtain a string - -- representation of the state of a generator. - -- Check that the Function Value will transform a string - -- representation of the state of a random number generator - -- into the actual state object. - begin - - -- Use two discrete and float random number generators to generate - -- a series of values (so that the generators are no longer in their - -- initial states, and they have generated the same number of - -- random values). - - TC_Seed := Integer(Discrete_Pack.Random(DGen_1)); - Discrete_Pack.Reset(DGen_1, TC_Seed); - Discrete_Pack.Reset(DGen_2, TC_Seed); - Card_Pack.Reset (EGen_1, TC_Seed); - Card_Pack.Reset (EGen_2, TC_Seed); - Float_Random.Reset (FGen_1, TC_Seed); - Float_Random.Reset (FGen_2, TC_Seed); - - for i in 1..1000 loop - DVal_1 := Discrete_Pack.Random(DGen_1); - DVal_2 := Discrete_Pack.Random(DGen_2); - EVal_1 := Card_Pack.Random(EGen_1); - EVal_2 := Card_Pack.Random(EGen_2); - FVal_1 := Float_Random.Random(FGen_1); - FVal_2 := Float_Random.Random(FGen_2); - end loop; - - -- Use the Procedure Save to save the states of the generators - -- to state variables. - - Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1); - Discrete_Pack.Save(DGen_2, To_State => DState_2); - Card_Pack.Save (Gen => EGen_1, To_State => EState_1); - Card_Pack.Save (EGen_2, To_State => EState_2); - Float_Random.Save (FGen_1, To_State => FState_1); - Float_Random.Save (FGen_2, FState_2); - - -- Use the Function Image to produce a representation of the state - -- codes as (bounded) string objects. - - DString_1 := DString_Pack.To_Bounded_String( - Discrete_Pack.Image(Of_State => DState_1)); - DString_2 := DString_Pack.To_Bounded_String( - Discrete_Pack.Image(DState_2)); - EString_1 := EString_Pack.To_Bounded_String( - Card_Pack.Image(Of_State => EState_1)); - EString_2 := EString_Pack.To_Bounded_String( - Card_Pack.Image(EState_2)); - FString_1 := FString_Pack.To_Bounded_String( - Float_Random.Image(Of_State => FState_1)); - FString_2 := FString_Pack.To_Bounded_String( - Float_Random.Image(FState_2)); - - -- Compare the bounded string objects for equality. - - if DString_1 /= DString_2 then - Report.Failed("String values returned from Function Image " & - "depict different states of Discrete generators"); - end if; - if EString_1 /= EString_2 then - Report.Failed("String values returned from Function Image " & - "depict different states of Enumeration " & - "generators"); - end if; - if FString_1 /= FString_2 then - Report.Failed("String values returned from Function Image " & - "depict different states of Float generators"); - end if; - - -- The string representation of a state code is transformed back - -- to a state code variable using the Function Value. - - DState_1 := Discrete_Pack.Value(Coded_State => - DString_Pack.To_String(DString_1)); - EState_1 := Card_Pack.Value(EString_Pack.To_String(EString_1)); - FState_1 := Float_Random.Value(FString_Pack.To_String(FString_1)); - - -- One of the (pair of each type of ) generators is used to generate - -- a series of random values, getting them "out of synch" with the - -- specific generation sequence of the other generators. - - for i in 1..100 loop - DVal_1 := Discrete_Pack.Random(DGen_1); - EVal_1 := Card_Pack.Random(EGen_1); - FVal_1 := Float_Random.Random (FGen_1); - end loop; - - -- The "out of synch" generators are reset to the previous state they - -- had when their states were saved, and they should now have the same - -- states as the generators that did not generate the values above. - - Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1); - Card_Pack.Reset (Gen => EGen_1, From_State => EState_1); - Float_Random.Reset (Gen => FGen_1, From_State => FState_1); - - -- All generators should now be in the same state, so the - -- random values they produce should be the same. - - for i in 1..1000 loop - if Discrete_Pack.Random(DGen_1) /= Discrete_Pack.Random(DGen_2) - then - TC_Discrete_Check_Failed := True; - exit; - end if; - end loop; - - for i in 1..1000 loop - if Card_Pack.Random(EGen_1) /= Card_Pack.Random(EGen_2) then - TC_Enum_Check_Failed := True; - exit; - end if; - end loop; - - for i in 1..1000 loop - if Float_Random.Random(FGen_1) /= Float_Random.Random(FGen_2) - then - TC_Float_Check_Failed := True; - exit; - end if; - end loop; - - if TC_Discrete_Check_Failed then - Report.Failed("Random values generated following use of " & - "procedures Image and Value were not the same " & - "for Discrete generator"); - end if; - if TC_Enum_Check_Failed then - Report.Failed("Random values generated following use of " & - "procedures Image and Value were not the same " & - "for Enumeration generator"); - end if; - if TC_Float_Check_Failed then - Report.Failed("Random values generated following use of " & - "procedures Image and Value were not the same " & - "for Float generator"); - end if; - - end Objective_2; - - - - Objective_3: - -- Check that a call to Function Value, with a string value that is - -- not the image of any generator state, is a bounded error. This - -- error either raises Constraint_Error or Program_Error, or is - -- accepted. (See Technical Corrigendum 1). - declare - Not_A_State : constant String := ImpDef.Non_State_String; - begin - - begin - DState_1 := Discrete_Pack.Value(Not_A_State); - if Not_A_State /= "**NONE**" then - Report.Failed("Exception not raised by Function " & - "Ada.Numerics.Discrete_Random.Value when " & - "provided a string input that does not " & - "represent the state of a random number " & - "generator"); - else - Report.Comment("All strings represent states for Function " & - "Ada.Numerics.Discrete_Random.Value"); - end if; - Discrete_Pack.Reset(DGen_1, DState_1); - exception - when Constraint_Error => null; -- OK, expected exception. - Report.Comment("Constraint_Error raised by Function " & - "Ada.Numerics.Discrete_Random.Value when " & - "provided a string input that does not " & - "represent the state of a random number " & - "generator"); - when Program_Error => -- OK, expected exception. - Report.Comment("Program_Error raised by Function " & - "Ada.Numerics.Discrete_Random.Value when " & - "provided a string input that does not " & - "represent the state of a random number " & - "generator"); - when others => - Report.Failed("Unexpected exception raised by Function " & - "Ada.Numerics.Discrete_Random.Value when " & - "provided a string input that does not " & - "represent the state of a random number " & - "generator"); - end; - - begin - EState_1 := Card_Pack.Value(Not_A_State); - if Not_A_State /= "**NONE**" then - Report.Failed("Exception not raised by Function " & - "Ada.Numerics.Discrete_Random.Value when " & - "provided a string input that does not " & - "represent the state of an enumeration " & - "random number generator"); - else - Report.Comment("All strings represent states for Function " & - "Ada.Numerics.Discrete_Random.Value"); - end if; - Card_Pack.Reset(EGen_1, EState_1); - exception - when Constraint_Error => null; -- OK, expected exception. - when Program_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function " & - "Ada.Numerics.Discrete_Random.Value when " & - "provided a string input that does not " & - "represent the state of an enumeration " & - "random number generator"); - end; - - begin - FState_1 := Float_Random.Value(Not_A_State); - if Not_A_State /= "**NONE**" then - Report.Failed("Exception not raised by an " & - "instantiated version of " & - "Ada.Numerics.Float_Random.Value when " & - "provided a string input that does not " & - "represent the state of a random number " & - "generator"); - else - Report.Comment("All strings represent states for Function " & - "Ada.Numerics.Float_Random.Value"); - end if; - Float_Random.Reset(FGen_1, FState_1); - exception - when Constraint_Error => null; -- OK, expected exception. - when Program_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by an " & - "instantiated version of " & - "Ada.Numerics.Float_Random.Value when " & - "provided a string input that does not " & - "represent the state of a random number " & - "generator"); - end; - - end Objective_3; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA5012; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a deleted file mode 100644 index e1035db271b..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a +++ /dev/null @@ -1,342 +0,0 @@ --- CXA5015.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 following representation-oriented attributes are --- available and that the produce correct results: --- 'Denorm, 'Signed_Zeros, 'Exponent 'Fraction, 'Compose, 'Scaling, --- 'Floor, 'Ceiling, 'Rounding, 'Unbiased_Rounding, 'Truncation, --- 'Remainder, 'Adjacent, 'Copy_Sign, 'Leading_Part, 'Machine, and --- 'Model_Small. --- --- TEST DESCRIPTION: --- This test checks whether certain attributes of floating point types --- are available from an implementation. Where attribute correctness --- can be verified in a straight forward manner, the appropriate checks --- are included here. However, this test is not intended to ensure the --- correctness of the results returned from all of the attributes --- examined in this test; that process will occur in the tests of the --- Numerics_Annex. --- --- --- CHANGE HISTORY: --- 26 Jun 95 SAIC Initial prerelease version. --- 29 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- 01 DEC 97 EDS Fix value for checking the S'Adjacent attribute ---! - -with Report; - -procedure CXA5015 is - - subtype Float_Subtype is Float range -10.0..10.0; - type Derived_Float_1 is digits 8; - type Derived_Float_2 is new Derived_Float_1 range -10.0..10.0E10; - - use type Float, Float_Subtype, Derived_Float_1, Derived_Float_2; - - TC_Boolean : Boolean; - TC_Float : Float; - TC_SFloat : Float_Subtype; - TC_DFloat_1 : Derived_Float_1; - TC_DFloat_2 : Derived_Float_2; - TC_Tolerance : Float := 0.001; - - function Not_Equal (Actual_Result, Expected_Result, Tolerance : Float) - return Boolean is - begin - return abs(Actual_Result - Expected_Result) > Tolerance; - end Not_Equal; - - -begin - - Report.Test ("CXA5015", "Check that certain representation-oriented " & - "attributes are available and that they " & - "produce correct results"); - - -- New Representation-Oriented Attributes. - -- - -- Check the S'Denorm attribute. - - TC_Boolean := Float'Denorm; - TC_Boolean := Float_Subtype'Denorm; - TC_Boolean := Derived_Float_1'Denorm; - TC_Boolean := Derived_Float_2'Denorm; - - - -- Check the S'Signed_Zeroes attribute. - - TC_Boolean := Float'Signed_Zeros; - TC_Boolean := Float_Subtype'Signed_Zeros; - TC_Boolean := Derived_Float_1'Signed_Zeros; - TC_Boolean := Derived_Float_2'Signed_Zeros; - - - -- New Primitive Function Attributes. - -- - -- Check the S'Exponent attribute. - - TC_Float := 0.5; - TC_SFloat := 0.99; - TC_DFloat_1 := 2.45; - TC_DFloat_2 := 2.65; - - if Float'Exponent(TC_Float) > Float_Subtype'Exponent(TC_SFloat) or - Float'Exponent(TC_Float) > 2 - then - Report.Failed("Incorrect result from the 'Exponent attribute"); - end if; - - - -- Check the S'Fraction attribute. - - if Not_Equal - (Float'Fraction(TC_Float), - TC_Float * Float(Float'Machine_Radix)**(-Float'Exponent(TC_Float)), - TC_Tolerance) - then - Report.Failed("Incorrect result from the 'Fraction attribute - 1"); - end if; - - if Float'Fraction(TC_Float) < - (1.0/Float(Float'Machine_Radix)) - TC_Tolerance or - Float'Fraction(TC_Float) >= 1.0 - TC_Tolerance - then - Report.Failed("Incorrect result from the 'Fraction attribute - 2"); - end if; - - - -- Check the S'Compose attribute. - - if Not_Equal - (Float'Compose(TC_Float, 3), - TC_Float * Float(Float'Machine_Radix)**(3-Float'Exponent(TC_Float)), - TC_Tolerance) - then - Report.Failed("Incorrect result from the 'Compose attribute"); - end if; - - - -- Check the S'Scaling attribute. - - if Not_Equal - (Float'Scaling(TC_Float, 2), - TC_Float * Float(Float'Machine_Radix)**2, - TC_Tolerance) - then - Report.Failed("Incorrect result from the 'Scaling attribute"); - end if; - - - -- Check the S'Floor attribute. - - TC_Float := 0.99; - TC_SFloat := 1.00; - TC_DFloat_1 := 2.50; - TC_DFloat_2 := -2.50; - - if Float'Floor(TC_Float) /= 0.0 or - Float_Subtype'Floor(TC_SFloat) /= 1.0 or - Derived_Float_1'Floor(TC_DFloat_1) /= 2.0 or - Derived_Float_2'Floor(TC_DFloat_2) /= -3.0 - then - Report.Failed("Incorrect result from the 'Floor attribute"); - end if; - - - -- Check the S'Ceiling attribute. - - TC_Float := 0.99; - TC_SFloat := 1.00; - TC_DFloat_1 := 2.50; - TC_DFloat_2 := -2.99; - - if Float'Ceiling(TC_Float) /= 1.0 or - Float_Subtype'Ceiling(TC_SFloat) /= 1.0 or - Derived_Float_1'Ceiling(TC_DFloat_1) /= 3.0 or - Derived_Float_2'Ceiling(TC_DFloat_2) /= -2.0 - then - Report.Failed("Incorrect result from the 'Ceiling attribute"); - end if; - - - -- Check the S'Rounding attribute. - - TC_Float := 0.49; - TC_SFloat := 1.00; - TC_DFloat_1 := 2.50; - TC_DFloat_2 := -2.50; - - if Float'Rounding(TC_Float) /= 0.0 or - Float_Subtype'Rounding(TC_SFloat) /= 1.0 or - Derived_Float_1'Rounding(TC_DFloat_1) /= 3.0 or - Derived_Float_2'Rounding(TC_DFloat_2) /= -3.0 - then - Report.Failed("Incorrect result from the 'Rounding attribute"); - end if; - - - -- Check the S'Unbiased_Rounding attribute. - - TC_Float := 0.50; - TC_SFloat := 1.50; - TC_DFloat_1 := 2.50; - TC_DFloat_2 := -2.50; - - if Float'Unbiased_Rounding(TC_Float) /= 0.0 or - Float_Subtype'Unbiased_Rounding(TC_SFloat) /= 2.0 or - Derived_Float_1'Unbiased_Rounding(TC_DFloat_1) /= 2.0 or - Derived_Float_2'Unbiased_Rounding(TC_DFloat_2) /= -2.0 - then - Report.Failed("Incorrect result from the 'Unbiased_Rounding " & - "attribute"); - end if; - - - -- Check the S'Truncation attribute. - - TC_Float := -0.99; - TC_SFloat := 1.50; - TC_DFloat_1 := 2.99; - TC_DFloat_2 := -2.50; - - if Float'Truncation(TC_Float) /= 0.0 or - Float_Subtype'Truncation(TC_SFloat) /= 1.0 or - Derived_Float_1'Truncation(TC_DFloat_1) /= 2.0 or - Derived_Float_2'Truncation(TC_DFloat_2) /= -2.0 - then - Report.Failed("Incorrect result from the 'Truncation attribute"); - end if; - - - -- Check the S'Remainder attribute. - - TC_Float := 9.0; - TC_SFloat := 7.5; - TC_DFloat_1 := 5.0; - TC_DFloat_2 := 8.0; - - if Float'Remainder(TC_Float, 2.0) /= 1.0 or - Float_Subtype'Remainder(TC_SFloat, 3.0) /= 1.5 or - Derived_Float_1'Remainder(TC_DFloat_1, 2.0) /= 1.0 or - Derived_Float_2'Remainder(TC_DFloat_2, 4.0) /= 0.0 - then - Report.Failed("Incorrect result from the 'Remainder attribute"); - end if; - - - -- Check the S'Adjacent attribute. - - TC_Float := 4.0; - TC_SFloat := -1.0; - - if Float'Adjacent(TC_Float, TC_Float) /= TC_Float or - Float_Subtype'Adjacent(TC_SFloat, -1.0) /= TC_SFloat - then - Report.Failed("Incorrect result from the 'Adjacent attribute"); - end if; - - - -- Check the S'Copy_Sign attribute. - - TC_Float := 0.0; - TC_SFloat := -1.0; - TC_DFloat_1 := 5.0; - TC_DFloat_2 := -2.5; - - if Float'Copy_Sign(TC_Float, -2.0) /= 0.0 or - Float_Subtype'Copy_Sign(TC_SFloat, 4.0) /= 1.0 or - Derived_Float_1'Copy_Sign(TC_DFloat_1, -2.0) /= -5.0 or - Derived_Float_2'Copy_Sign(TC_DFloat_2, -2.0) /= -2.5 - then - Report.Failed("Incorrect result from the 'Copy_Sign attribute"); - end if; - - - -- Check the S'Leading_Part attribute. - - TC_Float := 0.0; - TC_SFloat := -1.0; - TC_DFloat_1 := 5.88; - TC_DFloat_2 := -2.52; - - -- Leading part obtained in the variables. - TC_Float := Float'Leading_Part(TC_Float, 2); - TC_SFloat := Float_Subtype'Leading_Part(TC_SFloat, 2); - TC_DFloat_1 := Derived_Float_1'Leading_Part(TC_DFloat_1, 2); - TC_DFloat_2 := Derived_Float_2'Leading_Part(TC_DFloat_2, 2); - - -- Checking for the leading part of the variables at this point should - -- produce the same values. - if Float'Leading_Part(TC_Float, 2) /= TC_Float or - Float_Subtype'Leading_Part(TC_SFloat, 2) /= TC_SFloat or - Derived_Float_1'Leading_Part(TC_DFloat_1, 2) /= TC_DFloat_1 or - Derived_Float_2'Leading_Part(TC_DFloat_2, 2) /= TC_DFloat_2 - then - Report.Failed("Incorrect result from the 'Leading_Part attribute"); - end if; - - - -- Check the S'Machine attribute. - - TC_Float := 0.0; - TC_SFloat := -1.0; - TC_DFloat_1 := 5.88; - TC_DFloat_2 := -2.52; - - -- Closest machine number obtained in the variables. - TC_Float := Float'Machine(TC_Float); - TC_SFloat := Float_Subtype'Machine(TC_SFloat); - TC_DFloat_1 := Derived_Float_1'Machine(TC_DFloat_1); - TC_DFloat_2 := Derived_Float_2'Machine(TC_DFloat_2); - - -- Checking for the closest machine number to each of the variables at - -- this point should produce the same values. - if Float'Machine(TC_Float) /= TC_Float or - Float_Subtype'Machine(TC_SFloat) /= TC_SFloat or - Derived_Float_1'Machine(TC_DFloat_1) /= TC_DFloat_1 or - Derived_Float_2'Machine(TC_DFloat_2) /= TC_DFloat_2 - then - Report.Failed("Incorrect result from the 'Machine attribute"); - end if; - - - -- New Model-Oriented Attributes. - -- - -- Check the S'Model_Small attribute. - - if Not_Equal - (Float'Model_Small, - Float(Float'Machine_Radix)**(Float'Model_Emin-1), - TC_Tolerance) - then - Report.Failed("Incorrect result from the 'Model_Small attribute"); - end if; - - - Report.Result; - -end CXA5015; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a deleted file mode 100644 index 12db5e7e108..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a +++ /dev/null @@ -1,338 +0,0 @@ --- CXA5A01.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 Sin and Sinh provide correct results. --- --- TEST DESCRIPTION: --- This test examines both the version of Sin and Sinh resulting from --- the instantiation of the Ada.Numerics.Generic_Elementary_Functions --- with a type derived from type Float, as well as the preinstantiated --- version of this package for type Float. --- Prescribed results, as well as instances prescribed to raise --- exceptions, are examined in the test cases. In addition, --- certain evaluations are performed where the actual function result --- is compared with the expected result (within an epsilon range of --- accuracy). --- --- TEST FILES: --- The following files comprise this test: --- --- FXA5A00.A (foundation code) --- CXA5A01.A --- --- --- CHANGE HISTORY: --- 06 Mar 95 SAIC Initial prerelease version. --- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and --- use of Result_Within_Range function overloaded for --- FXA5A00.New_Float_Type. --- 26 Jun 98 EDS Protected exception tests by first testing --- for 'Machine_Overflows ---! - -with Ada.Numerics.Elementary_Functions; -with Ada.Numerics.Generic_Elementary_Functions; -with FXA5A00; -with Report; - -procedure CXA5A01 is -begin - - Report.Test ("CXA5A01", "Check that the functions Sin and Sinh provide " & - "correct results"); - - Test_Block: - declare - - use Ada.Numerics; - use FXA5A00; - - package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); - package EF renames Ada.Numerics.Elementary_Functions; - - The_Result : Float; - New_Float_Result : New_Float; - - procedure Dont_Optimize_Float is new Dont_Optimize(Float); - procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); - - begin - - -- Testing of Sin Function, both instantiated and pre-instantiated - -- version. - - -- Check that no exception occurs on computing the Sin with very - -- large (positive and negative) input values. - - begin - New_Float_Result := GEF.Sin (New_Float(FXA5A00.Large)); - Dont_Optimize_New_Float(New_Float_Result, 1); - exception - when others => - Report.Failed("Unexpected exception on GEF.Sin with large " & - "positive value"); - end; - - begin - The_Result := EF.Sin (FXA5A00.Minus_Large); - Dont_Optimize_Float(The_Result, 2); - exception - when others => - Report.Failed("Unexpected exception on GEF.Sin with large " & - "negative value"); - end; - - - -- Test of Sin for prescribed result at zero. - - if GEF.Sin (0.0) /= 0.0 or - EF.Sin (0.0) /= 0.0 - then - Report.Failed("Incorrect value returned from Sin(0.0)"); - end if; - - - -- Test of Sin with expected result value between 0.0 and 1.0. - - if not (GEF.Sin (Ada.Numerics.Pi/4.0) < 1.0) or - not ( EF.Sin (Ada.Numerics.Pi/4.0) < 1.0) or - not FXA5A00.Result_Within_Range(GEF.Sin(0.35), 0.343, 0.001) or - not FXA5A00.Result_Within_Range( EF.Sin(1.18), 0.924, 0.001) - then - Report.Failed("Incorrect value returned from Sin function when " & - "the expected result is between 0.0 and 1.0"); - end if; - - - -- Test of Sin with expected result value between -1.0 and 0.0. - - if not (GEF.Sin (-Ada.Numerics.Pi/4.0) > -1.0) or - not ( EF.Sin (-Ada.Numerics.Pi/4.0) > -1.0) or - not FXA5A00.Result_Within_Range(GEF.Sin(-0.24), -0.238, 0.001) or - not FXA5A00.Result_Within_Range( EF.Sin(-1.00), -0.841, 0.001) - then - Report.Failed("Incorrect value returned from Sin function when " & - "the expected result is between -1.0 and 0.0"); - end if; - - - -- Testing of the Sin function with Cycle parameter. - - -- Check that Argument_Error is raised when the value of the Cycle - -- parameter is zero. - - begin - New_Float_Result := GEF.Sin (X => 1.0, Cycle => 0.0); - Report.Failed("Argument_Error not raised by GEF.Sin function " & - "when the Cycle parameter is zero"); - Dont_Optimize_New_Float(New_Float_Result, 3); - exception - when Ada.Numerics.Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by GEF.Sin function " & - "when the Cycle parameter is zero"); - end; - - begin - The_Result := EF.Sin (X => 0.34, Cycle => 0.0); - Report.Failed("Argument_Error not raised by EF.Sin function when " & - "the Cycle parameter is zero"); - Dont_Optimize_Float(The_Result, 4); - exception - when Ada.Numerics.Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by EF.Sin function " & - "when the Cycle parameter is zero"); - end; - - -- Check that Argument_Error is raised when the value of the Cycle - -- parameter is negative. - - begin - New_Float_Result := GEF.Sin (X => 0.45, Cycle => -1.0); - Report.Failed("Argument_Error not raised by GEF.Sin function " & - "when the Cycle parameter is negative"); - Dont_Optimize_New_Float(New_Float_Result, 5); - exception - when Ada.Numerics.Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by GEF.Sin function " & - "when the Cycle parameter is negative"); - end; - - begin - The_Result := EF.Sin (X => 0.10, Cycle => -4.0); - Report.Failed("Argument_Error not raised by EF.Sin function when " & - "the Cycle parameter is negative"); - Dont_Optimize_Float(The_Result, 6); - exception - when Ada.Numerics.Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by EF.Sin function " & - "when the Cycle parameter is negative"); - end; - - - -- Check that no exception occurs on computing the Sin with very - -- large (positive and negative) input values and Cycle parameter. - - begin - New_Float_Result := GEF.Sin (New_Float(FXA5A00.Large), 360.0); - Dont_Optimize_New_Float(New_Float_Result, 7); - exception - when others => - Report.Failed("Unexpected exception on GEF.Sin with large " & - "positive value and Cycle parameter"); - end; - - begin - The_Result := EF.Sin (FXA5A00.Minus_Large, 720.0); - Dont_Optimize_Float(The_Result, 8); - exception - when others => - Report.Failed("Unexpected exception on EF.Sin with large " & - "negative value and Cycle parameter"); - end; - - - -- Test of Sin with Cycle parameter for prescribed result at zero. - - if GEF.Sin (0.0, 360.0) /= 0.0 or - EF.Sin (0.0, 180.0) /= 0.0 - then - Report.Failed("Incorrect value returned from Sin function with " & - "cycle parameter for a zero input parameter value"); - end if; - - - -- Tests of Sin function with Cycle parameter for prescribed results. - - if GEF.Sin(0.0, 360.0) /= 0.0 or - EF.Sin(180.0, 360.0) /= 0.0 or - GEF.Sin(90.0, 360.0) /= 1.0 or - EF.Sin(450.0, 360.0) /= 1.0 or - GEF.Sin(270.0, 360.0) /= -1.0 or - EF.Sin(630.0, 360.0) /= -1.0 - then - Report.Failed("Incorrect result from the Sin function with " & - "various cycle values for prescribed results"); - end if; - - - -- Testing of Sinh Function, both instantiated and pre-instantiated - -- version. - - -- Test for Constraint_Error on parameter with large positive magnitude. - - begin - - if New_Float'Machine_Overflows then - New_Float_Result := GEF.Sinh (New_Float(FXA5A00.Large)); - Report.Failed("Constraint_Error not raised when the GEF.Sinh " & - "function is provided a parameter with a large " & - "positive value"); - Dont_Optimize_New_Float(New_Float_Result, 9); - end if; - - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Constraint_Error not raised when the GEF.Sinh " & - "function is provided a parameter with a large " & - "positive value"); - end; - - -- Test for Constraint_Error on parameter with large negative magnitude. - - begin - - if Float'Machine_Overflows then - The_Result := EF.Sinh (FXA5A00.Minus_Large); - Report.Failed("Constraint_Error not raised when the EF.Sinh " & - "function is provided a parameter with a " & - "large negative value"); - Dont_Optimize_Float(The_Result, 10); - end if; - - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Constraint_Error not raised when the EF.Sinh " & - "function is provided a parameter with a " & - "large negative value"); - end; - - - -- Test that no exception occurs when the Sinh function is provided a - -- very small positive or negative value. - - begin - New_Float_Result := GEF.Sinh (New_Float(FXA5A00.Small)); - Dont_Optimize_New_Float(New_Float_Result, 11); - exception - when others => - Report.Failed("Unexpected exception on GEF.Sinh with a very" & - "small positive value"); - end; - - begin - The_Result := EF.Sinh (-FXA5A00.Small); - Dont_Optimize_Float(The_Result, 12); - exception - when others => - Report.Failed("Unexpected exception on EF.Sinh with a very" & - "small negative value"); - end; - - - -- Test for prescribed 0.0 result of Function Sinh with 0.0 parameter. - - if GEF.Sinh (0.0) /= 0.0 or - EF.Sinh (0.0) /= 0.0 - then - Report.Failed("Incorrect value returned from Sinh(0.0)"); - end if; - - - -- Test of Sinh function with various input parameters. - - if not FXA5A00.Result_Within_Range(GEF.Sinh(0.01), 0.010, 0.001) or - not FXA5A00.Result_Within_Range( EF.Sinh(0.61), 0.649, 0.001) or - not FXA5A00.Result_Within_Range(GEF.Sinh(1.70), 2.65, 0.01) or - not FXA5A00.Result_Within_Range( EF.Sinh(3.15), 11.65, 0.01) - then - Report.Failed("Incorrect result returned from Sinh function " & - "with various input parameters"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA5A01; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a deleted file mode 100644 index 9e6c575dd2c..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a +++ /dev/null @@ -1,328 +0,0 @@ --- CXA5A02.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 Cos and Cosh provide correct results. --- --- TEST DESCRIPTION: --- This test examines both the version of Cos and Cosh resulting from --- the instantiation of the Ada.Numerics.Generic_Elementary_Functions --- with type derived from type Float, as well as the pre-instantiated --- version of this package for type Float. --- Prescribed results, including instances prescribed to raise --- exceptions, are examined in the test cases. In addition, --- certain evaluations are performed where the actual function result --- is compared with the expected result (within an epsilon range of --- accuracy). --- --- TEST FILES: --- The following files comprise this test: --- --- FXA5A00.A (foundation code) --- CXA5A02.A --- --- --- CHANGE HISTORY: --- 09 Mar 95 SAIC Initial prerelease version. --- 03 Apr 95 SAIC Removed reference to derived type. --- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and --- use of Result_Within_Range function overloaded for --- FXA5A00.New_Float_Type. --- 28 Feb 97 PWB.CTA Removed checks specifying Cycle => 2.0 * Pi --- 26 Jun 98 EDS Protected exception checks by first testing --- for 'Machine_Overflows. Removed code deleted --- by comment. --- CHANGE NOTE: --- According to Ken Dritz, author of the Numerics Annex of the RM, --- one should never specify the cycle 2.0*Pi for the trigonometric --- functions. In particular, if the machine number for the first --- argument is not an exact multiple of the machine number for the --- explicit cycle, then the specified exact results cannot be --- reasonably expected. The affected checks have been deleted. ---! - -with Ada.Numerics.Elementary_Functions; -with Ada.Numerics.Generic_Elementary_Functions; -with FXA5A00; -with Report; - -procedure CXA5A02 is -begin - - Report.Test ("CXA5A02", "Check that the functions Cos and Cosh provide " & - "correct results"); - - Test_Block: - declare - - use Ada.Numerics; - use FXA5A00; - - package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); - package EF renames Ada.Numerics.Elementary_Functions; - - The_Result : Float; - New_Float_Result : New_Float; - - procedure Dont_Optimize_Float is new Dont_Optimize(Float); - procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); - - begin - - -- Testing of Cos Function, both instantiated and pre-instantiated - -- version. - - -- Check that no exception occurs on computing the Cos with very - -- large (positive and negative) input values. - - begin - New_Float_Result := GEF.Cos (New_Float(FXA5A00.Large)); - Dont_Optimize_New_Float(New_Float_Result, 1); - exception - when others => - Report.Failed("Unexpected exception on GEF.Cos with large " & - "positive value"); - end; - - begin - The_Result := EF.Cos (FXA5A00.Minus_Large); - Dont_Optimize_Float(The_Result, 2); - exception - when others => - Report.Failed("Unexpected exception on GEF.Cos with large " & - "negative value"); - end; - - - -- Test of Cos for prescribed result at zero. - - if GEF.Cos (0.0) /= 1.0 or - EF.Cos (0.0) /= 1.0 - then - Report.Failed("Incorrect value returned from Cos(0.0)"); - end if; - - - -- Test of Cos with expected result value between 1.0 and -1.0. - - if not (Result_Within_Range( EF.Cos(Ada.Numerics.Pi/3.0), - 0.500, - 0.001) and - Result_Within_Range(GEF.Cos(0.6166), 0.816, 0.001) and - Result_Within_Range(GEF.Cos(0.1949), 0.981, 0.001) and - Result_Within_Range( EF.Cos(Ada.Numerics.Pi/2.0), - 0.00, - 0.001) and - Result_Within_Range( EF.Cos(2.0*Ada.Numerics.Pi/3.0), - -0.500, - 0.001) and - Result_Within_Range(GEF.Cos(New_Float(Ada.Numerics.Pi)), - -1.00, - 0.001)) - then - Report.Failed("Incorrect value returned from Cos function when " & - "the expected result is between 1.0 and -1.0"); - end if; - - - -- Testing of the Cos function with Cycle parameter. - - -- Check that Argument_Error is raised when the value of the Cycle - -- parameter is zero. - - begin - New_Float_Result := GEF.Cos (X => 1.0, Cycle => 0.0); - Report.Failed("Argument_Error not raised by GEF.Cos function " & - "when the Cycle parameter is zero"); - Dont_Optimize_New_Float(New_Float_Result, 3); - exception - when Ada.Numerics.Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by GEF.cos function " & - "when the Cycle parameter is zero"); - end; - - begin - The_Result := EF.Cos (X => 0.55, Cycle => 0.0); - Report.Failed("Argument_Error not raised by EF.Cos function when " & - "the Cycle parameter is zero"); - Dont_Optimize_Float(The_Result, 4); - exception - when Ada.Numerics.Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by EF.Cos function " & - "when the Cycle parameter is zero"); - end; - - -- Check that Argument_Error is raised when the value of the Cycle - -- parameter is negative. - - begin - New_Float_Result := GEF.Cos (X => 0.45, Cycle => -2.0*Pi); - Report.Failed("Argument_Error not raised by GEF.Cos function " & - "when the Cycle parameter is negative"); - Dont_Optimize_New_Float(New_Float_Result, 5); - exception - when Ada.Numerics.Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by GEF.Cos function " & - "when the Cycle parameter is negative"); - end; - - begin - The_Result := EF.Cos (X => 0.10, Cycle => -Pi/2.0); - Report.Failed("Argument_Error not raised by EF.Cos function when " & - "the Cycle parameter is negative"); - Dont_Optimize_Float(The_Result, 6); - exception - when Ada.Numerics.Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by EF.Cos function " & - "when the Cycle parameter is negative"); - end; - - -- Test of Cos with Cycle parameter for prescribed result at zero. - - if GEF.Cos (0.0, 360.0) /= 1.0 or - EF.Cos (0.0, 360.0) /= 1.0 - then - Report.Failed("Incorrect value returned from Cos function with " & - "cycle parameter for a zero input parameter value"); - end if; - - - -- Tests of Cos function with specified Cycle, using various input - -- parameter values for prescribed results. - - if GEF.Cos(0.0, 360.0) /= 1.0 or - EF.Cos(360.0, 360.0) /= 1.0 or - GEF.Cos(90.0, 360.0) /= 0.0 or - EF.Cos(270.0, 360.0) /= 0.0 or - GEF.Cos(180.0, 360.0) /= -1.0 or - EF.Cos(540.0, 360.0) /= -1.0 - then - Report.Failed("Incorrect result from the Cos function with " & - "specified cycle for prescribed results"); - end if; - - - - -- Testing of Cosh Function, both instantiated and pre-instantiated - -- version. - - -- Test for Constraint_Error on parameter with large positive magnitude. - - begin - - if New_Float'Machine_Overflows then - - New_Float_Result := GEF.Cosh (New_Float(FXA5A00.Large)); - Report.Failed("Constraint_Error not raised when the GEF.Cosh " & - "function is provided a parameter with a large " & - "positive value"); - Dont_Optimize_New_Float(New_Float_Result, 9); - end if; - - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Constraint_Error not raised when the GEF.Cosh " & - "function is provided a parameter with a large " & - "positive value"); - end; - - -- Test for Constraint_Error on parameter with large negative magnitude. - - begin - - if Float'Machine_Overflows then - The_Result := EF.Cosh (FXA5A00.Minus_Large); - Report.Failed("Constraint_Error not raised when the EF.Cosh " & - "function is provided a parameter with a " & - "large negative value"); - Dont_Optimize_Float(The_Result, 10); - end if; - - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Constraint_Error not raised when the EF.Cosh " & - "function is provided a parameter with a " & - "large negative value"); - end; - - - -- Test that no exception occurs when the Cosh function is provided a - -- very small positive or negative value. - - begin - New_Float_Result := GEF.Cosh (New_Float(FXA5A00.Small)); - Dont_Optimize_New_Float(New_Float_Result, 11); - exception - when others => - Report.Failed("Unexpected exception on GEF.Cosh with a very" & - "small positive value"); - end; - - begin - The_Result := EF.Cosh (-FXA5A00.Small); - Dont_Optimize_Float(The_Result, 12); - exception - when others => - Report.Failed("Unexpected exception on EF.Cosh with a very" & - "small negative value"); - end; - - - -- Test for prescribed 1.0 result of Function Cosh with 0.0 parameter. - - if GEF.Cosh (0.0) /= 1.0 or - EF.Cosh (0.0) /= 1.0 - then - Report.Failed("Incorrect value returned from Cosh(0.0)"); - end if; - - - -- Test of Cosh function with various input parameters. - - if not FXA5A00.Result_Within_Range(GEF.Cosh(0.24), 1.029, 0.001) or - not FXA5A00.Result_Within_Range( EF.Cosh(0.59), 1.179, 0.001) or - not FXA5A00.Result_Within_Range(GEF.Cosh(1.06), 1.616, 0.001) or - not FXA5A00.Result_Within_Range( EF.Cosh(1.50), 2.352, 0.001) or - not FXA5A00.Result_Within_Range(GEF.Cosh(1.84), 3.228, 0.001) or - not FXA5A00.Result_Within_Range( EF.Cosh(3.40), 14.99, 0.01) - then - Report.Failed("Incorrect result from Cosh function with " & - "various input parameters"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA5A02; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a deleted file mode 100644 index d99ba9bdcf0..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a +++ /dev/null @@ -1,426 +0,0 @@ --- CXA5A03.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 Tan, Tanh, and Arctanh provide correct --- results. --- --- TEST DESCRIPTION: --- This test examines both the version of Tan, Tanh, and Arctanh --- the instantiation of the Ada.Numerics.Generic_Elementary_Functions --- with a type derived from type Float, as well as the preinstantiated --- version of this package for type Float. --- Prescribed results, including instances prescribed to raise --- exceptions, are examined in the test cases. In addition, --- certain evaluations are performed where the actual function result --- is compared with the expected result (within an epsilon range of --- accuracy). --- --- TEST FILES: --- The following files comprise this test: --- --- FXA5A00.A (foundation code) --- CXA5A03.A --- --- --- CHANGE HISTORY: --- 14 Mar 95 SAIC Initial prerelease version. --- 06 Apr 95 SAIC Corrected errors in context clause references --- and usage of Cycle parameter. --- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and --- use of Result_Within_Range function overloaded for --- FXA5A00.New_Float_Type. --- 29 Jun 98 EDS Protected exception tests by first testing --- for 'Machine_Overflows --- ---! - -with Ada.Numerics.Elementary_Functions; -with Ada.Numerics.Generic_Elementary_Functions; -with FXA5A00; -with Report; - -procedure CXA5A03 is -begin - - Report.Test ("CXA5A03", "Check that the functions Tan, Tanh, and " & - "Arctanh provide correct results"); - - Test_Block: - declare - - use Ada.Numerics; - use FXA5A00; - - package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); - package EF renames Ada.Numerics.Elementary_Functions; - - The_Result : Float; - New_Float_Result : New_Float; - - procedure Dont_Optimize_Float is new Dont_Optimize(Float); - procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); - - begin - - -- Testing of Tan Function, both instantiated and pre-instantiated - -- version. - - -- Check that no exception occurs on computing the Tan with very - -- large (positive and negative) input values. - - begin - New_Float_Result := GEF.Tan (New_Float(FXA5A00.Large)); - Dont_Optimize_New_Float(New_Float_Result, 1); - exception - when others => - Report.Failed("Unexpected exception on GEF.Tan with large " & - "positive value"); - end; - - begin - The_Result := EF.Tan (FXA5A00.Minus_Large); - Dont_Optimize_Float(The_Result, 2); - exception - when others => - Report.Failed("Unexpected exception on EF.Tan with large " & - "negative value"); - end; - - - -- Check that no exception occurs on computing the Tan with very - -- small (positive and negative) input values. - - begin - New_Float_Result := GEF.Tan (New_Float(FXA5A00.Small)); - Dont_Optimize_New_Float(New_Float_Result, 3); - exception - when others => - Report.Failed("Unexpected exception on GEF.Tan with small " & - "positive value"); - end; - - begin - The_Result := EF.Tan (-FXA5A00.Small); - Dont_Optimize_Float(The_Result, 4); - exception - when others => - Report.Failed("Unexpected exception on EF.Tan with small " & - "negative value"); - end; - - - -- Check prescribed result from Tan function. When the parameter X - -- has the value zero, the Tan function yields a result of zero. - - if GEF.Tan(0.0) /= 0.0 or - EF.Tan(0.0) /= 0.0 - then - Report.Failed("Incorrect result from Tan function with zero " & - "value input parameter"); - end if; - - - -- Check the results of the Tan function with various input parameters. - - if not (Result_Within_Range(GEF.Tan(0.7854), 1.0, 0.001) and - Result_Within_Range(GEF.Tan(0.8436), 1.124, 0.001) and - Result_Within_Range( EF.Tan(Pi), 0.0, 0.001) and - Result_Within_Range( EF.Tan(-Pi), 0.0, 0.001) and - Result_Within_Range(GEF.Tan(0.5381), 0.597, 0.001) and - Result_Within_Range( EF.Tan(0.1978), 0.200, 0.001)) - then - Report.Failed("Incorrect result from Tan function with various " & - "input parameters"); - end if; - - - -- Testing of Tan function with cycle parameter. - - -- Check that Constraint_Error is raised by the Tan function with - -- specified cycle, when the value of the parameter X is an odd - -- multiple of the quarter cycle. - - if New_Float'Machine_Overflows = True then - begin - New_Float_Result := GEF.Tan(270.0, 360.0); - Report.Failed("Constraint_Error not raised by GEF.Tan on odd " & - "multiple of the quarter cycle"); - Dont_Optimize_New_Float(New_Float_Result, 5); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by GEF.Tan on odd " & - "multiple of the quarter cycle"); - end; - end if; - - -- Check that the exception Numerics.Argument_Error is raised, when - -- the value of the parameter Cycle is zero or negative. - - begin - New_Float_Result := GEF.Tan(X => 1.0, Cycle => -360.0); - Report.Failed("Argument_Error not raised by GEF.Tan when Cycle " & - "parameter has negative value"); - Dont_Optimize_New_Float(New_Float_Result, 6); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by GEF.Tan when Cycle " & - "parameter has negative value"); - end; - - begin - The_Result := EF.Tan(1.0, Cycle => 0.0); - Report.Failed("Argument_Error not raised by GEF.Tan when Cycle " & - "parameter has a zero value"); - Dont_Optimize_Float(The_Result, 7); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by EF.Tan when Cycle " & - "parameter has a zero value"); - end; - - - -- Check that no exception occurs on computing the Tan with very - -- large (positive and negative) input values. - - begin - New_Float_Result := GEF.Tan (New_Float(FXA5A00.Large), 360.0); - Dont_Optimize_New_Float(New_Float_Result, 8); - exception - when others => - Report.Failed("Unexpected exception on GEF.Tan with large " & - "positive value"); - end; - - begin - The_Result := EF.Tan (FXA5A00.Minus_Large, Cycle => 360.0); - Dont_Optimize_Float(The_Result, 9); - exception - when others => - Report.Failed("Unexpected exception on EF.Tan with large " & - "negative value"); - end; - - - -- Check prescribed result from Tan function with Cycle parameter. - - if GEF.Tan(0.0, 360.0) /= 0.0 or - EF.Tan(0.0, Cycle => 360.0) /= 0.0 - then - Report.Failed("Incorrect result from Tan function with cycle " & - "parameter, using a zero value input parameter"); - end if; - - - -- Check the Tan function, with specified Cycle parameter, with a - -- variety of input parameters. - - if not Result_Within_Range(GEF.Tan(30.0, 360.0), 0.577, 0.001) or - not Result_Within_Range( EF.Tan(57.0, 360.0), 1.540, 0.001) or - not Result_Within_Range(GEF.Tan(115.0, 360.0), -2.145, 0.001) or - not Result_Within_Range( EF.Tan(299.0, 360.0), -1.804, 0.001) or - not Result_Within_Range(GEF.Tan(390.0, 360.0), 0.577, 0.001) or - not Result_Within_Range( EF.Tan(520.0, 360.0), -0.364, 0.001) - then - Report.Failed("Incorrect result from the Tan function with " & - "cycle parameter, with various input parameter " & - "values"); - end if; - - - - -- Testing of Tanh Function, both instantiated and pre-instantiated - -- version. - - -- Check that no exception occurs on computing the Tan with very - -- large (positive and negative) input values. - - begin - New_Float_Result := GEF.Tanh (New_Float(FXA5A00.Large)); - Dont_Optimize_New_Float(New_Float_Result, 10); - exception - when others => - Report.Failed("Unexpected exception on GEF.Tanh with large " & - "positive value"); - end; - - begin - The_Result := EF.Tanh (FXA5A00.Minus_Large); - Dont_Optimize_Float(The_Result, 11); - exception - when others => - Report.Failed("Unexpected exception on EF.Tanh with large " & - "negative value"); - end; - - - -- Check for prescribed result of Tanh with zero value input parameter. - - if GEF.Tanh (0.0) /= 0.0 or - EF.Tanh (0.0) /= 0.0 - then - Report.Failed("Incorrect result from Tanh with zero parameter"); - end if; - - - -- Check the results of the Tanh function with various input - -- parameters. - - if not (FXA5A00.Result_Within_Range(GEF.Tanh(2.99), 0.995, 0.001) and - FXA5A00.Result_Within_Range(GEF.Tanh(0.130), 0.129, 0.001) and - FXA5A00.Result_Within_Range( EF.Tanh(Pi), 0.996, 0.001) and - FXA5A00.Result_Within_Range( EF.Tanh(-Pi), -0.996, 0.001) and - FXA5A00.Result_Within_Range(GEF.Tanh(0.60), 0.537, 0.001) and - FXA5A00.Result_Within_Range( EF.Tanh(1.04), 0.778, 0.001) and - FXA5A00.Result_Within_Range(GEF.Tanh(1.55), 0.914, 0.001) and - FXA5A00.Result_Within_Range( EF.Tanh(-2.14), -0.973, 0.001)) - then - Report.Failed("Incorrect result from Tanh function with various " & - "input parameters"); - end if; - - - - -- Testing of Arctanh Function, both instantiated and pre-instantiated - -- version. - - -- Check that Constraint_Error is raised by the Arctanh function - -- when the absolute value of the parameter X is one. - - if New_Float'Machine_Overflows = True then - begin - New_Float_Result := GEF.Arctanh(X => 1.0); - Report.Failed("Constraint_Error not raised by Function Arctanh " & - "when provided a parameter value of 1.0"); - Dont_Optimize_New_Float(New_Float_Result, 12); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Arctanh " - & "when provided a parameter value of 1.0"); - end; - end if; - - if Float'Machine_Overflows = True then - begin - The_Result := EF.Arctanh(-1.0); - Report.Failed("Constraint_Error not raised by Function Arctanh " & - "when provided a parameter value of -1.0"); - Dont_Optimize_Float(The_Result, 13); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Arctanh " - & "when provided a parameter value of -1.0"); - end; - end if; - - -- Check that Function Arctanh raises Argument_Error when the absolute - -- value of the parameter X exceeds one. - - begin - New_Float_Result := GEF.Arctanh(New_Float(FXA5A00.One_Plus_Delta)); - Report.Failed("Argument_Error not raised by Function Arctanh " & - "when provided a parameter value greater than 1.0"); - Dont_Optimize_New_Float(New_Float_Result, 14); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Arctanh " & - "when provided a parameter value greater than 1.0"); - end; - - - begin - The_Result := EF.Arctanh(FXA5A00.Minus_One_Minus_Delta); - Report.Failed("Argument_Error not raised by Function Arctanh " & - "when provided a parameter value less than -1.0"); - Dont_Optimize_Float(The_Result, 15); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Arctanh " & - "when provided a parameter value less than -1.0"); - end; - - - begin - New_Float_Result := GEF.Arctanh(New_Float(FXA5A00.Large)); - Report.Failed("Argument_Error not raised by Function Arctanh " & - "when provided a large positive parameter value"); - Dont_Optimize_New_Float(New_Float_Result, 16); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Arctanh " & - "when provided a large positive parameter value"); - end; - - - begin - The_Result := EF.Arctanh(FXA5A00.Minus_Large); - Report.Failed("Argument_Error not raised by Function Arctanh " & - "when provided a large negative parameter value"); - Dont_Optimize_Float(The_Result, 17); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Arctanh " & - "when provided a large negative parameter value"); - end; - - - -- Prescribed results for Function Arctanh with zero input value. - - if GEF.Arctanh(0.0) /= 0.0 or - EF.Arctanh(0.0) /= 0.0 - then - Report.Failed("Incorrect result from Function Arctanh with a " & - "parameter value of zero"); - end if; - - - -- Check the results of the Arctanh function with various input - -- parameters. - - if not (Result_Within_Range(GEF.Arctanh(0.15), 0.151, 0.001) and - Result_Within_Range( EF.Arctanh(0.44), 0.472, 0.001) and - Result_Within_Range(GEF.Arctanh(0.81), 1.127, 0.001) and - Result_Within_Range( EF.Arctanh(0.99), 2.647, 0.001)) - then - Report.Failed("Incorrect result from Arctanh function with " & - "various input parameters"); - end if; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA5A03; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a deleted file mode 100644 index 9b590a23cb8..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a +++ /dev/null @@ -1,434 +0,0 @@ --- CXA5A04.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 Cot, Coth, and Arccoth provide correct --- results. --- --- TEST DESCRIPTION: --- This test examines both the version of Cot, Coth, and Arccoth --- the instantiation of the Ada.Numerics.Generic_Elementary_Functions --- with a type derived from type Float, as well as the preinstantiated --- version of this package for type Float. --- Prescribed results, including instances prescribed to raise --- exceptions, are examined in the test cases. In addition, --- certain evaluations are performed where the actual function result --- is compared with the expected result (within an epsilon range of --- accuracy). --- --- TEST FILES: --- The following files comprise this test: --- --- FXA5A00.A (foundation code) --- CXA5A04.A --- --- --- CHANGE HISTORY: --- 15 Mar 95 SAIC Initial prerelease version. --- 07 Apr 95 SAIC Corrected errors in context clause reference, --- added trigonometric relationship checks. --- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and --- use of Result_Within_Range function overloaded for --- FXA5A00.New_Float_Type. --- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi --- 29 Jun 98 EDS Protected exception tests by first testing --- for 'Machine_Overflows --- --- CHANGE NOTE: --- According to Ken Dritz, author of the Numerics Annex of the RM, --- one should never specify the cycle 2.0*Pi for the trigonometric --- functions. In particular, if the machine number for the first --- argument is not an exact multiple of the machine number for the --- explicit cycle, then the specified exact results cannot be --- reasonably expected. The affected checks in this test have been --- marked as comments, with the additional notation "pwb-math". --- Phil Brashear ---! - -with Ada.Exceptions; -with Ada.Numerics.Elementary_Functions; -with Ada.Numerics.Generic_Elementary_Functions; -with FXA5A00; -with Report; - -procedure CXA5A04 is -begin - - Report.Test ("CXA5A04", "Check that the functions Cot, Coth, and " & - "Arccoth provide correct results"); - - Test_Block: - declare - - use Ada.Exceptions; - use Ada.Numerics; - use FXA5A00; - - package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); - package EF renames Ada.Numerics.Elementary_Functions; - - The_Result : Float; - New_Float_Result : New_Float; - - procedure Dont_Optimize_Float is new Dont_Optimize(Float); - procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); - - begin - - -- Testing of Cot Function, both instantiated and pre-instantiated - -- version. - - -- Check that Constraint_Error is raised with the Cot function is - -- given a parameter input value of 0.0. - - if New_Float'Machine_Overflows = True then - begin - New_Float_Result := GEF.Cot (0.0); - Report.Failed("Constraint_Error not raised by Function Cot " & - "when provided a zero input parameter value"); - Dont_Optimize_New_Float(New_Float_Result, 1); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Cot " & - "when provided a zero input parameter value"); - end; - end if; - - -- Check that no exception occurs on computing the Cot with very - -- large (positive and negative) input values. - - begin - New_Float_Result := GEF.Cot (New_Float(FXA5A00.Large)); - Dont_Optimize_New_Float(New_Float_Result, 2); - exception - when others => - Report.Failed("Unexpected exception on GEF.Cot with large " & - "positive value"); - end; - - begin - The_Result := EF.Cot (FXA5A00.Minus_Large); - Dont_Optimize_Float(The_Result, 3); - exception - when others => - Report.Failed("Unexpected exception on EF.Cot with large " & - "negative value"); - end; - - - -- Check the results of the Cot function with various input parameters. - - if not (FXA5A00.Result_Within_Range(GEF.Cot(Pi/4.0), 1.0, 0.001) and - FXA5A00.Result_Within_Range( EF.Cot(Pi/2.0), 0.0, 0.001) and - FXA5A00.Result_Within_Range(GEF.Cot(3.0*Pi/4.0),-1.0, 0.001) and - FXA5A00.Result_Within_Range( EF.Cot(3.0*Pi/2.0), 0.0, 0.001)) - then - Report.Failed("Incorrect result from Cot function with various " & - "input parameters"); - end if; - - - -- Check the results of the Cot function against the results of - -- various trigonometric relationships. - - if not FXA5A00.Result_Within_Range(GEF.Cot(New_Float(Pi/4.0)), - 1.0/EF.Tan(Pi/4.0), - 0.001) or - not FXA5A00.Result_Within_Range(EF.Cot(Pi/4.0), - EF.Cos(Pi/4.0)/EF.Sin(Pi/4.0), - 0.001) or - not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(Pi/4.0)), - Pi/4.0, - 0.001) - then - Report.Failed("Incorrect result from Cot function with respect " & - "to various trigonometric relationship expected " & - "results"); - end if; - - - -- Testing of Cot with Cycle parameter. - - -- Check that Argument_Error is raised by the Cot function when the - -- value of the Cycle parameter is zero or negative. - - begin - New_Float_Result := GEF.Cot (1.0, Cycle => 0.0); - Report.Failed("Argument_Error not raised by the Cot Function " & - "with a specified cycle value of 0.0"); - Dont_Optimize_New_Float(New_Float_Result, 4); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed - ("Unexpected exception raised by the Cot Function with " & - "a specified cycle value of 0.0"); - end; - - begin - The_Result := EF.Cot (X => 1.0, Cycle => -360.0); - Report.Failed("Argument_Error not raised by the Cot Function " & - "with a specified cycle value of -360.0"); - Dont_Optimize_Float(The_Result, 5); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed - ("Unexpected exception raised by the Cot Function with " & - "a specified cycle value of -360.0"); - end; - - - -- Check that Constraint_Error is raised by the Cot Function with - -- specified cycle, when the value of the parameter X is 0.0. - - if New_Float'Machine_Overflows = True then - begin - New_Float_Result := GEF.Cot (0.0, 360.0); - Report.Failed("Constraint_Error not raised by Function Cot " & - "with specified cycle, when value of parameter " & - "X is 0.0"); - Dont_Optimize_New_Float(New_Float_Result, 6); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Cot " & - "with specified cycle, when value of parameter " & - "X is 0.0"); - end; - end if; - - -- Check that Constraint_Error is raised by the Cot Function with - -- specified cycle, when the value of the parameter X is a multiple - -- of the half cycle. - - if New_Float'Machine_Overflows = True then - begin - New_Float_Result := GEF.Cot (180.0, 360.0); - Report.Failed("Constraint_Error not raised by Function Cot " & - "with specified cycle, when value of parameter " & - "X is a multiple of the half cycle (180.0, 360.0)"); - Dont_Optimize_New_Float(New_Float_Result, 7); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Cot " & - "with specified cycle, when value of parameter " & - "X is a multiple of the half cycle" & - " (180.0, 360.0)"); - end; - end if; - - if Float'Machine_Overflows = True then - begin - The_Result := EF.Cot (540.0, 360.0); - Report.Failed("Constraint_Error not raised by Function Cot " & - "with specified cycle, when value of parameter " & - "X is a multiple of the half cycle (540.0, 360.0)"); - Dont_Optimize_Float(The_Result, 8); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Cot " & - "with specified cycle, when value of parameter " & - "X is a multiple of the half cycle (540.0, 360.0)"); - end; - end if; - ---pwb-math -- Check that no exception occurs on computing the Cot with very ---pwb-math -- large (positive and negative) input values. ---pwb-math ---pwb-math begin ---pwb-math New_Float_Result := GEF.Cot (New_Float(FXA5A00.Large), 2.0*Pi); ---pwb-math Dont_Optimize_New_Float(New_Float_Result, 9); ---pwb-math exception ---pwb-math when others => ---pwb-math Report.Failed("Unexpected exception on GEF.Cot with large " & ---pwb-math "positive value"); ---pwb-math end; ---pwb-math ---pwb-math begin ---pwb-math The_Result := EF.Cot (FXA5A00.Minus_Large, Cycle => 2.0*Pi); ---pwb-math Dont_Optimize_Float(The_Result, 10); ---pwb-math exception ---pwb-math when others => ---pwb-math Report.Failed("Unexpected exception on EF.Cot with large " & ---pwb-math "negative value"); ---pwb-math end; ---pwb-math ---pwb-math ---pwb-math -- Check prescribed result from Cot function with Cycle parameter. ---pwb-math ---pwb-math if not FXA5A00.Result_Within_Range ---pwb-math (GEF.Cot(New_Float(FXA5A00.Half_Pi), 2.0*Pi), 0.0, 0.001) or ---pwb-math not FXA5A00.Result_Within_Range ---pwb-math (EF.Cot(3.0*Pi/2.0, Cycle => 2.0*Pi), 0.0, 0.001) ---pwb-math then ---pwb-math Report.Failed("Incorrect result from Cot function with cycle " & ---pwb-math "parameter, using a multiple of Pi/2 as the " & ---pwb-math "input parameter"); ---pwb-math end if; - - - -- Testing of Coth Function, both instantiated and pre-instantiated - -- version. - - -- Check that no exception occurs on computing the Coth with very - -- large (positive and negative) input values. - - begin - The_Result := EF.Coth (FXA5A00.Large); - if The_Result > 1.0 then - Report.Failed("Result of Coth function with large positive " & - "value greater than 1.0"); - end if; - exception - when others => - Report.Failed("Unexpected exception on EF.Coth with large " & - "positive value"); - end; - - begin - The_Result := EF.Coth (FXA5A00.Minus_Large); - if The_Result < -1.0 then - Report.Failed("Result of Coth function with large negative " & - "value less than -1.0"); - end if; - exception - when others => - Report.Failed("Unexpected exception on EF.Coth with large " & - "negative value"); - end; - - - -- Check that Constraint_Error is raised by the Coth function, when - -- the value of the parameter X is 0.0. - - if New_Float'Machine_Overflows = True then - begin - New_Float_Result := GEF.Coth (X => 0.0); - Report.Failed("Constraint_Error not raised by the Coth function " & - "when the value of parameter X is 0.0"); - Dont_Optimize_New_Float(New_Float_Result, 11); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Coth " & - "function when the value of parameter X is 0.0"); - end; - end if; - - - -- Testing of Arccoth Function, both instantiated and pre-instantiated - -- version. - - -- Check that Constraint_Error is raised by the Arccoth function - -- when the absolute value of the parameter X is 1.0. - - if New_Float'Machine_Overflows = True then - begin - New_Float_Result := GEF.Arccoth (X => 1.0); - Report.Failed("Constraint_Error not raised by the Arccoth " & - "function when the value of parameter X is 1.0"); - Dont_Optimize_New_Float(New_Float_Result, 12); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Arccoth " & - "function when the value of parameter X is 1.0"); - end; - end if; - - if Float'Machine_Overflows = True then - begin - The_Result := EF.Arccoth (-1.0); - Report.Failed("Constraint_Error not raised by the Arccoth " & - "function when the value of parameter X is -1.0"); - Dont_Optimize_Float(The_Result, 13); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Arccoth " & - "function when the value of parameter X is -1.0"); - end; - end if; - - -- Check that Argument_Error is raised by the Arccoth function when - -- the absolute value of the parameter X is less than 1.0. - - begin - New_Float_Result := GEF.Arccoth (X => New_Float(One_Minus_Delta)); - Report.Failed("Argument_Error not raised by the Arccoth " & - "function with parameter value less than 1.0"); - Dont_Optimize_New_Float(New_Float_Result, 14); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Arccoth " & - "function with parameter value less than 1.0"); - end; - - begin - The_Result := EF.Arccoth (X => FXA5A00.Minus_One_Plus_Delta); - Report.Failed("Argument_Error not raised by the Arccoth function " & - "with parameter value between 0.0 and -1.0"); - Dont_Optimize_Float(The_Result, 15); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Arccoth " & - "function with parameter value between 0.0 " & - "and -1.0"); - end; - - - -- Check the results of the Arccoth function with various input - -- parameters. - - if not (Result_Within_Range(GEF.Arccoth(1.01), 2.652, 0.01) and - Result_Within_Range( EF.Arccoth(1.25), 1.099, 0.01) and - Result_Within_Range(GEF.Arccoth(1.56), 0.760, 0.001) and - Result_Within_Range( EF.Arccoth(1.97), 0.560, 0.001) and - Result_Within_Range(GEF.Arccoth(2.40), 0.444, 0.001) and - Result_Within_Range( EF.Arccoth(4.30), 0.237, 0.001) and - Result_Within_Range(GEF.Arccoth(5.80), 0.174, 0.001) and - Result_Within_Range( EF.Arccoth(7.00), 0.144, 0.001)) - then - Report.Failed("Incorrect result from Arccoth function with various " & - "input parameters"); - end if; - - - exception - when The_Error : others => - Report.Failed ("The following exception was raised in the " & - "Test_Block: " & Exception_Name(The_Error)); - end Test_Block; - - Report.Result; - -end CXA5A04; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a deleted file mode 100644 index b50da3a6ab5..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a +++ /dev/null @@ -1,338 +0,0 @@ --- CXA5A05.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 Arcsin and Arcsinh provide correct --- results. --- --- TEST DESCRIPTION: --- This test examines both the version of Arcsin and Arcsinh --- the instantiation of the Ada.Numerics.Generic_Elementary_Functions --- with a type derived from type Float, as well as the preinstantiated --- version of this package for type Float. --- Prescribed results, including instances prescribed to raise --- exceptions, are examined in the test cases. In addition, --- certain evaluations are performed where the actual function result --- is compared with the expected result (within an epsilon range of --- accuracy). --- --- TEST FILES: --- The following files comprise this test: --- --- FXA5A00.A (foundation code) --- CXA5A05.A --- --- --- CHANGE HISTORY: --- 20 Mar 95 SAIC Initial prerelease version. --- 06 Apr 95 SAIC Corrected errors in context clause reference and --- use of Cycle parameter. --- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and --- use of Result_Within_Range function overloaded for --- FXA5A00.New_Float_Type. --- 28 Feb 97 PWB.CTA Removed checks with explict Cycle => 2.0*Pi --- --- CHANGE NOTE: --- According to Ken Dritz, author of the Numerics Annex of the RM, --- one should never specify the cycle 2.0*Pi for the trigonometric --- functions. In particular, if the machine number for the first --- argument is not an exact multiple of the machine number for the --- explicit cycle, then the specified exact results cannot be --- reasonably expected. The affected checks in this test have been --- marked as comments, with the additional notation "pwb-math". --- Phil Brashear ---! - -with Ada.Numerics.Elementary_Functions; -with Ada.Numerics.Generic_Elementary_Functions; -with FXA5A00; -with Report; - -procedure CXA5A05 is -begin - - Report.Test ("CXA5A05", "Check that the functions Arcsin and Arcsinh " & - "provide correct results"); - - Test_Block: - declare - - use Ada.Numerics; - use FXA5A00; - - package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); - package EF renames Ada.Numerics.Elementary_Functions; - - The_Result : Float; - New_Float_Result : New_Float; - - procedure Dont_Optimize_Float is new Dont_Optimize(Float); - procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); - - begin - - -- Testing of Function Arcsin, both instantiated and pre-instantiated - -- versions. - - -- Check that Argument_Error is raised by the Arcsin function when - -- the absolute value of the parameter X is greater than 1.0. - - begin - New_Float_Result := GEF.Arcsin(New_Float(FXA5A00.One_Plus_Delta)); - Report.Failed("Argument_Error not raised by Arcsin function " & - "when provided a parameter value larger than 1.0"); - Dont_Optimize_New_Float(New_Float_Result, 1); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Arcsin function " & - "when provided a parameter value larger than 1.0"); - end; - - begin - The_Result := EF.Arcsin(FXA5A00.Minus_Large); - Report.Failed("Argument_Error not raised by Arcsin function " & - "when provided a large negative parameter value"); - Dont_Optimize_Float(The_Result, 2); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Arcsin function " & - "when provided a large negative parameter value"); - end; - - - -- Check the prescribed result of function Arcsin with parameter 0.0. - - if GEF.Arcsin(X => 0.0) /= 0.0 or - EF.Arcsin(0.0) /= 0.0 - then - Report.Failed("Incorrect result from Function Arcsin when the " & - "value of the parameter X is 0.0"); - end if; - - - -- Check the results of the Arcsin function with various input - -- parameters. - - if not Result_Within_Range(GEF.Arcsin(1.0), 1.571, 0.001) or - not Result_Within_Range( EF.Arcsin(0.62), 0.669, 0.001) or - not Result_Within_Range(GEF.Arcsin(0.01), 0.010, 0.001) or - not Result_Within_Range( EF.Arcsin(-0.29), -0.294, 0.001) or - not Result_Within_Range(GEF.Arcsin(-0.50), -0.524, 0.001) or - not Result_Within_Range( EF.Arcsin(-1.0), -1.571, 0.001) - then - Report.Failed("Incorrect result from Function Arcsin with " & - "various input parameters"); - end if; - - - -- Testing of Function Arcsin with specified Cycle parameter. - ---pwb-math -- Check that Argument_Error is raised by the Arcsin function with ---pwb-math -- specified cycle, whenever the absolute value of the parameter X ---pwb-math -- is greater than 1.0. ---pwb-math ---pwb-math begin ---pwb-math New_Float_Result := GEF.Arcsin(New_Float(FXA5A00.Large), 2.0*Pi); ---pwb-math Report.Failed("Argument_Error not raised by Function Arcsin " & ---pwb-math "with specified cycle, when provided a large " & ---pwb-math "positive input parameter"); ---pwb-math Dont_Optimize_New_Float(New_Float_Result, 3); ---pwb-math exception ---pwb-math when Argument_Error => null; -- OK, expected exception. ---pwb-math when others => ---pwb-math Report.Failed("Unexpected exception raised by Function Arcsin " & ---pwb-math "with specified cycle, when provided a large " & ---pwb-math "positive input parameter"); ---pwb-math end; ---pwb-math ---pwb-math begin ---pwb-math The_Result := EF.Arcsin(FXA5A00.Minus_One_Minus_Delta, 2.0*Pi); ---pwb-math Report.Failed("Argument_Error not raised by Function Arcsin " & ---pwb-math "with specified cycle, when provided an input " & ---pwb-math "parameter less than -1.0"); ---pwb-math Dont_Optimize_Float(The_Result, 4); ---pwb-math exception ---pwb-math when Argument_Error => null; -- OK, expected exception. ---pwb-math when others => ---pwb-math Report.Failed("Unexpected exception raised by Function Arcsin " & ---pwb-math "with specified cycle, when provided an input " & ---pwb-math "parameter less than -1.0"); ---pwb-math end; ---pwb-math - -- Check that Argument_Error is raised by the Arcsin function with - -- specified cycle, whenever the Cycle parameter is zero or negative. - - begin - New_Float_Result := GEF.Arcsin(2.0, 0.0); - Report.Failed("Argument_Error not raised by Function Arcsin " & - "with specified cycle of 0.0"); - Dont_Optimize_New_Float(New_Float_Result, 5); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Arcsin " & - "with specified cycle of 0.0"); - end; - - begin - The_Result := EF.Arcsin(2.0, -2.0*Pi); - Report.Failed("Argument_Error not raised by Function Arcsin " & - "with specified negative cycle parameter"); - Dont_Optimize_Float(The_Result, 6); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Arcsin " & - "with specified negative cycle parameter"); - end; - - ---pwb-math -- Check the prescribed result of function Arcsin with specified Cycle ---pwb-math -- parameter, when the value of parameter X is 0.0. ---pwb-math ---pwb-math if GEF.Arcsin(X => 0.0, Cycle => 2.0*Pi) /= 0.0 or ---pwb-math EF.Arcsin(0.0, 2.0*Pi) /= 0.0 ---pwb-math then ---pwb-math Report.Failed("Incorrect result from Function Arcsin with " & ---pwb-math "specified Cycle parameter, when the value " & ---pwb-math "of parameter X is 0.0"); ---pwb-math end if; ---pwb-math ---pwb-math ---pwb-math -- Test of the Arcsin function with specified Cycle parameter with ---pwb-math -- various input parameters. ---pwb-math ---pwb-math if not FXA5A00.Result_Within_Range(GEF.Arcsin( 0.01, 2.0*Pi), ---pwb-math 0.010, ---pwb-math 0.001) or ---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin( 0.14, 2.0*Pi), ---pwb-math 0.141, ---pwb-math 0.001) or ---pwb-math not FXA5A00.Result_Within_Range(GEF.Arcsin( 0.37, 2.0*Pi), ---pwb-math 0.379, ---pwb-math 0.001) or ---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin( 0.55, 2.0*Pi), ---pwb-math 0.582, ---pwb-math 0.001) or ---pwb-math not FXA5A00.Result_Within_Range(GEF.Arcsin(-0.22, 2.0*Pi), ---pwb-math -0.222, ---pwb-math 0.001) or ---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(-0.99, 2.0*Pi), ---pwb-math -1.43, ---pwb-math 0.01) or ---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(1.0, 360.0), ---pwb-math 90.0, ---pwb-math 0.1) or ---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(1.0, 100.0), ---pwb-math 25.0, ---pwb-math 0.1) ---pwb-math then ---pwb-math Report.Failed("Incorrect result from Arcsin with specified " & ---pwb-math "cycle parameter with various input parameters"); ---pwb-math end if; - - -- Testing of Arcsinh Function, both instantiated and pre-instantiated - -- version. - - -- Check that no exception occurs on computing the Arcsinh with very - -- large (positive and negative) input values. - - begin - New_Float_Result := GEF.Arcsinh(New_Float(FXA5A00.Large)); - Dont_Optimize_New_Float(New_Float_Result, 7); - exception - when others => - Report.Failed("Unexpected exception on Arcsinh with large " & - "positive value"); - end; - - begin - The_Result := EF.Arcsinh(FXA5A00.Minus_Large); - Dont_Optimize_Float(The_Result, 8); - exception - when others => - Report.Failed("Unexpected exception on Arcsinh with large " & - "negative value"); - end; - - - -- Check that no exception occurs on computing the Arcsinh with very - -- small (positive and negative) input values. - - begin - New_Float_Result := GEF.Arcsinh(New_Float(FXA5A00.Small)); - Dont_Optimize_New_Float(New_Float_Result, 9); - exception - when others => - Report.Failed("Unexpected exception on Arcsinh with small " & - "positive value"); - end; - - begin - The_Result := EF.Arcsinh(-FXA5A00.Small); - Dont_Optimize_Float(The_Result, 10); - exception - when others => - Report.Failed("Unexpected exception on Arcsinh with small " & - "negative value"); - end; - - - -- Check function Arcsinh for prescribed result with parameter 0.0. - - if GEF.Arcsinh(X => 0.0) /= 0.0 or - EF.Arcsinh(X => 0.0) /= 0.0 - then - Report.Failed("Incorrect result from Function Arcsinh when " & - "provided a 0.0 input parameter"); - end if; - - - -- Check the results of the Arcsinh function with various input - -- parameters. - - if not Result_Within_Range(GEF.Arcsinh(0.15), 0.149, 0.001) or - not Result_Within_Range( EF.Arcsinh(0.82), 0.748, 0.001) or - not Result_Within_Range(GEF.Arcsinh(1.44), 1.161, 0.001) or - not Result_Within_Range(GEF.Arcsinh(6.70), 2.601, 0.001) or - not Result_Within_Range( EF.Arcsinh(Pi), 1.862, 0.001) or - not Result_Within_Range( EF.Arcsinh(-Pi), -1.862, 0.001) or - not Result_Within_Range(GEF.Arcsinh(-1.0), -0.881, 0.001) or - not Result_Within_Range( EF.Arcsinh(-5.5), -2.406, 0.001) - then - Report.Failed("Incorrect result from Function Arcsin with " & - "various input parameters"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA5A05; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a deleted file mode 100644 index 191a96d7567..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a +++ /dev/null @@ -1,334 +0,0 @@ --- CXA5A06.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 Arccos and Arccosh provide correct --- results. --- --- TEST DESCRIPTION: --- This test examines both the version of Arccos and Arccosh --- the instantiation of the Ada.Numerics.Generic_Elementary_Functions --- with a type derived from type Float, as well as the preinstantiated --- version of this package for type Float. --- Prescribed results, including instances prescribed to raise --- exceptions, are examined in the test cases. In addition, --- certain evaluations are performed where the actual function result --- is compared with the expected result (within an epsilon range of --- accuracy). --- --- TEST FILES: --- The following files comprise this test: --- --- FXA5A00.A (foundation code) --- CXA5A06.A --- --- --- CHANGE HISTORY: --- 27 Mar 95 SAIC Initial prerelease version. --- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and --- use of Result_Within_Range function overloaded for --- FXA5A00.New_Float_Type. --- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi --- --- CHANGE NOTE: --- According to Ken Dritz, author of the Numerics Annex of the RM, --- one should never specify the cycle 2.0*Pi for the trigonometric --- functions. In particular, if the machine number for the first --- argument is not an exact multiple of the machine number for the --- explicit cycle, then the specified exact results cannot be --- reasonably expected. The affected checks in this test have been --- marked as comments, with the additional notation "pwb-math". --- Phil Brashear ---! - -with Ada.Numerics.Elementary_Functions; -with Ada.Numerics.Generic_Elementary_Functions; -with FXA5A00; -with Report; - -procedure CXA5A06 is -begin - - Report.Test ("CXA5A06", "Check that the functions Arccos and Arccosh " & - "provide correct results"); - - Test_Block: - declare - - use Ada.Numerics; - use FXA5A00; - - package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); - package EF renames Ada.Numerics.Elementary_Functions; - - The_Result : Float; - New_Float_Result : New_Float; - - procedure Dont_Optimize_Float is new Dont_Optimize(Float); - procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); - - begin - - -- Testing of Arccos Function, both instantiated and pre-instantiated - -- version. - - -- Check that Argument_Error is raised by the Arccos function when the - -- absolute value of the input parameter is greater than 1.0. - - begin - New_Float_Result := GEF.Arccos(New_Float(FXA5A00.One_Plus_Delta)); - Report.Failed("Argument_Error not raised by the Arccos function " & - "when the input parameter is greater than 1.0"); - Dont_Optimize_New_Float(New_Float_Result, 1); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Arccos " & - "function when the input parameter is greater " & - "than 1.0"); - end; - - begin - The_Result := EF.Arccos(-FXA5A00.Large); - Report.Failed("Argument_Error not raised by the Arccos function " & - "when the input parameter is a large negative value"); - Dont_Optimize_Float(The_Result, 2); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Arccos " & - "function when the input parameter is a " & - "large negative value"); - end; - - - -- Check the prescribed results of the Arccos function. - - if GEF.Arccos(X => 1.0) /= 0.0 or - EF.Arccos(1.0) /= 0.0 - then - Report.Failed("Incorrect result returned by the Arccos function " & - "when provided a parameter value of 0.0"); - end if; - - - -- Check the results of the Arccos function with various input - -- parameters. - - if not Result_Within_Range(GEF.Arccos(0.77), 0.692, 0.001) or - not Result_Within_Range( EF.Arccos(0.37), 1.19, 0.01) or - not Result_Within_Range(GEF.Arccos(0.0), Pi/2.0, 0.01) or - not Result_Within_Range( EF.Arccos(-0.11), 1.68, 0.01) or - not Result_Within_Range(GEF.Arccos(-0.67), 2.31, 0.01) or - not Result_Within_Range( EF.Arccos(-0.94), 2.79, 0.01) or - not Result_Within_Range(GEF.Arccos(-1.0), Pi, 0.01) - then - Report.Failed("Incorrect result returned from the Arccos " & - "function when provided a variety of input " & - "parameters"); - end if; - - - -- Testing of the Arccos function with specified Cycle parameter. - - -- Check that Argument_Error is raised by the Arccos function, with - -- specified Cycle parameter, when the absolute value of the input - -- parameter is greater than 1.0. - - begin ---pwb-math: Next line: Changed 2.0*Pi to 360.0 - New_Float_Result := GEF.Arccos(New_Float(Large), Cycle => 360.0); - Report.Failed("Argument_Error not raised by the Arccos function " & - "with specified Cycle parameter, when the input " & - "parameter is a large positive value"); - Dont_Optimize_New_Float(New_Float_Result, 3); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Arccos " & - "function with specified Cycle parameter, when " & - "the input parameter is a large positive value"); - end; - - begin ---pwb-math: Next line: Changed 2.0*Pi to 360.0 - The_Result := EF.Arccos(FXA5A00.Minus_One_Minus_Delta, 360.0); - Report.Failed("Argument_Error not raised by the Arccos function " & - "with specified Cycle parameter, when the input " & - "parameter is less than -1.0"); - Dont_Optimize_Float(The_Result, 4); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Arccos " & - "function with specified Cycle parameter, " & - "when the input parameter is less than -1.0"); - end; - - - -- Check that Argument_Error is raised by the Arccos function with - -- specified cycle when the value of the Cycle parameter is zero or - -- negative. - - begin - New_Float_Result := GEF.Arccos(X => 1.0, Cycle => 0.0 ); - Report.Failed("Argument_Error not raised by the Arccos function " & - "with specified Cycle parameter, when the Cycle " & - "parameter is 0.0"); - Dont_Optimize_New_Float(New_Float_Result, 5); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Arccos " & - "function with specified Cycle parameter, when " & - "the Cycle parameter is 0.0"); - end; - - begin - The_Result := EF.Arccos(1.0, Cycle => -2.0*Pi); - Report.Failed("Argument_Error not raised by the Arccos function " & - "with specified Cycle parameter, when the Cycle " & - "parameter is negative"); - Dont_Optimize_Float(The_Result, 6); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Arccos " & - "function with specified Cycle parameter, when " & - "the Cycle parameter is negative"); - end; - - - -- Check the prescribed result of the Arccos function with specified - -- Cycle parameter. - ---pwb-math: Next two lines: Changed 2.0*Pi to 360.0 - if GEF.Arccos(X => 1.0, Cycle => 360.0) /= 0.0 or - EF.Arccos(1.0, 360.0) /= 0.0 - then - Report.Failed("Incorrect result from the Arccos function with " & - "specified Cycle parameter, when the input " & - "parameter value is 1.0"); - end if; - - - -- Check the results of the Arccos function, with specified Cycle - -- parameter, with various input parameters. - - if --pwb-math not Result_Within_Range(GEF.Arccos( 0.04, 2.0*Pi), 1.53, 0.01) or ---pwb-math not Result_Within_Range( EF.Arccos( 0.14, 2.0*Pi), 1.43, 0.01) or ---pwb-math not Result_Within_Range(GEF.Arccos( 0.57, 2.0*Pi), 0.96, 0.01) or ---pwb-math not Result_Within_Range( EF.Arccos( 0.99, 2.0*Pi), 0.14, 0.01) or - not Result_Within_Range(GEF.Arccos(-1.0, 360.0), 180.0, 0.1) or - not Result_Within_Range(GEF.Arccos(-1.0, 100.0), 50.0, 0.1) or - not Result_Within_Range(GEF.Arccos( 0.0, 360.0), 90.0, 0.1) or - not Result_Within_Range(GEF.Arccos( 0.0, 100.0), 25.0, 0.1) - then - Report.Failed("Incorrect result returned from the Arccos " & - "function with specified Cycle parameter, " & - "when provided a variety of input parameters"); - end if; - - - - -- Testing of Arccosh Function, both instantiated and pre-instantiated - -- version. - - -- Check that Argument_Error is raised by the Arccosh function when - -- the value of the parameter X is less than 1.0. - - begin - New_Float_Result := GEF.Arccosh(New_Float(FXA5A00.One_Minus_Delta)); - Report.Failed("Argument_Error not raised by the Arccosh function " & - "when the parameter value is less than 1.0"); - Dont_Optimize_New_Float(New_Float_Result, 7); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Arccosh " & - "function when given a parameter value less " & - "than 1.0"); - end; - - begin - The_Result := EF.Arccosh(0.0); - Report.Failed("Argument_Error not raised by the Arccosh function " & - "when the parameter value is 0.0"); - Dont_Optimize_Float(The_Result, 8); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Arccosh " & - "function when given a parameter value of 0.0"); - end; - - begin - New_Float_Result := GEF.Arccosh(New_Float(-FXA5A00.Large)); - Report.Failed("Argument_Error not raised by the Arccosh function " & - "when the large negative parameter value"); - Dont_Optimize_New_Float(New_Float_Result, 9); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Arccosh " & - "function when given a large negative parameter " & - "value"); - end; - - - -- Check the prescribed results of the Arccosh function. - - if GEF.Arccosh(X => 1.0) /= 0.0 or - EF.Arccosh(1.0) /= 0.0 - then - Report.Failed("Incorrect result returned by the Arccosh " & - "function when provided a parameter value of 0.0"); - end if; - - - -- Check the results of the Arccosh function with various input - -- parameters. - - if not Result_Within_Range(GEF.Arccosh(1.03), 0.244, 0.001) or - not Result_Within_Range( EF.Arccosh(1.28), 0.732, 0.001) or - not Result_Within_Range(GEF.Arccosh(1.50), 0.962, 0.001) or - not Result_Within_Range( EF.Arccosh(1.77), 1.17, 0.01) or - not Result_Within_Range(GEF.Arccosh(2.00), 1.32, 0.01) or - not Result_Within_Range( EF.Arccosh(4.30), 2.14, 0.01) or - not Result_Within_Range(GEF.Arccosh(6.90), 2.62, 0.01) - then - Report.Failed("Incorrect result returned from the Arccosh " & - "function when provided a variety of input " & - "parameters"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA5A06; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a deleted file mode 100644 index 179d54c44bf..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a +++ /dev/null @@ -1,413 +0,0 @@ --- CXA5A07.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 function Arctan provides correct results. --- --- TEST DESCRIPTION: --- This test examines both the version of Arctan resulting from the --- instantiation of the Ada.Numerics.Generic_Elementary_Functions with --- a type derived from type Float, as well as the preinstantiated --- version of this package for type Float. --- Prescribed results, including instances prescribed to raise --- exceptions, are examined in the test cases. In addition, --- certain evaluations are performed where the actual function result --- is compared with the expected result (within an epsilon range of --- accuracy). --- --- TEST FILES: --- The following files comprise this test: --- --- FXA5A00.A (foundation code) --- CXA5A07.A --- --- --- CHANGE HISTORY: --- 04 Apr 95 SAIC Initial prerelease version. --- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and --- use of Result_Within_Range function overloaded for --- FXA5A00.New_Float_Type. --- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi --- --- CHANGE NOTE: --- According to Ken Dritz, author of the Numerics Annex of the RM, --- one should never specify the cycle 2.0*Pi for the trigonometric --- functions. In particular, if the machine number for the first --- argument is not an exact multiple of the machine number for the --- explicit cycle, then the specified exact results cannot be --- reasonably expected. The affected checks in this test have been --- marked as comments, with the additional notation "pwb-math". --- Phil Brashear ---! - -with Ada.Numerics.Elementary_Functions; -with Ada.Numerics.Generic_Elementary_Functions; -with FXA5A00; -with Report; - -procedure CXA5A07 is -begin - - Report.Test ("CXA5A07", "Check that the Arctan function provides " & - "correct results"); - - Test_Block: - declare - - use Ada.Numerics; - use FXA5A00; - - package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); - package EF renames Ada.Numerics.Elementary_Functions; - - Float_Result : Float; - New_Float_Result : New_Float; - - procedure Dont_Optimize_Float is new Dont_Optimize(Float); - procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); - - begin - - -- Testing of Arctan Function, both instantiated and pre-instantiated - -- version. - - -- Check that Argument_Error is raised by the Arctan function when - -- provided parameter values of 0.0, 0.0. - - begin - New_Float_Result := GEF.Arctan(Y => 0.0, X => 0.0); - Report.Failed("Argument_Error not raised when the Arctan " & - "function is provided input of 0.0, 0.0"); - Dont_Optimize_New_Float(New_Float_Result, 1); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by the Arctan " & - "function when provided 0.0, 0.0 input parameters"); - end; - - - -- Check that no exception is raised by the Arctan function when - -- provided a large positive or negative Y parameter value, when - -- using the default value for parameter X. - - begin - Float_Result := EF.Arctan(Y => FXA5A00.Large); - Dont_Optimize_Float(Float_Result, 2); - exception - when others => - Report.Failed("Exception raised when the Arctan function is " & - "provided a large positive Y parameter value"); - end; - - begin - New_Float_Result := GEF.Arctan(Y => New_Float(-FXA5A00.Large)); - Dont_Optimize_New_Float(New_Float_Result, 3); - exception - when others => - Report.Failed("Exception raised when the Arctan function is " & - "provided a large negative Y parameter value"); - end; - - - -- Check that no exception is raised by the Arctan function when - -- provided a small positive or negative Y parameter value, when - -- using the default value for parameter X. - - begin - Float_Result := EF.Arctan(Y => FXA5A00.Small); - Dont_Optimize_Float(Float_Result, 4); - exception - when others => - Report.Failed("Exception raised when the Arctan function is " & - "provided a small positive Y parameter value"); - end; - - begin - New_Float_Result := GEF.Arctan(Y => New_Float(-FXA5A00.Small)); - Dont_Optimize_New_Float(New_Float_Result, 5); - exception - when others => - Report.Failed("Exception raised when the Arctan function is " & - "provided a small negative Y parameter value"); - end; - - - -- Check that no exception is raised by the Arctan function when - -- provided combinations of large and small positive or negative - -- parameter values for both Y and X input parameters. - - begin - Float_Result := EF.Arctan(Y => FXA5A00.Large, X => FXA5A00.Large); - Dont_Optimize_Float(Float_Result, 6); - exception - when others => - Report.Failed("Exception raised when the Arctan function is " & - "provided large positive X and Y parameter values"); - end; - - begin - New_Float_Result := GEF.Arctan(New_Float(-FXA5A00.Large), - X => New_Float(FXA5A00.Small)); - Dont_Optimize_New_Float(New_Float_Result, 7); - exception - when others => - Report.Failed("Exception raised when the Arctan function is " & - "provided a large negative Y parameter value " & - "and a small positive X parameter value"); - end; - - - begin - Float_Result := EF.Arctan(Y => FXA5A00.Small, X => FXA5A00.Large); - Dont_Optimize_Float(Float_Result, 8); - exception - when others => - Report.Failed("Exception raised when the Arctan function is " & - "provided a small positive Y parameter value " & - "and a large positive X parameter value"); - end; - - begin - New_Float_Result := GEF.Arctan(New_Float(-FXA5A00.Small), - New_Float(-FXA5A00.Large)); - Dont_Optimize_New_Float(New_Float_Result, 9); - exception - when others => - Report.Failed("Exception raised when the Arctan function is " & - "provided a small negative Y parameter value " & - "and a large negative parameter value"); - end; - - - -- Check that when the Arctan function is provided a Y parameter value - -- of 0.0 and a positive X parameter input value, the prescribed result - -- of zero is returned. - - if GEF.Arctan(Y => 0.0) /= 0.0 or -- Default X value - EF.Arctan(Y => 0.0, X => FXA5A00.Large) /= 0.0 or ---pwb-math: Next line: changed 2.0*Pi to 360.0 - GEF.Arctan(0.0, 360.0) /= 0.0 or - EF.Arctan(0.0, FXA5A00.Small) /= 0.0 - then - Report.Failed("Incorrect results from the Arctan function when " & - "provided a Y parameter value of 0.0 and various " & - "positive X parameter values"); - end if; - - - -- Check that the Arctan function provides correct results when provided - -- a variety of Y parameter values. - - if not FXA5A00.Result_Within_Range(EF.Arctan(Pi), 1.26, 0.01) or - not FXA5A00.Result_Within_Range(EF.Arctan(-Pi), -1.26, 0.01) or - not FXA5A00.Result_Within_Range(GEF.Arctan(1.0), 0.785, 0.001) or - not FXA5A00.Result_Within_Range(EF.Arctan(-1.0), -0.785, 0.001) or - not FXA5A00.Result_Within_Range(GEF.Arctan(0.25), 0.245, 0.001) or - not FXA5A00.Result_Within_Range(EF.Arctan(0.92), 0.744, 0.001) - then - Report.Failed("Incorrect results from the Arctan function when " & - "provided a variety of Y parameter values"); - end if; - - - - -- Check the results of the Arctan function with specified cycle - -- parameter. - - -- Check that the Arctan function with specified Cycle parameter - -- raises Argument_Error when the value of the Cycle parameter is zero - -- or negative. - - begin - Float_Result := EF.Arctan(Y => Pi, Cycle => 0.0); -- Default X value - Report.Failed("Argument_Error not raised by the Arctan function " & - "with default X parameter value, when the Cycle " & - "parameter is 0.0"); - Dont_Optimize_Float(Float_Result, 10); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by the Arctan " & - "function with default X parameter value, when " & - "provided a 0.0 cycle parameter value"); - end; - - begin - New_Float_Result := GEF.Arctan(Y => Pi, X => 1.0, Cycle => 0.0); - Report.Failed("Argument_Error not raised by the Arctan function " & - "when the Cycle parameter is 0.0"); - Dont_Optimize_New_Float(New_Float_Result, 11); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by the Arctan " & - "function when provided a 0.0 cycle parameter " & - "value"); - end; - - begin - Float_Result := EF.Arctan(Y => Pi, Cycle => -360.0); - Report.Failed("Argument_Error not raised by the Arctan function " & - "with a default X parameter value, when the Cycle " & - "parameter is -360.0"); - Dont_Optimize_Float(Float_Result, 12); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by the Arctan " & - "function with a default X parameter value, when " & - "provided a -360.0 cycle parameter value"); - end; - - begin - New_Float_Result := GEF.Arctan(Y => Pi, X => 1.0, Cycle => -Pi); - Report.Failed("Argument_Error not raised by the Arctan function " & - "when the Cycle parameter is -Pi"); - Dont_Optimize_New_Float(New_Float_Result, 13); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by the Arctan " & - "function when provided a -Pi cycle parameter " & - "value"); - end; - - - -- Check that no exception is raised by the Arctan function with - -- specified Cycle parameter, when provided large and small positive - -- or negative parameter values for both Y and X input parameters. - - begin - Float_Result := EF.Arctan(Y => -FXA5A00.Large, - X => -FXA5A00.Large, ---pwb-math: Next line: changed 2.0*Pi to 360.0 - Cycle => 360.0); - Dont_Optimize_Float(Float_Result, 14); - exception - when others => - Report.Failed("Exception raised when the Arctan function with " & - "specified Cycle parameter, when provided large " & - "negative X and Y parameter values"); - end; - - - begin - New_Float_Result := GEF.Arctan(New_Float(FXA5A00.Large), - X => New_Float(-FXA5A00.Small), ---pwb-math: Next line: changed 2.0*Pi to 360.0 - Cycle => 360.0); - Dont_Optimize_New_Float(New_Float_Result, 15); - exception - when others => - Report.Failed("Exception raised when the Arctan function with " & - "specified Cycle parameter, when provided large " & - "positive Y parameter value and a small negative " & - "X parameter value"); - end; - - - begin - Float_Result := EF.Arctan(Y => -FXA5A00.Small, - X => -FXA5A00.Large, ---pwb-math: Next line: changed 2.0*Pi to 360.0 - Cycle => 360.0); - Dont_Optimize_Float(Float_Result, 16); - exception - when others => - Report.Failed("Exception raised when the Arctan function with " & - "specified Cycle parameter, when provided large " & - "negative Y parameter value and a large negative " & - "X parameter value"); - end; - - begin - New_Float_Result := GEF.Arctan(New_Float(FXA5A00.Small), - New_Float(FXA5A00.Large), ---pwb-math: Next line: changed 2.0*Pi to 360.0 - 360.0); - Dont_Optimize_New_Float(New_Float_Result, 17); - exception - when others => - Report.Failed("Exception raised when the Arctan function with " & - "specified Cycle parameter, when provided a " & - "small negative Y parameter value and a large " & - "positive X parameter value"); - end; - - - -- Check that the Arctan function with specified Cycle parameter - -- provides correct results when provided a variety of Y parameter - -- input values. - ---pwb-math if not FXA5A00.Result_Within_Range(EF.Arctan(Pi, Cycle => 2.0*Pi), ---pwb-math 1.26, ---pwb-math 0.01) or ---pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(-Pi, Cycle => 2.0*Pi), ---pwb-math -1.26, ---pwb-math 0.01) or ---pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 2.0*Pi), ---pwb-math 0.785, ---pwb-math 0.001) or ---pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(-1.0, Cycle => 2.0*Pi), ---pwb-math -0.785, ---pwb-math 0.001) or ---pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(0.16, Cycle => 2.0*Pi), ---pwb-math 0.159, ---pwb-math 0.001) or ---pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(1.0, Cycle => 360.0), ---pwb-math 45.0, ---pwb-math 0.1) or ---pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 100.0), ---pwb-math 12.5, ---pwb-math 0.1) - ---pwb-math Next 12 lines are replacements for 21 commented lines above - if not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 2.0*180.0), - 45.0, - 0.001) or - not FXA5A00.Result_Within_Range(EF.Arctan(-1.0, Cycle => 2.0*180.0), - -45.0, - 0.001) or - not FXA5A00.Result_Within_Range(EF.Arctan(1.0, Cycle => 360.0), - 45.0, - 0.1) or - not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 100.0), - 12.5, - 0.1) - then - Report.Failed("Incorrect results from the Arctan function with " & - "specified Cycle parameter when provided a variety " & - "of Y parameter values"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA5A07; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a deleted file mode 100644 index ae2b85a6d43..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a +++ /dev/null @@ -1,474 +0,0 @@ --- CXA5A08.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 function Arccot provides correct results. --- --- TEST DESCRIPTION: --- This test examines both the version of Arccot resulting from the --- instantiation of the Ada.Numerics.Generic_Elementary_Functions --- with a type derived from type Float, as well as the preinstantiated --- version of this package for type Float. --- Prescribed results, including instances prescribed to raise --- exceptions, are examined in the test cases. In addition, --- certain evaluations are performed where the actual function result --- is compared with the expected result (within an epsilon range of --- accuracy). --- --- TEST FILES: --- The following files comprise this test: --- --- FXA5A00.A (foundation code) --- CXA5A08.A --- --- --- CHANGE HISTORY: --- 06 Apr 95 SAIC Initial prerelease version. --- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and --- use of Result_Within_Range function overloaded for --- FXA5A00.New_Float_Type. --- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- 28 Feb 97 CTA.PWB Removed checks with explicit Cycle => 2.0*Pi --- --- CHANGE NOTE: --- According to Ken Dritz, author of the Numerics Annex of the RM, --- one should never specify the cycle 2.0*Pi for the trigonometric --- functions. In particular, if the machine number for the first --- argument is not an exact multiple of the machine number for the --- explicit cycle, then the specified exact results cannot be --- reasonably expected. The affected checks in this test have been --- marked as comments, with the additional notation "pwb-math". --- Phil Brashear ---! - -with Ada.Exceptions; -with Ada.Numerics.Elementary_Functions; -with Ada.Numerics.Generic_Elementary_Functions; -with FXA5A00; -with Report; - -procedure CXA5A08 is -begin - - Report.Test ("CXA5A08", "Check that the Arccot function provides " & - "correct results"); - - Test_Block: - declare - - use Ada.Exceptions; - use Ada.Numerics; - use FXA5A00; - - package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); - package EF renames Ada.Numerics.Elementary_Functions; - - Float_Result : Float; - Angle : Float; - New_Float_Result : New_Float; - New_Float_Angle : New_Float; - Incorrect_Inverse : Boolean := False; - - procedure Dont_Optimize_Float is new Dont_Optimize(Float); - procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); - - begin - - -- Testing of Arccot Function, both instantiated and pre-instantiated - -- version. - - -- Check that Argument_Error is raised by the Arccot function when - -- provided parameter values of 0.0, 0.0. - - begin - New_Float_Result := GEF.Arccot(X => 0.0, Y => 0.0); - Report.Failed("Argument_Error not raised when the Arccot " & - "function is provided input of 0.0, 0.0"); - Dont_Optimize_New_Float(New_Float_Result, 1); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by the Arccot " & - "function when provided 0.0, 0.0 input parameters"); - end; - - - -- Check that no exception is raised by the Arccot function when - -- provided a large positive or negative X parameter value, when - -- using the default value for parameter Y. - - begin - Float_Result := EF.Arccot(X => FXA5A00.Large); - Dont_Optimize_Float(Float_Result, 2); - exception - when others => - Report.Failed("Exception raised when the Arccot function is " & - "provided a large positive X parameter value"); - end; - - begin - New_Float_Result := GEF.Arccot(X => New_Float(-FXA5A00.Large)); - Dont_Optimize_New_Float(New_Float_Result, 3); - exception - when others => - Report.Failed("Exception raised when the Arccot function is " & - "provided a large negative X parameter value"); - end; - - - -- Check that no exception is raised by the Arccot function when - -- provided a small positive or negative X parameter value, when - -- using the default value for parameter Y. - - begin - Float_Result := EF.Arccot(X => FXA5A00.Small); - Dont_Optimize_Float(Float_Result, 4); - exception - when others => - Report.Failed("Exception raised when the Arccot function is " & - "provided a small positive X parameter value"); - end; - - begin - New_Float_Result := GEF.Arccot(X => New_Float(-FXA5A00.Small)); - Dont_Optimize_New_Float(New_Float_Result, 5); - exception - when others => - Report.Failed("Exception raised when the Arccot function is " & - "provided a small negative X parameter value"); - end; - - - -- Check that no exception is raised by the Arccot function when - -- provided combinations of large and small positive or negative - -- parameter values for both X and Y input parameters. - - begin - Float_Result := EF.Arccot(X => FXA5A00.Large, Y => FXA5A00.Large); - Dont_Optimize_Float(Float_Result, 6); - exception - when others => - Report.Failed("Exception raised when the Arccot function is " & - "provided large positive X and Y parameter values"); - end; - - begin - New_Float_Result := GEF.Arccot(New_Float(-FXA5A00.Large), - Y => New_Float(FXA5A00.Small)); - Dont_Optimize_New_Float(New_Float_Result, 7); - exception - when others => - Report.Failed("Exception raised when the Arccot function is " & - "provided a large negative X parameter value " & - "and a small positive Y parameter value"); - end; - - - begin - Float_Result := EF.Arccot(X => FXA5A00.Small, Y => FXA5A00.Large); - Dont_Optimize_Float(Float_Result, 8); - exception - when others => - Report.Failed("Exception raised when the Arccot function is " & - "provided a small positive X parameter value " & - "and a large positive Y parameter value"); - end; - - begin - New_Float_Result := GEF.Arccot(New_Float(-FXA5A00.Small), - New_Float(-FXA5A00.Large)); - Dont_Optimize_New_Float(New_Float_Result, 9); - exception - when others => - Report.Failed("Exception raised when the Arccot function is " & - "provided a small negative X parameter value " & - "and a large negative Y parameter value"); - end; - - - -- Check that when the Arccot function is provided a Y parameter value - -- of 0.0 and a positive X parameter input value, the prescribed result - -- of zero is returned. - - if EF.Arccot(X => FXA5A00.Large, Y => 0.0) /= 0.0 or - GEF.Arccot(2.0*Pi, Y => 0.0) /= 0.0 or - EF.Arccot(FXA5A00.Small, 0.0) /= 0.0 or - EF.Arccot(X => FXA5A00.Large, Y => 0.0, Cycle => 360.0) /= 0.0 or - GEF.Arccot(2.0*Pi, Y => 0.0, Cycle => 360.0) /= 0.0 or - EF.Arccot(FXA5A00.Small, 0.0, Cycle => 360.0) /= 0.0 - then - Report.Failed("Incorrect results from the Arccot function when " & - "provided a Y parameter value of 0.0 and various " & - "positive X parameter values"); - end if; - - - -- Check that the Arccot function provides correct results when - -- provided a variety of X parameter values. - - if not Result_Within_Range( EF.Arccot( 1.0), Pi/4.0, 0.001) or - not Result_Within_Range(GEF.Arccot( 0.0), Pi/2.0, 0.001) or - not Result_Within_Range( EF.Arccot(-1.0), 3.0*Pi/4.0, 0.001) - then - Report.Failed("Incorrect results from the Arccot function when " & - "provided a variety of Y parameter values"); - end if; - - - -- Check the results of the Arccot function with specified cycle - -- parameter. - - -- Check that the Arccot function with specified Cycle parameter - -- raises Argument_Error when the value of the Cycle parameter is zero - -- or negative. - - begin - Float_Result := EF.Arccot(X => Pi, Cycle => 0.0); -- Default Y value - Report.Failed("Argument_Error not raised by the Arccot function " & - "with default Y parameter value, when the Cycle " & - "parameter is 0.0"); - Dont_Optimize_Float(Float_Result, 10); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by the Arccot " & - "function with default Y parameter value, when " & - "provided a 0.0 cycle parameter value"); - end; - - begin - New_Float_Result := GEF.Arccot(X => Pi, Y => 1.0, Cycle => 0.0); - Report.Failed("Argument_Error not raised by the Arccot function " & - "when the Cycle parameter is 0.0"); - Dont_Optimize_New_Float(New_Float_Result, 11); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by the Arccot " & - "function when provided a 0.0 cycle parameter " & - "value"); - end; - - begin - Float_Result := EF.Arccot(X => Pi, Cycle => -360.0); - Report.Failed("Argument_Error not raised by the Arccot function " & - "with a default Y parameter value, when the Cycle " & - "parameter is -360.0"); - Dont_Optimize_Float(Float_Result, 12); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by the Arccot " & - "function with a default Y parameter value, when " & - "provided a -360.0 cycle parameter value"); - end; - - begin - New_Float_Result := GEF.Arccot(X => Pi, Y => 1.0, Cycle => -Pi); - Report.Failed("Argument_Error not raised by the Arccot function " & - "when the Cycle parameter is -Pi"); - Dont_Optimize_New_Float(New_Float_Result, 13); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by the Arccot " & - "function when provided a -Pi cycle parameter " & - "value"); - end; - - - -- Check that no exception is raised by the Arccot function with - -- specified Cycle parameter, when provided large and small positive - -- or negative parameter values for both X and Y input parameters. - - begin - Float_Result := EF.Arccot(X => -FXA5A00.Large, - Y => -FXA5A00.Large, ---pwb-math Next line: changed 2.0*Pi to 360.0 - Cycle => 360.0); - Dont_Optimize_Float(Float_Result, 14); - exception - when others => - Report.Failed("Exception raised when the Arccot function with " & - "specified Cycle parameter, when provided large " & - "negative X and Y parameter values"); - end; - - - begin - New_Float_Result := GEF.Arccot(New_Float(FXA5A00.Large), - Y => New_Float(-FXA5A00.Small), ---pwb-math Next line: changed 2.0*Pi to 360.0 - Cycle => 360.0); - Dont_Optimize_New_Float(New_Float_Result, 15); - exception - when others => - Report.Failed("Exception raised when the Arccot function with " & - "specified Cycle parameter, when provided large " & - "positive X parameter value and a small negative " & - "Y parameter value"); - end; - - - begin - Float_Result := EF.Arccot(X => -FXA5A00.Small, - Y => -FXA5A00.Large, ---pwb-math Next line: changed 2.0*Pi to 360.0 - Cycle => 360.0); - Dont_Optimize_Float(Float_Result, 16); - exception - when others => - Report.Failed("Exception raised when the Arccot function with " & - "specified Cycle parameter, when provided small " & - "negative X parameter value and a large negative " & - "Y parameter value"); - end; - - begin - New_Float_Result := GEF.Arccot(New_Float(FXA5A00.Small), - New_Float(FXA5A00.Large), ---pwb-math Next line: changed 2.0*Pi to 360.0 - 360.0); - Dont_Optimize_New_Float(New_Float_Result, 17); - exception - when others => - Report.Failed("Exception raised when the Arccot function with " & - "specified Cycle parameter, when provided a " & - "small positive X parameter value and a large " & - "positive Y parameter value"); - end; - - - -- Check that the Arccot function with specified Cycle parameter - -- provides correct results when provided a variety of X parameter - -- input values. - - if not FXA5A00.Result_Within_Range(GEF.Arccot( 0.0, Cycle => 360.0), - 90.0, - 0.001) or - not FXA5A00.Result_Within_Range(EF.Arccot( 0.0, Cycle => 100.0), - 25.0, - 0.001) or - not FXA5A00.Result_Within_Range(GEF.Arccot( 1.0, Cycle => 360.0), - 45.0, - 0.001) or - not FXA5A00.Result_Within_Range(EF.Arccot( 1.0, Cycle => 100.0), - 12.5, - 0.001) or - not FXA5A00.Result_Within_Range(GEF.Arccot(-1.0, Cycle => 360.0), - 135.0, - 0.001) or - not FXA5A00.Result_Within_Range(EF.Arccot(-1.0, Cycle => 100.0), - 37.5, - 0.001) - then - Report.Failed("Incorrect results from the Arccot function with " & - "specified Cycle parameter when provided a variety " & - "of X parameter values"); - end if; - - - if not FXA5A00.Result_Within_Range(EF.Arccot(0.2425355, 0.9701420), - EF.Arccot(0.25), - 0.01) or - not FXA5A00.Result_Within_Range(EF.Arccot(0.3162277, 0.9486831), - Ef.Arccot(0.33), - 0.01) - then - Report.Failed("Incorrect results from the Arccot function with " & - "comparison to other Arccot function results"); - end if; - - - if not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(0.4472135, - 0.8944270)), - 0.5, - 0.01) or - not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(0.9987380, - 0.0499369)), - 20.0, - 0.1) - then - Report.Failed("Incorrect results from the Arccot function when " & - "used as argument to Cot function"); - end if; - - - -- Check that inverse function results are correct. - -- Default Cycle test. - - Angle := 0.001; - while Angle < Pi and not Incorrect_Inverse loop - if not Result_Within_Range(EF.Arccot(EF.Cot(Angle)), Angle, 0.001) - then - Incorrect_Inverse := True; - end if; - Angle := Angle + 0.001; - end loop; - - if Incorrect_Inverse then - Report.Failed("Incorrect results returned from the Inverse " & - "comparison of Cot and Arccot using the default " & - "cycle value"); - Incorrect_Inverse := False; - end if; - - -- Non-Default Cycle test. - - New_Float_Angle := 0.01; - while New_Float_Angle < 180.0 and not Incorrect_Inverse loop - if not Result_Within_Range(EF.Arccot(EF.Cot(Float(New_Float_Angle), - Cycle => 360.0), - Cycle => 360.0), - Float(New_Float_Angle), - 0.01) or - not Result_Within_Range(GEF.Arccot( - New_Float(GEF.Cot(New_Float_Angle, - Cycle => 360.0)), - Cycle => 360.0), - Float(New_Float_Angle), - 0.01) - then - Incorrect_Inverse := True; - end if; - New_Float_Angle := New_Float_Angle + 0.01; - end loop; - - if Incorrect_Inverse then - Report.Failed("Incorrect results returned from the Inverse " & - "comparison of Cot and Arccot using non-default " & - "cycle value"); - end if; - - - exception - when The_Error : others => - Report.Failed ("The following exception was raised in the " & - "Test_Block: " & Exception_Name(The_Error)); - end Test_Block; - - Report.Result; - -end CXA5A08; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a deleted file mode 100644 index 22bd2f8909c..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a +++ /dev/null @@ -1,400 +0,0 @@ --- CXA5A09.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 function Log provides correct results. --- --- TEST DESCRIPTION: --- This test examines both the version of Log resulting from the --- instantiation of the Ada.Numerics.Generic_Elementary_Functions with --- with a type derived from type Float,as well as the preinstantiated --- version of this package for type Float. --- Prescribed results, including instances prescribed to raise --- exceptions, are examined in the test cases. In addition, --- certain evaluations are performed where the actual function result --- is compared with the expected result (within an epsilon range of --- accuracy). --- --- TEST FILES: --- The following files comprise this test: --- --- FXA5A00.A (foundation code) --- CXA5A09.A --- --- --- CHANGE HISTORY: --- 11 Apr 95 SAIC Initial prerelease version. --- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and --- use of Result_Within_Range function overloaded for --- FXA5A00.New_Float_Type. --- 29 Jun 98 EDS Protected exception tests by first testing --- for 'Machine_Overflows --- ---! - -with Ada.Numerics.Elementary_Functions; -with Ada.Numerics.Generic_Elementary_Functions; -with FXA5A00; -with Report; - -procedure CXA5A09 is -begin - - Report.Test ("CXA5A09", "Check that the Log function provides " & - "correct results"); - - Test_Block: - declare - - use Ada.Numerics; - use FXA5A00; - - package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); - package EF renames Ada.Numerics.Elementary_Functions; - - Arg, - Float_Result : Float := 0.0; - New_Float_Result : New_Float := 0.0; - - Incorrect_Inverse, - Incorrect_Inverse_Base_2, - Incorrect_Inverse_Base_8, - Incorrect_Inverse_Base_10, - Incorrect_Inverse_Base_16 : Boolean := False; - - procedure Dont_Optimize_Float is new Dont_Optimize(Float); - procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); - - begin - - -- Testing of Log Function, both instantiated and pre-instantiated - -- version. - - -- Check that Argument_Error is raised when the parameter X is negative. - - begin - New_Float_Result := GEF.Log(X => -1.0); - Report.Failed("Argument_Error not raised by the Log function " & - "when the input parameter is negative"); - Dont_Optimize_New_Float(New_Float_Result, 1); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Log function " & - "when the input parameter is negative"); - end; - - begin - Float_Result := EF.Log(X => -FXA5A00.Large); - Report.Failed("Argument_Error not raised by the Log function " & - "when the input parameter is negative"); - Dont_Optimize_Float(Float_Result, 2); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Log function " & - "when the input parameter is negative"); - end; - - - -- Check that Constraint_Error is raised when the Log function is - -- provided an input parameter of zero. - - if New_Float'Machine_Overflows = True then - begin - New_Float_Result := GEF.Log(X => 0.0); - Report.Failed("Constraint_Error not raised by the Log function " & - "when the input parameter is zero"); - Dont_Optimize_New_Float(New_Float_Result, 3); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Log function " - & "when the input parameter is zero"); - end; - end if; - - - -- Check for the reference manual prescribed results of the Log function. - - if GEF.Log(X => 1.0) /= 0.0 or - EF.Log(X => 1.0) /= 0.0 - then - Report.Failed("Incorrect result from Function Log when provided " & - "an input parameter value of 1.0"); - end if; - - - -- Check that the Log function provides correct results when provided - -- a variety of input parameters. - - if not FXA5A00.Result_Within_Range(GEF.Log(0.015), -4.20, 0.01) or - not FXA5A00.Result_Within_Range(GEF.Log(0.592), -0.524, 0.001) or - not FXA5A00.Result_Within_Range(GEF.Log(0.997), -0.003, 0.001) or - not FXA5A00.Result_Within_Range(GEF.Log(1.341), 0.293, 0.001) or - not FXA5A00.Result_Within_Range( EF.Log(2.826), 1.04, 0.01) or - not FXA5A00.Result_Within_Range( EF.Log(10.052), 2.31, 0.01) or - not FXA5A00.Result_Within_Range( EF.Log(2569.143), 7.85, 0.01) - then - Report.Failed("Incorrect results from Function Log when provided " & - "a variety of input parameter values"); - end if; - - Arg := 0.001; - while Arg < 1.0 and not Incorrect_Inverse loop - if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.001) then - Incorrect_Inverse := True; - end if; - Arg := Arg + 0.001; - end loop; - - if Incorrect_Inverse then - Report.Failed("Incorrect inverse result comparing ""**"" and " & - "Log function over argument range 0.001..1.0"); - Incorrect_Inverse := False; - end if; - - Arg := 1.0; - while Arg < 10.0 and not Incorrect_Inverse loop - if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.01) then - Incorrect_Inverse := True; - end if; - Arg := Arg + 0.01; - end loop; - - if Incorrect_Inverse then - Report.Failed("Incorrect inverse result comparing ""**"" and " & - "Log function over argument range 1.0..10.0"); - Incorrect_Inverse := False; - end if; - - Arg := 1.0; - while Arg < 1000.0 and not Incorrect_Inverse loop - if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.1) then - Incorrect_Inverse := True; - end if; - Arg := Arg + 1.0; - end loop; - - if Incorrect_Inverse then - Report.Failed("Incorrect inverse result comparing ""**"" and " & - "Log function over argument range 1.0..1000.0"); - end if; - - - -- Testing of Log Function, with specified Base parameter, both - -- instantiated and pre-instantiated versions. - - -- Check that Argument_Error is raised by the Log function with - -- specified Base parameter, when the X parameter value is negative. - - begin - New_Float_Result := GEF.Log(X => -1.0, Base => 16.0); - Report.Failed("Argument_Error not raised by the Log function " & - "with Base parameter, when the input parameter " & - "value is -1.0"); - Dont_Optimize_New_Float(New_Float_Result, 4); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Log function " & - "with Base parameter, when the X parameter value " & - "is -1.0"); - end; - - begin - Float_Result := EF.Log(X => -FXA5A00.Large, Base => 8.0); - Report.Failed("Argument_Error not raised by the Log function " & - "with Base parameter, when the X parameter " & - "value is a large negative value"); - Dont_Optimize_Float(Float_Result, 5); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Log function " & - "with Base parameter, when the X parameter " & - "value is a large negative value"); - end; - - - -- Check that Argument_Error is raised by the Log function when - -- the specified Base parameter is zero. - - begin - New_Float_Result := GEF.Log(X => 10.0, Base => 0.0); - Report.Failed("Argument_Error not raised by the Log function " & - "with Base parameter of 0.0"); - Dont_Optimize_New_Float(New_Float_Result, 6); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Log function " & - "with Base parameter of 0.0"); - end; - - - -- Check that Argument_Error is raised by the Log function when - -- the specified Base parameter is one. - - begin - Float_Result := EF.Log(X => 12.3, Base => 1.0); - Report.Failed("Argument_Error not raised by the Log function " & - "with Base parameter of 1.0"); - Dont_Optimize_Float(Float_Result, 7); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Log function " & - "with Base parameter of 1.0"); - end; - - - -- Check that Argument_Error is raised by the Log function when - -- the specified Base parameter is negative. - - begin - New_Float_Result := GEF.Log(X => 12.3, Base => -10.0); - Report.Failed("Argument_Error not raised by the Log function " & - "with negative Base parameter"); - Dont_Optimize_New_Float(New_Float_Result, 8); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the Log function " & - "with negative Base parameter"); - end; - - - -- Check that Constraint_Error is raised by the Log function when the - -- input X parameter value is 0.0. - - if New_Float'Machine_Overflows = True then - begin - New_Float_Result := GEF.Log(X => 0.0, Base => 16.0); - Report.Failed("Constraint_Error not raised by the Log function " & - "with specified Base parameter, when the value of " & - "the parameter X is 0.0"); - Dont_Optimize_New_Float(New_Float_Result, 9); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Log" & - "with specified Base parameter, when the value " & - "of the parameter X is 0.0"); - end; - end if; - - -- Check for the prescribed results of the Log function with specified - -- Base parameter. - - if GEF.Log(X => 1.0, Base => 16.0) /= 0.0 or - EF.Log(X => 1.0, Base => 10.0) /= 0.0 or - GEF.Log(1.0, Base => 8.0) /= 0.0 or - EF.Log(1.0, 2.0) /= 0.0 - then - Report.Failed("Incorrect result from Function Log with specified " & - "Base parameter when provided an parameter X input " & - "value of 1.0"); - end if; - - - -- Check that the Log function with specified Base parameter provides - -- correct results when provided a variety of input parameters. - - if not Result_Within_Range(GEF.Log( 10.0, e), 2.30, 0.01) or - not Result_Within_Range( EF.Log( 8.0, 2.0), 3.0, 0.01) or - not Result_Within_Range(GEF.Log(256.0, 2.0), 8.0, 0.01) or - not Result_Within_Range( EF.Log(512.0, 8.0), 3.0, 0.01) or - not Result_Within_Range(GEF.Log(0.5649, e), -0.57, 0.01) or - not Result_Within_Range( EF.Log(1.7714, e), 0.57, 0.01) or - not Result_Within_Range(GEF.Log(0.5718, 10.0), -0.243, 0.001) or - not Result_Within_Range( EF.Log(466.25, 10.0), 2.67, 0.01) - then - Report.Failed("Incorrect results from Function Log with specified " & - "Base parameter, when provided a variety of input " & - "parameter values"); - end if; - - - Arg := 1.0; - while Arg < 1000.0 and - not (Incorrect_Inverse_Base_2 and Incorrect_Inverse_Base_8 and - Incorrect_Inverse_Base_10 and Incorrect_Inverse_Base_16) - loop - if not FXA5A00.Result_Within_Range(EF."**"(2.0,EF.Log(Arg,2.0)), - Arg, - 0.001) - then - Incorrect_Inverse_Base_2 := True; - end if; - if not FXA5A00.Result_Within_Range(EF."**"(8.0,EF.Log(Arg,8.0)), - Arg, - 0.001) - then - Incorrect_Inverse_Base_8 := True; - end if; - if not FXA5A00.Result_Within_Range(EF."**"(10.0,EF.Log(Arg,10.0)), - Arg, - 0.001) - then - Incorrect_Inverse_Base_10 := True; - end if; - if not FXA5A00.Result_Within_Range(EF."**"(16.0,EF.Log(Arg,16.0)), - Arg, - 0.001) - then - Incorrect_Inverse_Base_16 := True; - end if; - Arg := Arg + 1.0; - end loop; - - if Incorrect_Inverse_Base_2 then - Report.Failed("Incorrect inverse result comparing ""**"" and " & - "Log function for Base 2"); - end if; - - if Incorrect_Inverse_Base_8 then - Report.Failed("Incorrect inverse result comparing ""**"" and " & - "Log function for Base 8"); - end if; - - if Incorrect_Inverse_Base_10 then - Report.Failed("Incorrect inverse result comparing ""**"" and " & - "Log function for Base 10"); - end if; - - if Incorrect_Inverse_Base_16 then - Report.Failed("Incorrect inverse result comparing ""**"" and " & - "Log function for Base 16"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXA5A09; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a deleted file mode 100644 index 4804d6729fc..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a +++ /dev/null @@ -1,551 +0,0 @@ --- CXA5A10.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 Exp and Sqrt, and the exponentiation --- operator "**" provide correct results. --- --- TEST DESCRIPTION: --- This test examines both the versions of Exp, Sqrt, and "**" --- resulting from the instantiation of the --- Ada.Numerics.Generic_Elementary_Functions with a type derived from --- type Float, as well as the preinstantiated version of this package --- for type Float. --- Prescribed results (stated as such in the reference manual), --- including instances prescribed to raise exceptions, are examined --- in the test cases. In addition, certain evaluations are performed --- for the preinstantiated package where the actual function result is --- compared with the expected result (within an epsilon range of --- accuracy). --- --- TEST FILES: --- The following files comprise this test: --- --- FXA5A00.A (foundation code) --- CXA5A10.A --- --- --- CHANGE HISTORY: --- 17 Apr 95 SAIC Initial prerelease version. --- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and --- use of Result_Within_Range function overloaded for --- FXA5A00.New_Float_Type. --- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- 01 Oct 01 RLB Protected Constraint_Error exception tests by --- first testing for 'Machine_Overflows. --- ---! - -with Ada.Exceptions; -with Ada.Numerics.Elementary_Functions; -with Ada.Numerics.Generic_Elementary_Functions; -with FXA5A00; -with Report; - -procedure CXA5A10 is -begin - - Report.Test ("CXA5A10", "Check that Exp, Sqrt, and the ""**"" operator " & - "provide correct results"); - - Test_Block: - declare - - use FXA5A00, Ada.Numerics; - use Ada.Exceptions; - - package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); - package EF renames Ada.Numerics.Elementary_Functions; - - use GEF, EF; - - Arg, - Float_Result : Float; - New_Float_Result : New_Float; - - Flag_1, Flag_2, Flag_3, Flag_4, - Incorrect_Inverse_Base_e, - Incorrect_Inverse_Base_2, - Incorrect_Inverse_Base_8, - Incorrect_Inverse_Base_10, - Incorrect_Inverse_Base_16 : Boolean := False; - - procedure Dont_Optimize_Float is new Dont_Optimize(Float); - procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); - - begin - - -- Testing of the "**" operator, both instantiated and pre-instantiated - -- version. - - -- Check that Argument_Error is raised by the exponentiation operator - -- when the value of the Left parameter (operand) is negative. - - begin - New_Float_Result := GEF."**"(Left => -10.0, - Right => 2.0); - Report.Failed("Argument_Error not raised by the instantiated " & - "version of the exponentiation operator when the " & - "value of the Left parameter is negative"); - Dont_Optimize_New_Float(New_Float_Result, 1); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the " & - "instantiated version of the exponentiation " & - "operator when the value of the Left parameter " & - "is negative"); - end; - - begin - Float_Result := (-FXA5A00.Small) ** 4.0; - Report.Failed("Argument_Error not raised by the preinstantiated " & - "version of the exponentiation operator when the " & - "value of the Left parameter is negative"); - Dont_Optimize_Float(Float_Result, 2); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the " & - "preinstantiated version of the exponentiation " & - "operator when the value of the Left parameter " & - "is negative"); - end; - - - -- Check that Argument_Error is raised by the exponentiation operator - -- when both parameters (operands) have the value 0.0. - - begin - New_Float_Result := GEF."**"(0.0, Right => 0.0); - Report.Failed("Argument_Error not raised by the instantiated " & - "version of the exponentiation operator when " & - "both operands are zero"); - Dont_Optimize_New_Float(New_Float_Result, 3); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the " & - "instantiated version of the exponentiation " & - "operator when both operands are zero"); - end; - - begin - Float_Result := 0.0**0.0; - Report.Failed("Argument_Error not raised by the preinstantiated " & - "version of the exponentiation operator when both " & - "operands are zero"); - Dont_Optimize_Float(Float_Result, 4); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the " & - "preinstantiated version of the exponentiation " & - "operator when both operands are zero"); - end; - - - -- Check that Constraint_Error is raised by the exponentiation - -- operator when the value of the left parameter (operand) is zero, - -- and the value of the right parameter (exponent) is negative. - -- This check applies only if Machine_Overflows is true [A.5.1(28, 30)]. - - if New_Float'Machine_Overflows = True then - begin - New_Float_Result := GEF."**"(0.0, Right => -2.0); - Report.Failed("Constraint_Error not raised by the instantiated " & - "version of the exponentiation operator when " & - "the left parameter is 0.0, and the right " & - "parameter is negative"); - Dont_Optimize_New_Float(New_Float_Result, 5); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the " & - "instantiated version of the exponentiation " & - "operator when the left parameter is 0.0, " & - "and the right parameter is negative"); - end; - end if; - - if Float'Machine_Overflows = True then - begin - Float_Result := 0.0 ** (-FXA5A00.Small); - Report.Failed("Constraint_Error not raised by the " & - "preinstantiated version of the exponentiation " & - "operator when the left parameter is 0.0, and the " & - "right parameter is negative"); - Dont_Optimize_Float(Float_Result, 6); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by the " & - "preinstantiated version of the exponentiation " & - "operator when the left parameter is 0.0, and " & - "the right parameter is negative"); - end; - end if; - - -- Prescribed results. - -- Check that exponentiation by a 0.0 exponent yields the value one. - - if GEF."**"(Left => 10.0, Right => 0.0) /= 1.0 or - EF."**"(FXA5A00.Large, Right => 0.0) /= 1.0 or - GEF."**"(3.0, 0.0) /= 1.0 or - FXA5A00.Small ** 0.0 /= 1.0 - then - Report.Failed("Incorrect results returned from the ""**"" " & - "operator when the value of the exponent is 0.0"); - end if; - - - -- Check that exponentiation by a unit exponent yields the value - -- of the left operand. - - if GEF."**"(Left => 50.0, Right => 1.0) /= 50.0 or - EF."**"(FXA5A00.Large, Right => 1.0) /= FXA5A00.Large or - GEF."**"(6.0, 1.0) /= 6.0 or - FXA5A00.Small ** 1.0 /= FXA5A00.Small - then - Report.Failed("Incorrect results returned from the ""**"" " & - "operator when the value of the exponent is 1.0"); - end if; - - - -- Check that exponentiation of the value 1.0 yields the value 1.0. - - if GEF."**"(Left => 1.0, Right => 16.0) /= 1.0 or - EF."**"(1.0, Right => FXA5A00.Large) /= 1.0 or - GEF."**"(1.0, 3.0) /= 1.0 or - 1.0 ** FXA5A00.Small /= 1.0 - then - Report.Failed("Incorrect results returned from the ""**"" " & - "operator when the value of the operand is 1.0"); - end if; - - - -- Check that exponentiation of the value 0.0 yields the value 0.0. - - if GEF."**"(Left => 0.0, Right => 10.0) /= 0.0 or - EF."**"(0.0, Right => FXA5A00.Large) /= 0.0 or - GEF."**"(0.0, 4.0) /= 0.0 or - 0.0 ** FXA5A00.Small /= 0.0 - then - Report.Failed("Incorrect results returned from the ""**"" " & - "operator when the value of the operand is 0.0"); - end if; - - - -- Check that exponentiation of various operands with a variety of - -- of exponent values yield correct results. - - if not Result_Within_Range(GEF."**"(5.0, 2.0), 25.0, 0.01) or - not Result_Within_Range(GEF."**"(1.225, 1.5), 1.36, 0.01) or - not Result_Within_Range(GEF."**"(0.26, 2.0), 0.068, 0.001) or - not Result_Within_Range( EF."**"(e, 5.0), 148.4, 0.1) or - not Result_Within_Range( EF."**"(10.0, e), 522.7, 0.1) or - not Result_Within_Range( EF."**"(e, (-3.0)), 0.050, 0.001) or - not Result_Within_Range(GEF."**"(10.0,(-2.0)), 0.010, 0.001) - then - Report.Failed("Incorrect results returned from the ""**"" " & - "operator with a variety of operand and exponent " & - "values"); - end if; - - - -- Use the following loops to check for internal consistency between - -- inverse functions. - - declare - -- Use the relative error value to account for non-exact - -- computations. - TC_Relative_Error: Float := 0.005; - begin - for i in 1..5 loop - for j in 0..5 loop - if not Incorrect_Inverse_Base_e and - not FXA5A00.Result_Within_Range - (Float(i)**Float(j), - e**(Float(j)*EF.Log(Float(i))), - TC_Relative_Error) - then - Incorrect_Inverse_Base_e := True; - Report.Failed("Incorrect Log-** Inverse calc for Base e " & - "with i= " & Integer'Image(i) & " and j= " & - Integer'Image(j)); - end if; - if not Incorrect_Inverse_Base_2 and - not FXA5A00.Result_Within_Range - (Float(i)**Float(j), - 2.0**(Float(j)*EF.Log(Float(i),2.0)), - TC_Relative_Error) - then - Incorrect_Inverse_Base_2 := True; - Report.Failed("Incorrect Log-** Inverse calc for Base 2 " & - "with i= " & Integer'Image(i) & " and j= " & - Integer'Image(j)); - end if; - if not Incorrect_Inverse_Base_8 and - not FXA5A00.Result_Within_Range - (Float(i)**Float(j), - 8.0**(Float(j)*EF.Log(Float(i),8.0)), - TC_Relative_Error) - then - Incorrect_Inverse_Base_8 := True; - Report.Failed("Incorrect Log-** Inverse calc for Base 8 " & - "with i= " & Integer'Image(i) & " and j= " & - Integer'Image(j)); - end if; - if not Incorrect_Inverse_Base_10 and - not FXA5A00.Result_Within_Range - (Float(i)**Float(j), - 10.0**(Float(j)*EF.Log(Float(i),10.0)), - TC_Relative_Error) - then - Incorrect_Inverse_Base_10 := True; - Report.Failed("Incorrect Log-** Inverse calc for Base 10 " & - "with i= " & Integer'Image(i) & " and j= " & - Integer'Image(j)); - end if; - if not Incorrect_Inverse_Base_16 and - not FXA5A00.Result_Within_Range - (Float(i)**Float(j), - 16.0**(Float(j)*EF.Log(Float(i),16.0)), - TC_Relative_Error) - then - Incorrect_Inverse_Base_16 := True; - Report.Failed("Incorrect Log-** Inverse calc for Base 16 " & - "with i= " & Integer'Image(i) & " and j= " & - Integer'Image(j)); - end if; - end loop; - end loop; - end; - - -- Reset Flags. - Incorrect_Inverse_Base_e := False; - Incorrect_Inverse_Base_2 := False; - Incorrect_Inverse_Base_8 := False; - Incorrect_Inverse_Base_10 := False; - Incorrect_Inverse_Base_16 := False; - - - -- Testing of Exp Function, both instantiated and pre-instantiated - -- version. - - -- Check that the result of the Exp Function, when provided an X - -- parameter value of 0.0, is 1.0. - - if GEF.Exp(X => 0.0) /= 1.0 or - EF.Exp(0.0) /= 1.0 - then - Report.Failed("Incorrect result returned by Function Exp when " & - "given a parameter value of 0.0"); - end if; - - - -- Check that the Exp Function provides correct results when provided - -- a variety of input parameter values. - - if not Result_Within_Range(GEF.Exp(0.001), 1.01, 0.01) or - not Result_Within_Range( EF.Exp(0.1), 1.11, 0.01) or - not Result_Within_Range(GEF.Exp(1.2697), 3.56, 0.01) or - not Result_Within_Range( EF.Exp(3.2525), 25.9, 0.1) or - not Result_Within_Range(GEF.Exp(-0.2198), 0.803, 0.001) or - not Result_Within_Range( EF.Exp(-1.6621), 0.190, 0.001) or - not Result_Within_Range(GEF.Exp(-2.3888), 0.092, 0.001) or - not Result_Within_Range( EF.Exp(-5.4415), 0.004, 0.001) - then - Report.Failed("Incorrect result from Function Exp when provided " & - "a variety of input parameter values"); - end if; - - -- Use the following loops to check for internal consistency between - -- inverse functions. - - Arg := 0.01; - while Arg < 10.0 loop - if not Incorrect_Inverse_Base_e and - FXA5A00.Result_Within_Range(EF.Exp(Arg), - e**(Arg*EF.Log(Arg)), - 0.001) - then - Incorrect_Inverse_Base_e := True; - Report.Failed("Incorrect Exp-** Inverse calc for Base e"); - end if; - if not Incorrect_Inverse_Base_2 and - FXA5A00.Result_Within_Range(EF.Exp(Arg), - 2.0**(Arg*EF.Log(Arg,2.0)), - 0.001) - then - Incorrect_Inverse_Base_2 := True; - Report.Failed("Incorrect Exp-** Inverse calc for Base 2"); - end if; - if not Incorrect_Inverse_Base_8 and - FXA5A00.Result_Within_Range(EF.Exp(Arg), - 8.0**(Arg*EF.Log(Arg,8.0)), - 0.001) - then - Incorrect_Inverse_Base_8 := True; - Report.Failed("Incorrect Exp-** Inverse calc for Base 8"); - end if; - if not Incorrect_Inverse_Base_10 and - FXA5A00.Result_Within_Range(EF.Exp(Arg), - 10.0**(Arg*EF.Log(Arg,10.0)), - 0.001) - then - Incorrect_Inverse_Base_10 := True; - Report.Failed("Incorrect Exp-** Inverse calc for Base 10"); - end if; - if not Incorrect_Inverse_Base_16 and - FXA5A00.Result_Within_Range(EF.Exp(Arg), - 16.0**(Arg*EF.Log(Arg,16.0)), - 0.001) - then - Incorrect_Inverse_Base_16 := True; - Report.Failed("Incorrect Exp-** Inverse calc for Base 16"); - end if; - Arg := Arg + 0.01; - end loop; - - - -- Testing of Sqrt Function, both instantiated and pre-instantiated - -- version. - - -- Check that Argument_Error is raised by the Sqrt Function when - -- the value of the input parameter X is negative. - - begin - Float_Result := EF.Sqrt(X => -FXA5A00.Small); - Report.Failed("Argument_Error not raised by Function Sqrt " & - "when provided a small negative input parameter " & - "value"); - Dont_Optimize_Float(Float_Result, 7); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Sqrt " & - "when provided a small negative input parameter " & - "value"); - end; - - begin - New_Float_Result := GEF.Sqrt(X => -64.0); - Report.Failed("Argument_Error not raised by Function Sqrt " & - "when provided a large negative input parameter " & - "value"); - Dont_Optimize_New_Float(New_Float_Result, 8); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised by Function Sqrt " & - "when provided a large negative input parameter " & - "value"); - end; - - - -- Check that the Sqrt Function, when given an X parameter value of 0.0, - -- returns a result of 0.0. - - if GEF.Sqrt(X => 0.0) /= 0.0 or - EF.Sqrt(0.0) /= 0.0 - then - Report.Failed("Incorrect result from Function Sqrt when provided " & - "an input parameter value of 0.0"); - end if; - - - -- Check that the Sqrt Function, when given an X parameter input value - -- of 1.0, returns a result of 1.0. - - if GEF.Sqrt(X => 1.0) /= 1.0 or - EF.Sqrt(1.0) /= 1.0 - then - Report.Failed("Incorrect result from Function Sqrt when provided " & - "an input parameter value of 1.0"); - end if; - - - -- Check that the Sqrt Function provides correct results when provided - -- a variety of input parameter values. - - if not FXA5A00.Result_Within_Range(GEF.Sqrt(0.0327), 0.181, 0.001) or - not FXA5A00.Result_Within_Range( EF.Sqrt(0.1808), 0.425, 0.001) or - not FXA5A00.Result_Within_Range(GEF.Sqrt(1.0556), 1.03, 0.01) or - not FXA5A00.Result_Within_Range( EF.Sqrt(32.8208), 5.73, 0.01) or - not FXA5A00.Result_Within_Range( EF.Sqrt(27851.0), 166.9, 0.1) or - not FXA5A00.Result_Within_Range( EF.Sqrt(61203.4), 247.4, 0.1) or - not FXA5A00.Result_Within_Range( EF.Sqrt(655891.0), 809.9, 0.1) - then - Report.Failed("Incorrect result from Function Sqrt when provided " & - "a variety of input parameter values"); - end if; - - -- Check internal consistency between functions. - - Arg := 0.01; - while Arg < 10.0 loop - if not Flag_1 and - not FXA5A00.Result_Within_Range(Arg, - EF.Sqrt(Arg)*EF.Sqrt(Arg), - 0.01) - then - Report.Failed("Inconsistency found in Case 1"); - Flag_1 := True; - end if; - if not Flag_2 and - not FXA5A00.Result_Within_Range(Arg, EF.Sqrt(Arg)**2.0, 0.01) - then - Report.Failed("Inconsistency found in Case 2"); - Flag_2 := True; - end if; - if not Flag_3 and - not FXA5A00.Result_Within_Range(EF.Log(Arg), - EF.Log(Sqrt(Arg)**2.0), 0.01) - then - Report.Failed("Inconsistency found in Case 3"); - Flag_3 := True; - end if; - if not Flag_4 and - not FXA5A00.Result_Within_Range(EF.Log(Arg), - 2.00*EF.Log(EF.Sqrt(Arg)), - 0.01) - then - Report.Failed("Inconsistency found in Case 4"); - Flag_4 := True; - end if; - Arg := Arg + 1.0; - end loop; - - - exception - when The_Error : others => - Report.Failed ("The following exception was raised in the " & - "Test_Block: " & Exception_Name(The_Error)); - end Test_Block; - - Report.Result; - -end CXA5A10; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a deleted file mode 100644 index 16f30752db1..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a +++ /dev/null @@ -1,243 +0,0 @@ --- CXA8001.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 all elements to be transferred to a sequential file of --- mode Append_File will be placed following the last element currently --- in the file. --- Check that it is possible to append data to a file that has been --- previously appended to. --- Check that the predefined procedure Write will place an element after --- the last element in the file in mode Append_File. --- --- TEST DESCRIPTION: --- This test implements a sequential file system that has the capability --- to store data records at the end of a file. Initially, the file is --- opened with mode Out_File, and data is written to the file. The file --- is closed, then reopened with mode Append_File. An additional record --- is written, and again the file is closed. The file is then reopened, --- again with mode Append_File, and another record is written to the --- file. --- The file is closed again, the reopened with mode In_File, and the data --- in the file is read and checked for proper ordering within the file. --- --- An expected common usage of Append_File mode would be in the opening --- of a file that currently contains data. Likewise, the reopening of --- files in Append_Mode that have been previously appended to for the --- addition of more data would be frequently encountered. This test --- attempts to simulate both situations. (Of course, in an actual user --- environment, the open/write/close processing would be performed using --- looping structures, rather than the straight-line processing displayed --- here.) --- --- APPLICABILITY CRITERIA: --- Applicable to all systems capable of supporting IO operations on --- external Sequential_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations ---! - -with Sequential_IO; -with Report; - -procedure CXA8001 is - - -- Declare data types and objects to be stored in the file. - subtype Name_Type is String (1 .. 10); - type Tickets is range 0 .. 1000; - - type Order_Type is record - Name : Name_Type; - No_of_Tickets : Tickets; - end record; - - package Order_IO is new Sequential_IO (Order_Type); -- Declare Seq_IO - -- package, - Order_File : Order_IO.File_Type; -- and file object. - Order_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXA8001" ); - Incomplete : exception; - -begin - - Report.Test ("CXA8001", "Check that all elements to be transferred to a " & - "sequential file of mode Append_File will be " & - "placed following the last element currently " & - "in the file"); - - Test_for_Sequential_IO_Support: - begin - - -- An implementation that does not support Sequential_IO in a particular - -- environment will raise Use_Error or Name_Error on calls to various - -- Sequential_IO operations. This block statement encloses a call to - -- Create, which should produce an exception in a non-supportive - -- environment. These exceptions will be handled to produce a - -- Not_Applicable result. - - Order_IO.Create (File => Order_File, -- Create Sequential_IO file - Mode => Order_IO.Out_File, -- with mode Out_File. - Name => Order_Filename); - - exception - - when Order_IO.Use_Error | Order_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Sequential_IO" ); - raise Incomplete; - - end Test_for_Sequential_IO_Support; - - Operational_Test_Block: - declare - -- Assign values into the component fields of the data objects. - Buyer_1 : constant Order_Type := ("John Smith", 3); - Buyer_2 : constant Order_Type := - (Name => "Jane Jones", No_of_Tickets => 2); - Buyer_3 : Order_Type := ("Mike Brown", 5); - - begin - Order_IO.Write (File => Order_File, -- Write initial data item - Item => Buyer_1); -- to file. - - Order_IO.Close (File => Order_File); -- Close file. - - -- - -- Enter additional data records into the file. (Append to a file of - -- previous mode Out_File). - -- - Order_IO.Open (Order_File, -- Open Sequential_IO file - Order_IO.Append_File, -- with mode Append_File. - Order_Filename); - - Order_IO.Write (Order_File, Buyer_2); -- Write second data item - -- to file. - Order_IO.Close (File => Order_File); -- Close file. - - -- Check to determine whether file is actually closed. - begin - Order_IO.Write (Order_File, Buyer_2); - Report.Failed("Exception not raised on Write to Closed file"); - exception - when Order_IO.Status_Error => null; -- Expected exception. - when others => - Report.Failed("Incorrect exception on Write to Closed file"); - end; - - -- - -- The following code segment demonstrates appending data to a file - -- that has been previously appended to. - -- - - Order_IO.Open (Order_File, -- Open Sequential_IO file - Order_IO.Append_File, -- with mode Append_File. - Order_Filename ); - - Order_IO.Write (Order_File, Buyer_3); -- Write third data item - -- to file. - Order_IO.Close (File => Order_File); -- Close file. - - - Test_Verification_Block: - declare - TC_Order1, TC_Order2, TC_Order3 : Order_Type; - begin - - Order_IO.Open (Order_File, -- Open Sequential_IO file - Order_IO.In_File, -- with mode In_File. - Order_Filename ); - - Order_IO.Read (File => Order_File, -- Read records from file. - Item => TC_Order1); - Order_IO.Read (Order_File, TC_Order2); - Order_IO.Read (Order_File, TC_Order3); - - -- Compare the contents of each with the individual data items. - -- If items read from file do not match the items placed into - -- the file, in the appropriate order, then fail. - - if ((TC_Order1 /= Buyer_1) or - (TC_Order2.Name /= Buyer_2.Name) or - (TC_Order2.No_of_Tickets /= Buyer_2.No_of_Tickets) or - not ((TC_Order3.Name = "Mike Brown") and - (TC_Order3.No_of_Tickets = 5))) then - Report.Failed ("Incorrect appending of record data in file"); - end if; - - -- Check to determine that no more than three data records were - -- actually written to the file. - if not Order_IO.End_Of_File (Order_File) then - Report.Failed("File not empty after three reads"); - end if; - - exception - - when Order_IO.End_Error => -- If three items not in - -- file (data overwritten), - -- then fail. - Report.Failed ("Incorrect number of record elements in file"); - - when others => - Report.Failed ("Error raised during data verification"); - - end Test_Verification_Block; - - exception - - when others => - Report.Failed("Exception raised during Sequential_IO processing"); - - end Operational_Test_Block; - - Deletion: - begin - -- Check that file is open prior to deleting it. - if Order_IO.Is_Open(Order_File) then - Order_IO.Delete (Order_File); - else - Order_IO.Open(Order_File, Order_IO.In_File, Order_Filename); - Order_IO.Delete (Order_File); - end if; - - exception - when others => - Report.Failed - ( "Delete not properly implemented for Sequential_IO" ); - - end Deletion; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXA8001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a deleted file mode 100644 index 8670e98bac9..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a +++ /dev/null @@ -1,285 +0,0 @@ --- CXA8002.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 resetting a file using mode Append_File allows for the --- writing of elements to the file starting after the last element in --- the file. --- Check that the result of function Name can be used on a subsequent --- reopen of the file. --- Check that a mode change occurs on reset of a file to/from mode --- Append_File. --- --- TEST DESCRIPTION: --- This test simulates the read/write of data from/to an individual --- sequential file. New data can be appended to the end of the existing --- file, and the same file can be reset to allow reading of data from --- the file. This process can occur multiple times. --- When the mode of the file is changed with a Reset, the current mode --- value assigned to the file is checked using the result of function --- Mode. This, in conjunction with the read/write operations, verifies --- that a mode change has taken place on Reset. --- --- An expected common usage of the scenarios found in this test would --- be a case where a single data file is kept open continuously, being --- reset for read/append of data. For systems that do not support a --- direct form of I/O, this would allow for efficient use of a sequential --- I/O file. --- --- APPLICABILITY CRITERIA: --- Applicable to all systems capable of supporting IO operations on --- external Sequential_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Feb 97 PWB.CTA Fixed handling for file non-support and Reset --- non-support. ---! - -with Sequential_IO; -with Report; - -procedure CXA8002 is - subtype Employee_Data is String (1 .. 11); - package Data_IO is new Sequential_IO (Employee_Data); - - Employee_Data_File : Data_IO.File_Type; - Employee_Filename : constant String := - Report.Legal_File_Name (Nam => "CXA8002"); - - Incomplete : exception; - -begin - - Report.Test ("CXA8002", "Check that resetting a file using mode " & - "Append_File allows for the writing of " & - "elements to the file starting after the " & - "last element in the file"); - - Test_for_Sequential_IO_Support: - begin - - -- An implementation that does not support Sequential_IO in a particular - -- environment will raise Use_Error or Name_Error on calls to various - -- Sequential_IO operations. This block statement encloses a call to - -- Create, which should produce an exception in a non-supportive - -- environment. These exceptions will be handled to produce a - -- Not_Applicable result. - - Data_IO.Create (File => Employee_Data_File, -- Create file in - Mode => Data_IO.Append_File, -- mode Append_File. - Name => Employee_Filename); - - -- - -- The following portion of code demonstrates the fact that a sequential - -- file can be created in Append_File mode, and that data can be written - -- to the file. - -- - - exception - when Data_IO.Use_Error | Data_IO.Name_Error => - Report.Not_Applicable - ( "Sequential files not supported - Create as Append_File"); - raise Incomplete; - end Test_for_Sequential_IO_Support; - Operational_Test_Block: - declare - Blank_Data : constant Employee_Data := " "; - Employee_1 : constant Employee_Data := "123-45-6789"; - Employee_2 : Employee_Data := "987-65-4321"; - - -- Note: Artificial numerical data chosen above to prevent any - -- unintended similarity with persons alive or dead. - - TC_Employee_Data : Employee_Data := Blank_Data; - - - function TC_Mode_Selection (Selector : Integer) - return Data_IO.File_Mode is - begin - case Report.Ident_Int(Selector) is - when 1 => return Data_IO.In_File; - when 2 => return Data_IO.Out_File; - when others => return Data_IO.Append_File; - end case; - end TC_Mode_Selection; - - Employee_Filename : constant String := -- Use function Name to - Data_IO.Name (File => Employee_Data_File); -- store filename in - -- string variable. - begin - - Data_IO.Write (File => Employee_Data_File, -- Write initial data - Item => Employee_1); -- entry to file. - - -- - -- The following portion of code demonstrates that a sequential file - -- can be reset to various file modes, including Append_File mode, - -- allowing data to be added to the end of the file. - -- - begin - Data_IO.Reset (File => Employee_Data_File, -- Reset file with - Mode => Data_IO.In_File); -- mode In_File. - exception - when Data_IO.Use_Error => - Report.Not_Applicable - ("Reset to In_File not supported for Sequential_IO"); - raise Incomplete; - when others => - Report.Failed - ("Unexpected exception on Reset to In_File (Sequential_IO)"); - raise Incomplete; - end; - if Data_IO."="(Data_IO.Mode (Employee_Data_File), - TC_Mode_Selection (1)) then -- Compare In_File mode - -- Reset successful, - Data_IO.Read (File => Employee_Data_File, -- now verify file data. - Item => TC_Employee_Data); - - if ((TC_Employee_Data (1 .. 7) /= "123-45-") or - (TC_Employee_Data (5 .. 11) /= "45-6789")) then - Report.Failed ("Data read error"); - end if; - - else - Report.Failed ("File mode not changed by Reset"); - end if; - - -- - -- Simulate appending data to a file that has previously been written - -- to and read from. - -- - begin - Data_IO.Reset (File => Employee_Data_File, -- Reset file with - Mode => Data_IO.Append_File); -- mode Append_File. - exception - when Data_IO.Use_Error => - Report.Not_Applicable - ("Reset to Append_File not supported for Sequential_IO"); - raise Incomplete; - when others => - Report.Failed - ("Unexpected exception on Reset to Append_File (Sequential_IO)"); - raise Incomplete; - end; - - if Data_IO.Is_Open (Employee_Data_File) then -- File remains open - -- following Reset to - -- Append_File mode? - - if Data_IO."=" (Data_IO.Mode (Employee_Data_File), - TC_Mode_Selection (3)) then -- Compare to - -- Append_File mode. - Data_IO.Write (File => Employee_Data_File, -- Write additional - Item => Employee_2); -- data to file. - else - Report.Failed ("File mode not changed by Reset"); - end if; - - else - Report.Failed - ("File status not Open following Reset to Append mode"); - end if; - - Data_IO.Close (Employee_Data_File); - - - Test_Verification_Block: - begin - - Data_IO.Open (File => Employee_Data_File, -- Reopen file, using - Mode => Data_IO.In_File, -- previous result of - Name => Employee_Filename); -- function Name. - - TC_Employee_Data := Blank_Data; -- Clear record field. - Data_IO.Read (Employee_Data_File, -- Read first record, - TC_Employee_Data); -- check ordering of - -- records. - - if not ((TC_Employee_Data (1 .. 3) = "123") and then - (TC_Employee_Data (4 .. 11) = "-45-6789")) then - Report.Failed ("Data read error - first record"); - end if; - - TC_Employee_Data := Blank_Data; -- Clear record field. - Data_IO.Read (Employee_Data_File, -- Read second record, - TC_Employee_Data); -- check for ordering of - -- records. - - if ((TC_Employee_Data (1 .. 6) /= "987-65") or else - not (TC_Employee_Data (3 .. 11) = "7-65-4321")) then - Report.Failed ("Data read error - second record"); - end if; - - -- Check that only two items were written to the file. - if not Data_IO.End_Of_File(Employee_Data_File) then - Report.Failed("Incorrect number of records in file"); - end if; - - exception - - when Data_IO.End_Error => -- If two items not in - -- file (data overwritten), - -- then fail. - Report.Failed ("Incorrect number of record elements in file"); - - when others => - Report.Failed ("Error raised during data verification"); - - end Test_Verification_Block; - - exception - - when others => - Report.Failed("Exception raised during Sequential_IO processing"); - - end Operational_Test_Block; - - Final_Block: - begin - -- Check that file is open prior to deleting it. - if Data_IO.Is_Open(Employee_Data_File) then - Data_IO.Delete (Employee_Data_File); - else - Data_IO.Open(Employee_Data_File, - Data_IO.In_File, - Employee_Filename); - Data_IO.Delete (Employee_Data_File); - end if; - exception - when others => - Report.Failed ("Sequential_IO Delete not properly supported"); - end Final_Block; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ("Unexpected exception"); - Report.Result; -end CXA8002; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a b/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a deleted file mode 100644 index cf9b5e07598..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a +++ /dev/null @@ -1,214 +0,0 @@ --- CXA8003.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 Append_File mode has not been added to package Direct_IO. --- --- TEST DESCRIPTION: --- This test uses a procedure to change the mode of an existing Direct_IO --- file. The file descriptor is passed as a parameter, along with a --- numeric indicator for the new mode. Based on the numeric parameter, --- a Direct_IO.Reset is performed using a File_Mode'Value transformation --- of a string constant into a File_Mode value. An attempt to reset a --- Direct_IO file to mode Append_File should cause an Constraint_Error --- to be raised, as Append_File mode has not been added to Direct_IO in --- Ada 9X. --- --- APPLICABILITY CRITERIA: --- This test is applicable to all implementations supporting Direct_IO --- files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Feb 97 PWB.CTA Allowed for non-support of Reset for certain --- modes. ---! - -with Direct_IO; -with Report; - -procedure CXA8003 is - Incomplete : exception; - begin - - Report.Test ("CXA8003", "Check that Append_File mode has not " & - "been added to package Direct_IO"); - - Test_for_Direct_IO_Support: - declare - - subtype String_Data_Type is String (1 .. 20); - type Numeric_Data_Type is range 1 .. 512; - type Composite_Data_Type is array (1 .. 3) of String_Data_Type; - - type File_Data_Type is record - Data_Field_1 : String_Data_Type; - Data_Field_2 : Numeric_Data_Type; - Data_Field_3 : Composite_Data_Type; - end record; - - package Dir_IO is new Direct_IO (File_Data_Type); - - Data_File : Dir_IO.File_Type; - Dir_Filename : constant String := Report.Legal_File_Name; - - begin - - -- An application creates a text file with mode Out_File. - -- Use_Error will be raised if Direct_IO operations or external - -- files are not supported. - - Dir_IO.Create (Data_File, - Dir_IO.Out_File, - Dir_Filename); - - Change_File_Mode: - declare - - TC_Append_Test_Executed : Boolean := False; - - type Mode_Selection_Type is ( A, I, IO, O ); - - - procedure Change_Mode (File : in out Dir_IO.File_Type; - To : in Mode_Selection_Type) is - begin - case To is - when A => - TC_Append_Test_Executed := True; - Dir_IO.Reset - (File, Dir_IO.File_Mode'Value("Append_File")); - when I => - begin - Dir_IO.Reset - (File, Dir_IO.File_Mode'Value("In_File")); - exception - when Dir_IO.Use_Error => - Report.Not_Applicable - ("Reset to In_File not supported: Direct_IO"); - raise Incomplete; - end; - when IO => - begin - Dir_IO.Reset - (File, Dir_IO.File_Mode'Value("Inout_File")); - exception - when Dir_IO.Use_Error => - Report.Not_Applicable - ("Reset to InOut_File not supported: Direct_IO"); - raise Incomplete; - end; - when O => - begin - Dir_IO.Reset - (File, Dir_IO.File_Mode'Value("Out_File")); - exception - when Dir_IO.Use_Error => - Report.Not_Applicable - ("Reset to Out_File not supported: Direct_IO"); - raise Incomplete; - end; - end case; - end Change_Mode; - - - begin - - -- At some point in the processing, the application may call a - -- procedure to change the mode of the file (perhaps for - -- additional data entry, data verification, etc.). It is at - -- this point that a use of Append_File mode for a Direct_IO - -- file would cause an exception. - - for I in reverse Mode_Selection_Type loop - Change_Mode (Data_File, I); - Report.Comment - ("Mode changed to " & - Dir_IO.File_Mode'Image (Dir_IO.Mode (Data_File))); - end loop; - - Report.Failed("No error raised on change to Append_File mode"); - - exception - - -- A handler has been provided in the application, which - -- handles the constraint error, allowing processing to - -- continue. - - when Constraint_Error => - - if TC_Append_Test_Executed then - Report.Comment ("Constraint_Error correctly raised on " & - "attempted Append_File mode selection " & - "for a Direct_IO file"); - else - Report.Failed ("Append test was not executed"); - end if; - - when Incomplete => raise; - - when others => Report.Failed ("Unexpected exception raised"); - - end Change_File_Mode; - - Final_Block: - begin - if Dir_IO.Is_Open (Data_File) then - Dir_IO.Delete (Data_File); - else - Dir_IO.Open (Data_File, Dir_IO.In_File, Dir_Filename); - Dir_IO.Delete (Data_File); - end if; - exception - when others => - Report.Failed ("Delete not properly supported: Direct_IO"); - end Final_Block; - - exception - - -- Since Use_Error or Name_Error can be raised if, for the - -- specified mode, the environment does not support Direct_IO - -- operations, the following handlers are included: - - when Dir_IO.Name_Error => - Report.Not_Applicable("Name_Error raised on Direct IO Create"); - - when Dir_IO.Use_Error => - Report.Not_Applicable("Use_Error raised on Direct IO Create"); - - when others => - Report.Failed - ("Unexpected exception raised on Direct IO Create"); - - end Test_for_Direct_IO_Support; - - Report.Result; - -exception - when Incomplete => - Report.Result; - -end CXA8003; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a deleted file mode 100644 index 4fe9c357614..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a +++ /dev/null @@ -1,287 +0,0 @@ --- CXA9001.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 operations defined in the generic package --- Ada.Storage_IO provide the ability to store and retrieve objects --- which may include implicit levels of indirection in their --- implementation, from an in-memory buffer. --- --- TEST DESCRIPTION: --- The following scenario demonstrates how an object of a type with --- (potential) levels of indirection (based on the implementation) --- can be "flattened" and written/read to/from a Direct_IO file. --- In this small example, we have attempted to simulate the situation --- where two independent programs are using a particular Direct_IO file, --- one writing data to the file, and the second program reading that file. --- The Storage_IO Read and Write procedures are used to "flatten" --- and reconstruct objects of the record type. --- --- APPLICABILITY CRITERIA: --- Applicable to implementations capable of supporting external --- Direct_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 07 Jun 95 SAIC Modified to constrain type used with Storage_IO. --- 20 Nov 95 SAIC Corrected and enhanced for ACVC 2.0.1. --- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations ---! - -with Report; -with Ada.Storage_IO; -with Ada.Direct_IO; - -procedure CXA9001 is - package Dir_IO is new Ada.Direct_IO (Integer); - Test_File : Dir_IO.File_Type; - Incomplete : exception; -begin - - Report.Test ("CXA9001", "Check that the operations defined in the " & - "generic package Ada.Storage_IO provide the " & - "ability to store and retrieve objects which " & - "may include implicit levels of indirection in " & - "their implementation, from an in-memory buffer"); - - - Test_For_Direct_IO_Support: - begin - - -- The following Create does not have any bearing on the test scenario, - -- but is included to check that the implementation supports Direct_IO - -- files. An exception on this Create statement will raise a Name_Error - -- or Use_Error, which will be handled to produce a Not_Applicable - -- result. If created, the file is immediately deleted, as it is not - -- needed for the program scenario. - - Dir_IO.Create (Test_File, Dir_IO.Out_File, Report.Legal_File_Name(1)); - - exception - - when Dir_IO.Use_Error | Dir_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Direct_IO" ); - raise Incomplete; - - end Test_for_Direct_IO_Support; - - Deletion1: - begin - Dir_IO.Delete (Test_File); - exception - when others => - Report.Failed - ( "Delete not properly implemented for Direct_IO - 1" ); - end Deletion1; - - - Test_Block: - declare - - The_Filename : constant String := Report.Legal_File_Name(2); - - -- The following type is the basic unit used in this test. It is - -- incorporated into the definition of the Unit_Array_Type. - - type Unit_Type is - record - Position : Natural := 19; - String_Value : String (1..9) := (others => 'X'); - end record; - - TC_Size : Natural := Natural'First; - - procedure Data_Storage (Number_Of_Units : in Natural; - Result : out Natural) is - - -- Type based on input parameter. Uses type Unit_Type - -- as the array element. - type Unit_Array_Type is array (1..Number_Of_Units) - of Unit_Type; - - -- This type definition is the ultimate storage type used - -- in this test; uses type Unit_Array_Type as a record - -- component field. - -- This record type contains a component that is an array of - -- records, with each of these records containing a Natural - -- and a String value (i.e., a record containing an array of - -- records). - - type Data_Storage_Type is - record - Data_Value : Natural := Number_Of_Units; - Unit_Array : Unit_Array_Type; - end record; - - -- The instantiation of the following generic package is a - -- central point in this test. Storage_IO is instantiated for - -- a specific data type, and will be used to "flatten" objects - -- of that type into buffers. Direct_IO is instantiated for - -- these Storage_IO buffers. - - package Flat_Storage_IO is - new Ada.Storage_IO (Data_Storage_Type); - package Buffer_IO is - new Ada.Direct_IO (Flat_Storage_IO.Buffer_Type); - - Buffer_File : Buffer_IO.File_Type; - Outbound_Buffer : Flat_Storage_IO.Buffer_Type; - Storage_Item : Data_Storage_Type; - - begin -- procedure Data_Storage - - Buffer_IO.Create (Buffer_File, - Buffer_IO.Out_File, - The_Filename); - - Flat_Storage_IO.Write (Buffer => Outbound_Buffer, - Item => Storage_Item); - - -- At this point, any levels of indirection have been removed - -- by the Storage_IO procedure, and the buffered data can be - -- written to a file. - - Buffer_IO.Write (Buffer_File, Outbound_Buffer); - Buffer_IO.Close (Buffer_File); - Result := Storage_Item.Unit_Array'Last + -- 5 + - Storage_Item.Unit_Array -- 9 - (Storage_Item.Unit_Array'First).String_Value'Length; - - exception - when others => - Report.Failed ("Data storage error"); - if Buffer_IO.Is_Open (Buffer_File) then - Buffer_IO.Close (Buffer_File); - end if; - end Data_Storage; - - procedure Data_Retrieval (Number_Of_Units : in Natural; - Result : out Natural) is - type Unit_Array_Type is array (1..Number_Of_Units) - of Unit_Type; - - type Data_Storage_Type is - record - Data_Value : Natural := Number_Of_Units; - Unit_Array : Unit_Array_Type; - end record; - - package Flat_Storage_IO is - new Ada.Storage_IO (Data_Storage_Type); - package Reader_IO is - new Ada.Direct_IO (Flat_Storage_IO.Buffer_Type); - - Reader_File : Reader_IO.File_Type; - Inbound_Buffer : Flat_Storage_IO.Buffer_Type; - Storage_Item : Data_Storage_Type; - TC_Item : Data_Storage_Type; - - begin -- procedure Data_Retrieval - - Reader_IO.Open (Reader_File, Reader_IO.In_File, The_Filename); - Reader_IO.Read (Reader_File, Inbound_Buffer); - - Flat_Storage_IO.Read (Inbound_Buffer, Storage_Item); - - -- Validate the reconstructed value against an "unflattened" - -- value. - - if Storage_Item.Data_Value /= TC_Item.Data_Value - then - Report.Failed ("Data_Retrieval Error - 1"); - end if; - - for i in 1..Number_Of_Units loop - if Storage_Item.Unit_Array(i).String_Value'Length /= - TC_Item.Unit_Array(i).String_Value'Length or - Storage_Item.Unit_Array(i).Position /= - TC_Item.Unit_Array(i).Position or - Storage_Item.Unit_Array(i).String_Value /= - TC_Item.Unit_Array(i).String_Value - then - Report.Failed ("Data_Retrieval Error - 2"); - end if; - end loop; - - Result := Storage_Item.Unit_Array'Last + -- 5 + - Storage_Item.Unit_Array -- 9 - (Storage_Item.Unit_Array'First).String_Value'Length; - - if Reader_IO.Is_Open (Reader_File) then - Reader_IO.Delete (Reader_File); - else - Reader_IO.Open (Reader_File, - Reader_IO.In_File, - The_Filename); - Reader_IO.Delete (Reader_File); - end if; - - exception - when others => - Report.Failed ("Exception raised in Data_Retrieval"); - if Reader_IO.Is_Open (Reader_File) then - Reader_IO.Delete (Reader_File); - else - Reader_IO.Open (Reader_File, - Reader_IO.In_File, - The_Filename); - Reader_IO.Delete (Reader_File); - end if; - end Data_Retrieval; - - - begin -- Test_Block - - -- The number of Units is provided in this call to Data_Storage. - Data_Storage (Number_Of_Units => Natural(Report.Ident_Int(5)), - Result => TC_Size); - - if TC_Size /= 14 then - Report.Failed ("Data_Storage error in Data_Storage"); - end if; - - Data_Retrieval (Number_Of_Units => Natural(Report.Ident_Int(5)), - Result => TC_Size); - - if TC_Size /= 14 then - Report.Failed ("Data retrieval error in Data_Retrieval"); - end if; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXA9001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a deleted file mode 100644 index 415a56630ad..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a +++ /dev/null @@ -1,482 +0,0 @@ --- CXA9002.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 operations defined in the generic package --- Ada.Storage_IO provide the ability to store and retrieve objects --- of tagged types from in-memory buffers. --- --- TEST DESCRIPTION: --- The following scenario demonstrates how objects of a tagged type, --- extended types, and twice extended types can be written/read --- to/from Direct_IO files. The Storage_IO subprograms, Read and Write, --- demonstrated in this scenario, perform tag "fixing" prior to/following --- transfer to the Direct_IO files. --- This method is especially important for those implementations that --- represent tags as pointers, or for cases where the tagged objects --- are read in by a program other than the one that wrote them. --- --- In this small example, we have attempted to simulate the situation --- where two independent programs are using a series of Direct_IO files, --- one writing data to the files, and the second program reading the --- data from those files. Two procedures are defined, the first --- simulating the program responsible for writing, the second simulating --- a separate program opening and reading the data from the files. --- --- The hierarchy of types used in this test can be displayed as follows: --- --- Account_Type --- / \ --- / \ --- / \ --- Cash_Account_Type Investment_Account_Type --- / \ --- / \ --- / \ --- Checking_Account_Type Savings_Account_Type --- --- APPLICABILITY CRITERIA: --- Applicable to implementations capable of supporting external --- Direct_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 08 Nov 95 SAIC Corrected incorrect prefix of 'Tag for ACVC 2.0.1, --- and mode of files in Procedure Read_Data. --- Added verification of objects reconstructed from --- files. --- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations ---! - -package CXA9002_0 is - - type Investment_Type is (Stocks, Bonds, Mutual_Funds); - type Savings_Type is (Standard, Business, Impound); - - type Account_Type is tagged - record - Num : String (1..3); - end record; - - type Cash_Account_Type is new Account_Type with - record - Years_As_Customer : Natural := 1; - end record; - - type Investment_Account_Type is new Account_Type with - record - Investment_Vehicle : Investment_Type := Stocks; - end record; - - type Checking_Account_Type is new Cash_Account_Type with - record - Checks_Per_Year : Positive := 200; - Interest_Bearing : Boolean := False; - end record; - - type Savings_Account_Type is new Cash_Account_Type with - record - Kind : Savings_Type := Standard; - end record; - -end CXA9002_0; - ---- - -with Report; -with Ada.Storage_IO; -with Ada.Direct_IO; -with Ada.Tags; -with CXA9002_0; - -procedure CXA9002 is - package Dir_IO is new Ada.Direct_IO (Integer); - Test_File : Dir_IO.File_Type; - Incomplete : exception; -begin - - Report.Test ("CXA9002", "Check that the operations defined in the " & - "generic package Ada.Storage_IO provide the " & - "ability to store and retrieve objects of " & - "tagged types from in-memory buffers"); - - - Test_For_Direct_IO_Support: - begin - - -- The following Create does not have any bearing on the test scenario, - -- but is included to check that the implementation supports Direct_IO - -- files. An exception on this Create statement will raise a Name_Error - -- or Use_Error, which will be handled to produce a Not_Applicable - -- result. If created, the file is immediately deleted, as it is not - -- needed for the program scenario. - - Dir_IO.Create (Test_File, - Dir_IO.Out_File, - Report.Legal_File_Name(1)); - exception - - when Dir_IO.Use_Error | Dir_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Direct_IO" ); - raise Incomplete; - - end Test_for_Direct_IO_Support; - - Deletion: - begin - Dir_IO.Delete (Test_File); - exception - when others => - Report.Failed - ( "Delete not properly implemented for Direct_IO" ); - end Deletion; - - Test_Block: - declare - - use CXA9002_0; - - Acct_Filename : constant String := Report.Legal_File_Name(1); - Cash_Filename : constant String := Report.Legal_File_Name(2); - Inv_Filename : constant String := Report.Legal_File_Name(3); - Chk_Filename : constant String := Report.Legal_File_Name(4); - Sav_Filename : constant String := Report.Legal_File_Name(5); - - type Tag_Pointer_Type is access String; - - TC_Account_Type_Tag, - TC_Cash_Account_Type_Tag, - TC_Investment_Account_Type_Tag, - TC_Checking_Account_Type_Tag, - TC_Savings_Account_Type_Tag : Tag_Pointer_Type; - - TC_Account : Account_Type := - (Num => "123"); - - TC_Cash_Account : Cash_Account_Type := - (Num => "234", - Years_As_Customer => 3); - - TC_Investment_Account : Investment_Account_Type := - (Num => "456", - Investment_Vehicle => Bonds); - - TC_Checking_Account : Checking_Account_Type := - (Num => "567", - Years_As_Customer => 2, - Checks_Per_Year => 300, - Interest_Bearing => True); - - TC_Savings_Account : Savings_Account_Type := - (Num => "789", - Years_As_Customer => 14, - Kind => Business); - - procedure Buffer_Data is - - Account : Account_Type := - TC_Account; - Cash_Account : Cash_Account_Type := - TC_Cash_Account; - Investment_Account : Investment_Account_Type := - TC_Investment_Account; - Checking_Account : Checking_Account_Type := - TC_Checking_Account; - Savings_Account : Savings_Account_Type := - TC_Savings_Account; - - -- The instantiations below are a central point in this test. - -- Storage_IO is instantiated for each of the specific tagged - -- type. These instantiated packages will be used to compress - -- tagged objects of these various types into buffers that will - -- be written to the Direct_IO files declared below. - - package Acct_SIO is new Ada.Storage_IO (Account_Type); - package Cash_SIO is new Ada.Storage_IO (Cash_Account_Type); - package Inv_SIO is new Ada.Storage_IO (Investment_Account_Type); - package Chk_SIO is new Ada.Storage_IO (Checking_Account_Type); - package Sav_SIO is new Ada.Storage_IO (Savings_Account_Type); - - -- Direct_IO is instantiated for the buffer types defined in the - -- instantiated Storage_IO packages. - - package Acct_DIO is new Ada.Direct_IO (Acct_SIO.Buffer_Type); - package Cash_DIO is new Ada.Direct_IO (Cash_SIO.Buffer_Type); - package Inv_DIO is new Ada.Direct_IO (Inv_SIO.Buffer_Type); - package Chk_DIO is new Ada.Direct_IO (Chk_SIO.Buffer_Type); - package Sav_DIO is new Ada.Direct_IO (Sav_SIO.Buffer_Type); - - Acct_Buffer : Acct_SIO.Buffer_Type; - Cash_Buffer : Cash_SIO.Buffer_Type; - Inv_Buffer : Inv_SIO.Buffer_Type; - Chk_Buffer : Chk_SIO.Buffer_Type; - Sav_Buffer : Sav_SIO.Buffer_Type; - - Acct_File : Acct_DIO.File_Type; - Cash_File : Cash_DIO.File_Type; - Inv_File : Inv_DIO.File_Type; - Chk_File : Chk_DIO.File_Type; - Sav_File : Sav_DIO.File_Type; - - begin - - Acct_DIO.Create (Acct_File, Acct_DIO.Out_File, Acct_Filename); - Cash_DIO.Create (Cash_File, Cash_DIO.Out_File, Cash_Filename); - Inv_DIO.Create (Inv_File, Inv_DIO.Out_File, Inv_Filename); - Chk_DIO.Create (Chk_File, Chk_DIO.Out_File, Chk_Filename); - Sav_DIO.Create (Sav_File, Sav_DIO.Out_File, Sav_Filename); - - -- Store the tag values of the objects declared above for - -- comparison with tag values of objects following processing. - - TC_Account_Type_Tag := - new String'(Ada.Tags.External_Tag(Account_Type'Tag)); - - TC_Cash_Account_Type_Tag := - new String'(Ada.Tags.External_Tag(Cash_Account_Type'Tag)); - - TC_Investment_Account_Type_Tag := - new String'(Ada.Tags.External_Tag(Investment_Account_Type'Tag)); - - TC_Checking_Account_Type_Tag := - new String'(Ada.Tags.External_Tag(Checking_Account_Type'Tag)); - - TC_Savings_Account_Type_Tag := - new String'(Ada.Tags.External_Tag(Savings_Account_Type'Tag)); - - -- Prepare tagged data for writing to the Direct_IO files using - -- Storage_IO procedure to place data in buffers. - - Acct_SIO.Write (Buffer => Acct_Buffer, Item => Account); - Cash_SIO.Write (Cash_Buffer, Cash_Account); - Inv_SIO.Write (Inv_Buffer, Item => Investment_Account); - Chk_SIO.Write (Buffer => Chk_Buffer, Item => Checking_Account); - Sav_SIO.Write (Sav_Buffer, Savings_Account); - - -- At this point, the data and associated tag values have been - -- buffered by the Storage_IO procedure, and the buffered data - -- can be written to the appropriate Direct_IO file. - - Acct_DIO.Write (File => Acct_File, Item => Acct_Buffer); - Cash_DIO.Write (Cash_File, Cash_Buffer); - Inv_DIO.Write (Inv_File, Item => Inv_Buffer); - Chk_DIO.Write (File => Chk_File, Item =>Chk_Buffer); - Sav_DIO.Write (Sav_File, Sav_Buffer); - - -- Close all Direct_IO files. - - Acct_DIO.Close (Acct_File); - Cash_DIO.Close (Cash_File); - Inv_DIO.Close (Inv_File); - Chk_DIO.Close (Chk_File); - Sav_DIO.Close (Sav_File); - - exception - when others => Report.Failed("Exception raised in Buffer_Data"); - end Buffer_Data; - - procedure Read_Data is - - Account : Account_Type; - Cash_Account : Cash_Account_Type; - Investment_Account : Investment_Account_Type; - Checking_Account : Checking_Account_Type; - Savings_Account : Savings_Account_Type; - - -- Storage_IO is instantiated for each of the specific tagged - -- type. - - package Acct_SIO is new Ada.Storage_IO (Account_Type); - package Cash_SIO is new Ada.Storage_IO (Cash_Account_Type); - package Inv_SIO is new Ada.Storage_IO (Investment_Account_Type); - package Chk_SIO is new Ada.Storage_IO (Checking_Account_Type); - package Sav_SIO is new Ada.Storage_IO (Savings_Account_Type); - - -- Direct_IO is instantiated for the buffer types defined in the - -- instantiated Storage_IO packages. - - package Acct_DIO is new Ada.Direct_IO (Acct_SIO.Buffer_Type); - package Cash_DIO is new Ada.Direct_IO (Cash_SIO.Buffer_Type); - package Inv_DIO is new Ada.Direct_IO (Inv_SIO.Buffer_Type); - package Chk_DIO is new Ada.Direct_IO (Chk_SIO.Buffer_Type); - package Sav_DIO is new Ada.Direct_IO (Sav_SIO.Buffer_Type); - - Acct_Buffer : Acct_SIO.Buffer_Type; - Cash_Buffer : Cash_SIO.Buffer_Type; - Inv_Buffer : Inv_SIO.Buffer_Type; - Chk_Buffer : Chk_SIO.Buffer_Type; - Sav_Buffer : Sav_SIO.Buffer_Type; - - Acct_File : Acct_DIO.File_Type; - Cash_File : Cash_DIO.File_Type; - Inv_File : Inv_DIO.File_Type; - Chk_File : Chk_DIO.File_Type; - Sav_File : Sav_DIO.File_Type; - - begin - - -- Open the Direct_IO files. - - Acct_DIO.Open (Acct_File, Acct_DIO.In_File, Acct_Filename); - Cash_DIO.Open (Cash_File, Cash_DIO.In_File, Cash_Filename); - Inv_DIO.Open (Inv_File, Inv_DIO.In_File, Inv_Filename); - Chk_DIO.Open (Chk_File, Chk_DIO.In_File, Chk_Filename); - Sav_DIO.Open (Sav_File, Sav_DIO.In_File, Sav_Filename); - - -- Read the buffer data from the files using Direct_IO. - - Acct_DIO.Read (File => Acct_File, Item => Acct_Buffer); - Cash_DIO.Read (Cash_File, Cash_Buffer); - Inv_DIO.Read (Inv_File, Item => Inv_Buffer); - Chk_DIO.Read (File => Chk_File, Item =>Chk_Buffer); - Sav_DIO.Read (Sav_File, Sav_Buffer); - - -- At this point, the data and associated tag values are stored - -- in buffers. Use the Storage_IO procedure Read to recreate the - -- tagged objects from the buffers. - - Acct_SIO.Read (Buffer => Acct_Buffer, Item => Account); - Cash_SIO.Read (Cash_Buffer, Cash_Account); - Inv_SIO.Read (Inv_Buffer, Item => Investment_Account); - Chk_SIO.Read (Buffer => Chk_Buffer, Item => Checking_Account); - Sav_SIO.Read (Sav_Buffer, Savings_Account); - - -- Delete all Direct_IO files. - - Acct_DIO.Delete (Acct_File); - Cash_DIO.Delete (Cash_File); - Inv_DIO.Delete (Inv_File); - Chk_DIO.Delete (Chk_File); - Sav_DIO.Delete (Sav_File); - - Data_Verification_Block: - begin - - if Account /= TC_Account then - Report.Failed("Incorrect Account object reconstructed"); - end if; - - if Cash_Account /= TC_Cash_Account then - Report.Failed - ("Incorrect Cash_Account object reconstructed"); - end if; - - if Investment_Account /= TC_Investment_Account then - Report.Failed - ("Incorrect Investment_Account object reconstructed"); - end if; - - if Checking_Account /= TC_Checking_Account then - Report.Failed - ("Incorrect Checking_Account object reconstructed"); - end if; - - if Savings_Account /= TC_Savings_Account then - Report.Failed - ("Incorrect Savings_Account object reconstructed"); - end if; - - exception - when others => - Report.Failed - ("Exception raised during Data_Verification Block"); - end Data_Verification_Block; - - - -- To ensure that the tags of the values reconstructed by - -- Storage_IO were properly preserved, object tag values following - -- object reconstruction are compared with tag values of objects - -- stored prior to processing. - - Tag_Verification_Block: - begin - - if TC_Account_Type_Tag.all /= - Ada.Tags.External_Tag(Account_Type'Class(Account)'Tag) - then - Report.Failed("Incorrect Account tag"); - end if; - - if TC_Cash_Account_Type_Tag.all /= - Ada.Tags.External_Tag( - Cash_Account_Type'Class(Cash_Account)'Tag) - then - Report.Failed("Incorrect Cash_Account tag"); - end if; - - if TC_Investment_Account_Type_Tag.all /= - Ada.Tags.External_Tag( - Investment_Account_Type'Class(Investment_Account)'Tag) - then - Report.Failed("Incorrect Investment_Account tag"); - end if; - - if TC_Checking_Account_Type_Tag.all /= - Ada.Tags.External_Tag( - Checking_Account_Type'Class(Checking_Account)'Tag) - then - Report.Failed("Incorrect Checking_Account tag"); - end if; - - if TC_Savings_Account_Type_Tag.all /= - Ada.Tags.External_Tag( - Savings_Account_Type'Class(Savings_Account)'Tag) - then - Report.Failed("Incorrect Savings_Account tag"); - end if; - - exception - when others => - Report.Failed ("Exception raised during tag evaluation"); - end Tag_Verification_Block; - - exception - when others => Report.Failed ("Exception in Read_Data"); - end Read_Data; - - begin -- Test_Block - - -- Enter the data into the appropriate files. - Buffer_Data; - - -- Reconstruct the data from files, and verify the results. - Read_Data; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXA9002; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a deleted file mode 100644 index 6c2af987009..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a +++ /dev/null @@ -1,279 +0,0 @@ --- CXAA001.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 Line_Length and Page_Length maximums for a Text_IO --- file of mode Append_File are initially zero (unbounded) after a --- Create, Open, or Reset, and that these values can be modified using --- the procedures Set_Line_Length and Set_Page_Length. --- Check that setting the Line_Length and Page_Length attributes to zero --- results in an unbounded Text_IO file. --- Check that setting the line length when in Append_Mode doesn't --- change the length of lines previously written to the Text_IO file. --- --- TEST DESCRIPTION: --- This test attempts to simulate a possible text processing environment. --- String values, from a number of different string types, are written to --- a Text_IO file. Prior to the writing of each, the line length is set --- to the particular length of the data being written. In addition, the --- default line and page lengths are checked, to determine whether they --- are unbounded (length = 0) following a create, reset, or open of a --- Text_IO file with mode Append_File. --- --- APPLICABILITY CRITERIA: --- This test is applicable only to implementations that support text --- files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA001 is - use Ada; - Data_File : Text_IO.File_Type; - Data_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAA001" ); - Incomplete : exception; -begin - - Report.Test ("CXAA001","Check that the Line_Length and Page_Length " & - "maximums for a Text_IO file of mode Append_File " & - "are initially zero (unbounded) after a Create, " & - "Open, or Reset, and that these values can be " & - "modified using the procedures Set_Line_Length " & - "and Set_Page_Length"); - - Test_for_Text_IO_Support: - begin - - -- An implementation that does not support Text_IO in a particular - -- environment will raise Use_Error on calls to various - -- Text_IO operations. This block statement encloses a call to - -- Create, which should raise an exception in a non-supportive - -- environment. This exception will be handled to produce a - -- Not_Applicable result. - - Text_IO.Create (File => Data_File, - Mode => Text_IO.Append_File, - Name => Data_Filename); - - exception - - when Text_IO.Use_Error | Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Append_File for Text_IO" ); - raise Incomplete; - - end Test_for_Text_IO_Support; - - Operational_Test_Block: - declare - - subtype Confidential_Data_Type is string (1 .. 10); - subtype Secret_Data_Type is string (1 .. 20); - subtype Top_Secret_Data_Type is string (1 .. 30); - - Zero : constant Text_IO.Count := 0; - Confidential_Data_Size : constant Text_IO.Count := 10; - Secret_Data_Size : constant Text_IO.Count := 20; - Top_Secret_Data_Size : constant Text_IO.Count := 30; - - -- The following generic procedure is designed to simulate a text - -- processing environment where line and page sizes are set and - -- verified prior to the writing of data to a file. - - generic - Data_Size : Text_IO.Count; - procedure Write_Data_To_File (Data_Item : in String); - - procedure Write_Data_To_File (Data_Item : in String) is - use Text_IO; -- Used to provide visibility to the "/=" operator. - begin - if (Text_IO.Line_Length (Data_File) /= Zero) then -- Check default - Report.Failed("Line not of unbounded length"); -- line length, - elsif (Text_IO.Page_Length (Data_File) /= Zero) then -- default - Report.Failed ("Page not of unbounded length"); -- page length. - end if; - - Text_IO.Set_Line_Length (File => Data_File, -- Set the line - To => Data_Size); -- length. - Text_IO.Set_Page_Length (File => Data_File, -- Set the page - To => Data_Size); -- length. - -- Verify the lengths set. - if (Integer(Text_IO.Line_Length (Data_File)) /= - Report.Ident_Int(Integer(Data_Size))) then - Report.Failed ("Line length not set to appropriate length"); - elsif (Integer(Text_IO.Page_Length (Data_File)) /= - Report.Ident_Int(Integer(Data_Size))) then - Report.Failed ("Page length not set to appropriate length"); - end if; - - Text_IO.Put_Line (File => Data_File, -- Write data to - Item => Data_Item); -- file. - - end Write_Data_To_File; - - -- Instantiation for the three data types/sizes. - - procedure Write_Confidential_Data is - new Write_Data_To_File (Data_Size => Confidential_Data_Size); - - procedure Write_Secret_Data is - new Write_Data_To_File (Data_Size => Secret_Data_Size); - - procedure Write_Top_Secret_Data is - new Write_Data_To_File (Data_Size => Top_Secret_Data_Size); - - Confidential_Item : Confidential_Data_Type := "Confidenti"; - Secret_Item : Secret_Data_Type := "Secret Data Values "; - Top_Secret_Item : Top_Secret_Data_Type := - "Extremely Top Secret Data "; - - begin - - -- The following call simulates processing occurring after the create - -- of a Text_IO file with mode Append_File. - - Write_Confidential_Data (Confidential_Item); - - -- The following call simulates processing occurring after the reset - -- of a Text_IO file with mode Append_File. - - Reset1: - begin - Text_IO.Reset (Data_File, Text_IO.Append_File); -- Reset to - -- Append_File mode. - exception - when Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Append_File not supported for Text_IO" ); - raise Incomplete; - end Reset1; - - Write_Secret_Data (Data_Item => Secret_Item); - - Text_IO.Close (Data_File); -- Close file. - - -- The following processing simulates processing occurring after the - -- opening of an existing file with mode Append_File. - - Text_IO.Open (Data_File, -- Open file in - Text_IO.Append_File, -- Append_File mode. - Data_Filename); - - Write_Top_Secret_Data (Top_Secret_Item); - - Test_Verification_Block: - declare - TC_String1, - TC_String2, - TC_String3 : String (1..80) := (others => ' '); - TC_Length1, - TC_Length2, - TC_Length3 : Natural := 0; - begin - - Reset2: - begin - Text_IO.Reset (Data_File, Text_IO.In_File); -- Reset for reading. - exception - when Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO" ); - raise Incomplete; - end Reset2; - - Text_IO.Get_Line (Data_File, TC_String1, TC_Length1); - Text_IO.Get_Line (Data_File, TC_String2, TC_Length2); - Text_IO.Get_Line (Data_File, TC_String3, TC_Length3); - - -- Verify that the line lengths of each line were accurate. - -- Note: Each data line was written to the file after the - -- particular line length had been set (to the data length). - - if not ((TC_Length1 = Natural(Confidential_Data_Size)) and - (TC_Length2 = Natural(Secret_Data_Size)) and - (TC_Length3 = Natural(Top_Secret_Data_Size))) then - Report.Failed ("Inaccurate line lengths read from file"); - end if; - - -- Verify that the data read from the file are accurate. - - if (TC_String1(1..TC_Length1) /= Confidential_Item) or else - (TC_String2(1..TC_Length2) /= Secret_Item) or else - (TC_String3(1..TC_Length3) /= Top_Secret_Item) then - Report.Failed ("Corrupted data items read from file"); - end if; - - exception - - when Incomplete => - raise; - - when others => - Report.Failed ("Error raised during data verification"); - - end Test_Verification_Block; - - exception - - when Incomplete => - raise; - - when others => - Report.Failed ("Exception raised during Text_IO processing"); - - end Operational_Test_Block; - - Deletion: - begin - -- Check that the file is open prior to deleting it. - if Text_IO.Is_Open(Data_File) then - Text_IO.Delete(Data_File); - else - Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename); - Text_IO.Delete(Data_File); - end if; - exception - when others => - Report.Failed - ( "Delete not properly implemented for Text_IO" ); - end Deletion; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a deleted file mode 100644 index 953d33f1d44..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a +++ /dev/null @@ -1,257 +0,0 @@ --- CXAA002.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 procedures New_Page, Set_Line, Set_Col, and New_Line --- subprograms perform properly on a text file created with mode --- Append_File. --- Check that the attributes Page, Line, and Column are all set to 1 --- following the creation of a text file with mode Append_File. --- Check that the functions Page, Line, and Col perform properly on a --- text file created with mode Append_File. --- Check that the procedures Put and Put_Line perform properly on text --- files created with mode Append_File. --- Check that the procedure Set_Line sets the current line number to --- the value specified by the parameter "To" for text files created with --- mode Append_File. --- Check that the procedure Set_Col sets the current column number to --- the value specified by the parameter "To" for text files created with --- mode Append_File. --- --- TEST DESCRIPTION: --- This test is designed to simulate the text processing that could --- occur with files that have been created in Append_File mode. Various --- calls to Text_IO formatting subprograms are called to properly --- position text appended to a document. The text content and position --- are subsequently verified for accuracy. --- --- APPLICABILITY CRITERIA: --- This test is applicable only to implementations that support text --- files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations - ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA002 is - use Ada; - Data_File : Text_IO.File_Type; - Data_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAA002" ); - Incomplete : exception; -begin - - Report.Test ("CXAA002", "Check that page, line, and column formatting " & - "subprograms perform properly on text files " & - "created with mode Append_File"); - - Test_for_Text_IO_Support: - begin - - -- An implementation that does not support Text_IO in a particular - -- environment will raise Use_Error on calls to various - -- Text_IO operations. This block statement encloses a call to - -- Create, which should raise the exception in a non-supportive - -- environment. This exception will be handled to produce a - -- Not_Applicable result. - - Text_IO.Create (File => Data_File, - Mode => Text_IO.Append_File, - Name => Data_Filename); - - exception - - when Text_IO.Use_Error | Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Append_File for Text_IO" ); - raise Incomplete; - - end Test_for_Text_IO_Support; - - Operational_Test_Block: - declare - Default_Position : constant Text_IO.Positive_Count := 1; - Section_Header : constant String := "VII. "; - Appendix_Title : constant String := "Appendix A"; - Appendix_Content : constant String := "TBD"; - - -- The following procedure simulates the addition of an Appendix page - -- to an existing text file. - procedure Position_Appendix_Text is - use Text_IO; -- To provide visibility to the "/=" operator. - begin - - -- Test control code. - -- Verify initial page, line, column number. - if "/="(Text_IO.Page (Data_File), Default_Position) then - Report.Failed ("Incorrect default page number"); - end if; - if Text_IO.Line (Data_File) /= Default_Position then - Report.Failed ("Incorrect default line number"); - end if; - if "/="(Text_IO.Col (Data_File), Default_Position) then - Report.Failed ("Incorrect default column number"); - end if; - - -- Simulated usage code. - -- Set new page/line positions. - Text_IO.Put_Line - (Data_File, "Add some optional data to the file here"); - Text_IO.New_Page (Data_File); - Text_IO.New_Line (File => Data_File, Spacing => 2); - - -- Test control code. - if Integer(Text_IO.Page (Data_File)) /= Report.Ident_Int(2) or else - Integer(Text_IO.Line (Data_File)) /= Report.Ident_Int(3) then - Report.Failed ("Incorrect results from page/line positioning"); - end if; - - -- Simulated usage code. - Text_IO.Put (Data_File, Section_Header); -- Position title - Text_IO.Put_Line (Data_File, Appendix_Title); -- of Appendix. - - Text_IO.Set_Line (File => Data_File, To => 5); -- Set new - Text_IO.Set_Col (File => Data_File, To => 8); -- position. - - -- Test control code. - if (Integer(Text_IO.Line (Data_File)) /= Report.Ident_Int(5)) or - (Integer(Text_IO.Col (Data_File)) /= Report.Ident_Int(8)) then - Report.Failed ("Incorrect results from line/column positioning"); - end if; - - -- Simulated usage code. -- Position - Text_IO.Put_Line (Data_File, Appendix_Content); -- content of - -- Appendix. - end Position_Appendix_Text; - - begin - - -- This code section simulates a scenario that could occur in a - -- text processing environment: - -- A document is created/modified/edited Then... - -- Text is to be appended to the document. - -- A procedure is called to perform that operation. - -- The position on the appended page is set, verified, and text is - -- appended to the existing file. - -- - -- Note: The text file has been originally created in Append_File - -- mode, and has not been closed prior to this processing. - - Position_Appendix_Text; - - Test_Verification_Block: - declare - TC_Page, - TC_Line, - TC_Column : Text_IO.Positive_Count; - TC_Position : Natural := 0; - Blanks : constant String := " "; - TC_String : String (1 .. 17) := Blanks; - begin - - Reset1: - begin - Text_IO.Reset (Data_File, Text_IO.In_File); - exception - when Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO" ); - raise Incomplete; - end Reset1; - - Text_IO.Skip_Page (Data_File); - -- Loop to the third line - for I in 1 .. 3 loop -- and read the contents. - Text_IO.Get_Line (Data_File, TC_String, TC_Position); - end loop; - - if (TC_Position /= 16) or else -- Verify the title line. - (TC_String (1..4) /= "VII.") or else - (TC_String (3..16) /= ("I. " & Appendix_Title)) then - Report.Failed ("Incorrect positioning of title line"); - end if; - - TC_String := Blanks; -- Clear string. - -- Loop to the fifth line - for I in 4 .. 5 loop -- and read the contents. - Text_IO.Get_Line (Data_File, TC_String, TC_Position); - end loop; - - if (TC_Position /= 10) or -- Verify the contents. - (TC_String (8..10) /= Appendix_Content) then - Report.Failed ("Incorrect positioning of contents line"); - end if; - - exception - - when Incomplete => - raise; - - when others => - Report.Failed ("Error raised during data verification"); - - end Test_Verification_Block; - - exception - - when Incomplete => - raise; - - when others => - Report.Failed ("Exception raised during Text_IO processing"); - - end Operational_Test_Block; - - Deletion: - begin - -- Delete the external file. - if Text_IO.Is_Open(Data_File) then - Text_IO.Delete(Data_File); - else - Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename); - Text_IO.Delete(Data_File); - end if; - exception - when others => - Report.Failed - ( "Delete not properly implemented for Text_IO" ); - end Deletion; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA002; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a deleted file mode 100644 index c9580dfb343..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a +++ /dev/null @@ -1,293 +0,0 @@ --- CXAA003.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 procedures New_Page, Set_Line, Set_Col, and New_Line --- subprograms perform properly on a text file reset (from Out_File) --- with mode Append_File. --- Check that the attributes Page, Line, and Column are all set to 1 --- following the reset of a text file with mode Append_File. --- Check that the functions Page, Line, and Col perform properly on a --- text file reset with mode Append_File. --- Check that the procedures Put and Put_Line perform properly on text --- files reset with mode Append_File. --- Check that the procedure Set_Line sets the current line number to --- the value specified by the parameter "To" for text files reset with --- mode Append_File. Check that Set_Line has no effect if the specified --- line equals the current line. --- Check that the procedure Set_Col sets the current column number to --- the value specified by the parameter "To" for text files reset with --- mode Append_File. --- --- TEST DESCRIPTION: --- This test is designed to simulate the text processing that could --- occur with files that have been created in Out_File mode, --- and then reset to Append_File mode. --- Various calls to Text_IO formatting subprograms are called to properly --- position text appended to a document. The text content and position --- are subsequently verified for accuracy. --- --- APPLICABILITY CRITERIA: --- This test is applicable only to implementations that support text --- files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 24 Feb 97 PWB.CTA Allowed for non-support of some IO operations. ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA003 is - use Ada; - Data_File : Text_IO.File_Type; - Data_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAA003" ); - Incomplete : exception; - -begin - - Report.Test ("CXAA003", "Check that page, line, and column formatting " & - "subprograms perform properly on text files " & - "reset with mode Append_File"); - - Test_for_Text_IO_Support: - begin - - -- An implementation that does not support Text_IO in a particular - -- environment will raise Use_Error on calls to various - -- Text_IO operations. This block statement encloses a call to - -- Create, which should raise the exception in a non-supportive - -- environment. This exception will be handled to produce a - -- Not_Applicable result. - - Text_IO.Create (File => Data_File, - Mode => Text_IO.Out_File, - Name => Data_Filename); - exception - when Text_IO.Use_Error | Text_IO.Name_Error => - Report.Not_Applicable - ( "Text files not supported - Create as Out_File" ); - raise Incomplete; - end Test_for_Text_IO_Support; - - Operational_Test_Block: - declare - - Default_Position : constant Text_IO.Positive_Count := 1; - - Section_Header : constant String := "IX. "; - Glossary_Title : constant String := "GLOSSARY"; - Glossary_Content : constant String := "TBD"; - - -- The following procedure simulates the addition of a Glossary page - -- to an existing text file that has been reset with mode - -- Append_File. - - procedure Position_Glossary_Text - (The_File : in out Text_IO.File_Type) is - use Text_IO; -- To provide visibility to the "/=" operator. - begin - - -- Test control code. - -- Verify initial page value. - if (Text_IO.Page (The_File) /= Default_Position) then - Report.Failed ("Incorrect default page number"); - end if; - -- Verify initial line number. - if (Text_IO.Line (The_File) /= Default_Position) then - Report.Failed ("Incorrect default line number"); - end if; - -- Verify initial column number. - if (Text_IO.Col (The_File) /= Default_Position) then - Report.Failed ("Incorrect default column number"); - end if; - -- Simulated usage code. Set new page/line positions. - Text_IO.New_Page (The_File); - Text_IO.New_Page (The_File); - Text_IO.New_Line (File => The_File, Spacing => 1); - - -- Test control code. - if (Integer(Text_IO.Page(The_File)) /= - Report.Ident_Int(3)) or else - (Integer(Text_IO.Line (The_File)) /= - Report.Ident_Int(2)) then - Report.Failed ("Incorrect results from page/line positioning"); - end if; - - -- Simulated usage code. Position title of Glossary. - Text_IO.Put (The_File, Section_Header); - Text_IO.Put_Line (The_File, Glossary_Title); - -- Set line to the current line. - Text_IO.Set_Line (File => The_File, To => 3); - - -- Test control code. - if (Integer(Text_IO.Page (The_File)) /= Report.Ident_Int(3)) or - (Integer(Text_IO.Line (The_File)) /= Report.Ident_Int(3)) or - (Integer(Text_IO.Col (The_File)) /= Report.Ident_Int(1)) then - Report.Failed ("Set_Line failed for current line"); - end if; - - -- Simulated usage code. - Text_IO.Set_Line (File => The_File, To => 4); -- Set new - Text_IO.Set_Col (File => The_File, To => 10); -- position. - - -- Test control code. - if (Integer(Text_IO.Line (The_File)) /= Report.Ident_Int(4)) or - (Integer(Text_IO.Col (The_File)) /= Report.Ident_Int(10)) then - Report.Failed - ("Incorrect results from line/column positioning"); - end if; - - -- Simulated usage code. -- Position - Text_IO.Put_Line (The_File, Glossary_Content); -- content of - -- Glossary. - end Position_Glossary_Text; - - - begin - - -- In the scenario, data is added to the file here. - Text_IO.Put_Line (File => Data_File, Item => "Some optional data"); - - -- This code section simulates a scenario that could occur in a - -- text processing environment. Text is to be appended to an - -- existing document: - -- The file is reset to append mode. - -- A procedure is called to perform the positioning and placement - -- of text. - -- The position on the appended page is set, verified, and text is - -- placed in the file. - -- - -- Note: The text file has been originally created in Out_File - -- mode, and has subsequently been reset to Append_File mode. - - Reset1: - begin - -- Reset has effect of calling New_Page. - Text_IO.Reset (Data_File, Text_IO.Append_File); - exception - when Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Append_File not supported for Text_IO" ); - raise Incomplete; - end Reset1; - - Position_Glossary_Text (The_File => Data_File); - - Test_Verification_Block: - declare - TC_Page, TC_Line, TC_Column : Text_IO.Positive_Count; - TC_Position : Natural := 0; - Blanks : constant String := - " "; - TC_String : String (1 .. 15) := Blanks; - begin - Reset2: - begin - Text_IO.Reset (Data_File, Text_IO.In_File); - exception - when Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO" ); - raise Incomplete; - end Reset2; - - Text_IO.Skip_Page (Data_File); - Text_IO.Skip_Page (Data_File); - - -- If the Reset to Append_File mode actually put a page terminator - -- on the file, as allowed (but not required) by RM A.10.2(4), then - -- we are now on page 3, an empty page. We'll need to skip one more. - - if Text_IO.End_Of_Page (Data_File) then - Text_IO.Skip_Page (Data_File); - end if; - - -- Now we're on the Glossary page. - - -- Loop to the second line - for I in 1 .. 2 loop -- and read the contents. - Text_IO.Get_Line (Data_File, TC_String, TC_Position); - end loop; - if (TC_Position /= 13) or else -- Verify the title line. - (TC_String (1..2) /= "IX") or else - (TC_String (3..13) /= (". " & Glossary_Title)) then - Report.Failed ("Incorrect positioning of title line"); - end if; - - TC_String := Blanks; -- Clear string. - -- Loop to the fourth line - for I in 3 .. 4 loop -- and read the contents. - Text_IO.Get_Line (Data_File, TC_String, TC_Position); - end loop; - - if (TC_Position /= 12) or -- Verify the contents. - (TC_String (8..12) /= " " & Glossary_Content) then - Report.Failed ("Incorrect positioning of contents line"); - end if; - - exception - when Incomplete => - raise; - when others => - Report.Failed ("Error raised during data verification"); - - end Test_Verification_Block; - - exception - when Incomplete => - raise; - when others => - Report.Failed ("Exception raised during Text_IO processing"); - - end Operational_Test_Block; - - Final_Block: - begin - -- Delete the external file. - if Text_IO.Is_Open (Data_File) then - Text_IO.Delete (Data_File); - else - Text_IO.Open (Data_File, Text_IO.In_File, Data_Filename); - Text_IO.Delete (Data_File); - end if; - exception - when others => - Report.Failed ( "Delete not properly implemented for Text_IO" ); - end Final_Block; - - Report.Result; - - exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA003; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a deleted file mode 100644 index f3ea17ebad3..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a +++ /dev/null @@ -1,260 +0,0 @@ --- CXAA004.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 procedures New_Page, Set_Line, Set_Col, and New_Line --- perform properly on a text file opened with mode Append_File. --- Check that the attributes Page, Line, and Column are all set to 1 --- following the opening of a text file with mode Append_File. --- Check that the functions Page, Line, and Col perform properly on a --- text file opened with mode Append_File. --- Check that the procedures Put and Put_Line perform properly on text --- files opened with mode Append_File. --- Check that the procedure Set_Line sets the current line number to --- the value specified by the parameter "To" for text files opened with --- mode Append_File. --- Check that the procedure Set_Col sets the current column number to --- the value specified by the parameter "To" for text files reset with --- mode Append_File. --- --- TEST DESCRIPTION: --- This test is designed to simulate the text processing that could --- occur with files that have been created in Out_File mode, --- and then reset to Append_File mode. --- Various calls to Text_IO formatting subprograms are called to properly --- position text appended to a document. The text content and position --- are subsequently verified for accuracy. --- --- APPLICABILITY CRITERIA: --- This test is applicable only to implementations that support text --- files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 24 Feb 97 PWB.CTA Allowed for non-support of some IO operations. ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA004 is - use Ada; - Data_File : Text_IO.File_Type; - Data_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAA004" ); - Incomplete : exception; - -begin - - Report.Test ("CXAA004", "Check that page, line, and column formatting " & - "subprograms perform properly on text files " & - "opened with mode Append_File"); - - Test_for_Text_IO_Support: - begin - - -- An implementation that does not support Text_IO in a particular - -- environment will raise Use_Error on calls to various - -- Text_IO operations. This block statement encloses a call to - -- Create, which should raise the exception in a non-supportive - -- environment. This exception will be handled to produce a - -- Not_Applicable result. - - Text_IO.Create (File => Data_File, - Mode => Text_IO.Out_File, - Name => Data_Filename); - - exception - when Text_IO.Use_Error | Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create for Text_IO" ); - raise Incomplete; - end Test_for_Text_IO_Support; - - Operational_Test_Block: - declare - use Text_IO; -- To provide visibility to the "/=" operator. - - Default_Position : constant Text_IO.Positive_Count := 1; - - Section_Header : constant String := "X. "; - Reference_Title : constant String := "REFERENCES"; - Reference_Content : constant String := "Available Upon Request"; - - begin - - -- Some amount of text processing would occur here in the scenario - -- following file creation, prior to file closure. - Text_IO.Put_Line (File => Data_File, Item => "Some optional data"); - - -- Close has the effect of a call to New_Page (adding a page - -- terminator). - Text_IO.Close (Data_File); - - -- This code section simulates a scenario that could occur in a - -- text processing environment: - -- Certain text is to be appended to a document. - -- The file is opened in Append_File mode. - -- The position on the appended page is set, verified, and text - -- is placed in the file. - -- - -- Note: The text file has been originally created in Out_File - -- mode, has been subsequently closed and is now being reopened in - -- Append_File mode for further processing. - - Text_IO.Open (Data_File, Text_IO.Append_File, Data_Filename); - - -- Test control code. - if (Text_IO.Page(Data_File) /= Default_Position) then -- Verify init. - Report.Failed ("Incorrect default page number"); -- page value. - end if; - if (Text_IO.Line(Data_File) /= Default_Position) then -- Verify init. - Report.Failed ("Incorrect default line number"); -- line number. - end if; - if (Text_IO.Col (Data_File) /= Default_Position) then -- Verify init. - Report.Failed ("Incorrect default column number"); -- column no. - end if; - - -- Simulated usage code. - Text_IO.New_Page (Data_File); -- Set new page/ - Text_IO.New_Line (File => Data_File, Spacing => 2); -- line pos. - Text_IO.Put (Data_File, Section_Header); -- Position - Text_IO.Put_Line (Data_File, Reference_Title); -- title. - - -- Test control code. -- Verify new - if (Integer(Text_IO.Page (Data_File)) /= -- page and - Report.Ident_Int(2)) or else -- line. - (Integer(Text_IO.Line (Data_File)) /= - Report.Ident_Int(4)) then - Report.Failed ("Incorrect results from page/line positioning"); - end if; - - -- Simulated usage code. - Text_IO.Set_Line (File => Data_File, To => 8); -- Set new - Text_IO.Set_Col (File => Data_File, To => 30); -- position. - Text_IO.Put_Line (Data_File, Reference_Content); - - -- Test control code. - if (Integer(Text_IO.Line (Data_File)) /= - Report.Ident_Int(9)) or -- Verify new - (Integer(Text_IO.Col (Data_File)) /= -- position. - Report.Ident_Int(1)) then - Report.Failed ("Incorrect results from line/column positioning"); - end if; - - Test_Verification_Block: - declare - TC_Page, TC_Line, TC_Column : Text_IO.Positive_Count; - TC_Position : Natural := 0; - TC_String : String (1 .. 55) := (others => ' '); - begin - - Reset1: - begin - Text_IO.Reset (Data_File, Text_IO.In_File); - exception - when Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO" ); - raise Incomplete; - end Reset1; - - Text_IO.Skip_Page (Data_File); - - -- If the Reset to Append_File mode actually put a page terminator - -- in the file, as allowed (but not required) by RM A.10.2(4), then - -- we are now on page 2, an empty page. Therefore, we need to skip - -- one more page. - - if Text_IO.End_Of_Page (Data_File) then - Text_IO.Skip_Page (Data_File); - end if; - - -- Now we're on the reference page. - - -- Loop to the third line - for I in 1 .. 3 loop -- and read the contents. - Text_IO.Get_Line (Data_File, TC_String, TC_Position); - end loop; - - if (TC_Position /= 14) or else -- Verify the title line. - (TC_String (1..6) /= "X. RE") or else - (TC_String (2..14) /= (". " & Reference_Title)) then - Report.Failed ("Incorrect positioning of title line"); - end if; - -- Loop to the eighth line - for I in 4 .. 8 loop -- and read the contents. - Text_IO.Get_Line (Data_File, TC_String, TC_Position); - end loop; - - if (TC_Position /= 51) or -- Verify the contents. - (TC_String (30..51) /= "Available Upon Request") then - Report.Failed ("Incorrect positioning of contents line"); - end if; - - exception - - when Incomplete => - raise; - when others => - Report.Failed ("Error raised during data verification"); - - end Test_Verification_Block; - - exception - - when Incomplete => - raise; - when others => - Report.Failed ("Exception raised during Text_IO processing"); - - end Operational_Test_Block; - - Final_Block: - begin - -- Delete the external file. - if Text_IO.Is_Open (Data_File) then - Text_IO.Delete (Data_File); - else - Text_IO.Open (Data_File, Text_IO.In_File, Data_Filename); - Text_IO.Delete (Data_File); - end if; - exception - when others => - Report.Failed ( "Delete not properly implemented - Text_IO" ); - end Final_Block; - - Report.Result; - -exception - - when Incomplete => - Report.Result; - when others => - Report.Failed ("Unexpected exception"); - Report.Result; - -end CXAA004; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a deleted file mode 100644 index 7b2a0bc39d3..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a +++ /dev/null @@ -1,292 +0,0 @@ --- CXAA005.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 procedure Put, when called with string parameters, does --- not update the line number of a text file of mode Append_File, when --- the line length is unbounded (i.e., only the column number is --- updated). --- Check that a call to the procedure Put with a null string argument --- has no measurable effect on a text file of mode Append_File. --- --- TEST DESCRIPTION: --- This test is designed to ensure that when a string is appended to an --- unbounded text file, it is placed following the last element currently --- in the file. For an unbounded text file written with Put procedures --- only (not Put_Line), the line number should not be incremented by --- subsequent calls to Put in Append_File mode. Only the column number --- should be incremented based on the length of the string parameter --- placed in the file. If a call to Put with a null string argument is --- made, no change to the line or column number should occur, and no --- element(s) should be added to the file, so that there would be no --- measurable change to the file. --- --- APPLICABILITY CRITERIA: --- This test is applicable to all implementations that support Text_IO --- processing and external files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 24 Feb 97 CTA.PWB Allowed for non-support of some IO operations. ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA005 is - An_Unbounded_File : Ada.Text_IO.File_Type; - Unbounded_File_Name : constant String := - Report.Legal_File_Name ( Nam => "CXAA005" ); - Incomplete : exception; - -begin - - Report.Test ("CXAA005", "Check that the procedure Put does not " & - "increment line numbers when used with " & - "unbounded text files of mode Append_File"); - - Test_for_Text_IO_Support: - begin - - -- An application creates a text file in mode Out_File, with the intention - -- of entering string data packets into the file as appropriate. In the - -- event that the particular environment where the application is running - -- does not support Text_IO, Use_Error will be raised on calls to Text_IO - -- operations. - -- This exception will be handled to produce a Not_Applicable result. - - Ada.Text_IO.Create (File => An_Unbounded_File, - Mode => Ada.Text_IO.Out_File, - Name => Unbounded_File_Name); - exception - when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create for Text_IO" ); - raise Incomplete; - end Test_For_Text_IO_Support; - - Operational_Test_Block: - declare - subtype String_Sequence_Type is string (1 .. 20); - type String_Pointer_Type is access String_Sequence_Type; - --- During the course of processing, the application creates a variety of data --- pointers that refer to particular data items. The possibility of having --- null data values in this environment exists. - - Data_Packet_1 : String_Pointer_Type := - new String_Sequence_Type'("One Data Sequence 01"); - - Data_Packet_2 : String_Pointer_Type := - new String_Sequence_Type'("New Data Sequence 02"); - - Blank_Data_Packet : String_Pointer_Type := - new String_Sequence_Type'(" "); - - Null_Data_Packet : constant String := ""; - - TC_Line, TC_Col : Natural := 0; - - function TC_Mode_Selection (Selector : Integer) - return Ada.Text_IO.File_Mode is - begin - case Selector is - when 1 => return Ada.Text_IO.In_File; - when 2 => return Ada.Text_IO.Out_File; - when others => return Ada.Text_IO.Append_File; - end case; - end TC_Mode_Selection; - - begin - --- The application places some data into the file, using the Put subroutine. --- This operation can occur one-to-many times. - - Ada.Text_IO.Put (An_Unbounded_File, Data_Packet_1.all); - - -- Test control code. - if (Integer(Ada.Text_IO.Col (An_Unbounded_File)) /= - Report.Ident_Int(21)) or - (Integer(Ada.Text_IO.Line (An_Unbounded_File)) /= - Report.Ident_Int(1)) then - Report.Failed ("Incorrect Col position after 1st Put"); - end if; - --- The application may close the file at some point following its initial --- entry of data. - - Ada.Text_IO.Close (An_Unbounded_File); - --- At some later point in the processing, more data needs to be added to the --- file, so the application opens the file in Append_File mode. - - Ada.Text_IO.Open (File => An_Unbounded_File, - Mode => Ada.Text_IO.Append_File, - Name => Unbounded_File_Name); - - -- Test control code. - -- Store line/column number for later comparison. - TC_Line := Natural(Ada.Text_IO.Line(An_Unbounded_File)); - TC_Col := Natural(Ada.Text_IO.Col(An_Unbounded_File)); - --- Additional data items can then be appended to the file. - - Ada.Text_IO.Put (An_Unbounded_File, Blank_Data_Packet.all); - - -- Test control code. - if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /= - (TC_Col + 20)) or - (Natural(Ada.Text_IO.Line (An_Unbounded_File)) /= - TC_Line) then - Report.Failed ("Incorrect Col position after 2nd Put"); - end if; - --- In order to accommodate various scenarios, the application may have changed --- the mode of the data file to In_File in order to retrieve/verify some of --- the data contained there. However, with the need to place more data into --- the file, the file can be reset to Append_File mode. - - Reset1: - begin - Ada.Text_IO.Reset (An_Unbounded_File, - TC_Mode_Selection (Report.Ident_Int(3))); - exception - when Ada.Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Append_File not supported for Text_IO" ); - raise Incomplete; - end Reset1; - - -- Test control code. - -- Store line/column number for later comparison. - TC_Line := Natural(Ada.Text_IO.Line(An_Unbounded_File)); - TC_Col := Natural(Ada.Text_IO.Col(An_Unbounded_File)); - --- Additional data can then be appended to the file. On some occasions, an --- attempt to enter a null string value into the file may occur. This should --- have no effect on the file, leaving it unchanged. - - -- No measurable effect from Put with null string. - Ada.Text_IO.Put (An_Unbounded_File, Null_Data_Packet); - - -- Test control code. - -- There should be no change following the Put above. - if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /= - TC_Col) or - (Natural(Ada.Text_IO.Line (An_Unbounded_File)) /= - TC_Line) then - Report.Failed ("Incorrect Col position after 3rd Put"); - end if; - --- Additional data can be appended to the file. - - Ada.Text_IO.Put (An_Unbounded_File, Data_Packet_2.all); - - -- Test control code. - if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /= - (TC_Col + 20)) or - (Integer(Ada.Text_IO.Line (An_Unbounded_File)) /= - TC_Line) then - Report.Failed ("Incorrect Col position after 4th Put"); - end if; - - Test_Verification_Block: - declare - File_Data : String (1 .. 80); - TC_Width : Natural; - begin - --- The application has the capability to reset the file to In_File mode to --- verify some of the data that is contained there. - - Reset2: - begin - Ada.Text_IO.Reset (An_Unbounded_File, Ada.Text_IO.In_File); - exception - when Ada.Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported - Text_IO" ); - raise Incomplete; - end Reset2; - - Ada.Text_IO.Get_Line (An_Unbounded_File, - File_Data, - TC_Width); - - -- Test control code. - -- Since it is implementation defined whether a page - -- terminator separates preexisting text from new text - -- following an open in append mode (as occurred above), - -- verify only that the first data item written to the - -- file was not overwritten by any subsequent call to Put. - - if (File_Data (File_Data'First) /= 'O') or - (File_Data (20) /= '1') then - Report.Failed ("Data placed incorrectly in file"); - end if; - - exception - when Incomplete => - raise; - when others => - Report.Failed ("Error raised during data verification"); - end Test_Verification_Block; - - exception - when Incomplete => - raise; - when others => - Report.Failed ("Exception in Text_IO processing"); - end Operational_Test_Block; - - Final_Block: - begin - -- Delete the external file. - if Ada.Text_IO.Is_Open(An_Unbounded_File) then - Ada.Text_IO.Delete (An_Unbounded_File); - else - Ada.Text_IO.Open(An_Unbounded_File, - Ada.Text_IO.In_File, - Unbounded_File_Name); - Ada.Text_IO.Delete (An_Unbounded_File); - end if; - exception - when others => - Report.Failed - ( "Delete not properly implemented -- Text_IO" ); - end Final_Block; - - Report.Result; - -exception - - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA005; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a deleted file mode 100644 index 518d43b896e..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a +++ /dev/null @@ -1,285 +0,0 @@ --- CXAA006.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 for a bounded line length text file of mode Append_File, --- when the number of characters to be output exceeds the number of --- columns remaining on the current line, a call to Put will output --- characters of the string sufficient to fill the remaining columns of --- the line (up to line length), then output a line terminator, reset the --- column number, increment the line number, then output the balance of --- the item. --- --- Check that the procedure Put does not raise Layout_Error when the --- number of characters to be output exceeds the line length of a bounded --- text file of mode Append_File. --- --- TEST DESCRIPTION: --- This test demonstrates the situation where an application intends to --- output variable length string elements to a text file in the most --- efficient manner possible. This is the case in a typesetting --- environment where text is compressed and split between lines of a --- bounded length. --- --- The procedure Put will break string parameters placed in the file at --- the point of the line length. Two examples are demonstrated in this --- test, one being the case where only one column remains on a line, and --- the other being the case where a larger portion of the line remains --- unfilled, but still not sufficient to contain the entire output --- string. --- --- During the course of the test, the file is reset to Append_File mode, --- and the bounded line length is modified for different lines of the --- file. --- --- APPLICABILITY CRITERIA: --- This test is applicable to all implementations that support Text_IO --- processing and external files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA006 is - - A_Bounded_File : Ada.Text_IO.File_Type; - Bounded_File_Name : constant String := - Report.Legal_File_Name ( Nam => "CXAA006" ); - Incomplete : exception; - -begin - - Report.Test ("CXAA006", "Check that procedure Put will correctly " & - "output string items to a bounded line " & - "length text file of mode Append_File"); - - Test_for_Text_IO_Support: - begin - --- An application creates a text file in mode Append_File, with the intention --- of using the procedure Put to compress variable length string data into the --- file in the most efficient manner possible. - - Ada.Text_IO.Create (File => A_Bounded_File, - Mode => Ada.Text_IO.Append_File, - Name => Bounded_File_Name); - exception - when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create with Append_File for Text_IO" ); - raise Incomplete; - end Test_For_Text_IO_Support; - - Operational_Test_Block: - declare - Twelve_Characters : constant String := "12Characters"; - Nineteen_Characters : constant String := "Nineteen_Characters"; - TC_Line : Natural := 0; - - function TC_Mode_Selection (Selector : Integer) - return Ada.Text_IO.File_Mode is - begin - case Selector is - when 1 => return Ada.Text_IO.In_File; - when 2 => return Ada.Text_IO.Out_File; - when others => return Ada.Text_IO.Append_File; - end case; - end TC_Mode_Selection; - - begin - --- The application sets the line length of the file to be bound at 20. All --- lines in this file will be limited to that length. - - Ada.Text_IO.Set_Line_Length (A_Bounded_File, 20); - - Ada.Text_IO.Put (A_Bounded_File, Nineteen_Characters); - - -- Test control code. - if (Integer(Ada.Text_IO.Line (A_Bounded_File)) /= - Report.Ident_Int(1)) or - (Integer(Ada.Text_IO.Col (A_Bounded_File)) /= - Report.Ident_Int(20)) then - Report.Failed ("Incorrect position after 1st Put"); - end if; - --- The application finds that there is only one column available on the --- current line, so the next string item to be output must be broken at --- the appropriate place (following the first character). - - Ada.Text_IO.Put (File => A_Bounded_File, - Item => Twelve_Characters); - - -- Test control code. - if (Integer(Ada.Text_IO.Line (A_Bounded_File)) /= - Report.Ident_Int(2)) or - (Integer(Ada.Text_IO.Col (A_Bounded_File)) /= - Report.Ident_Int(12)) then - Report.Failed ("Incorrect position after 2nd Put"); - end if; - --- The application subsequently modifies the processing, resetting the file --- at this point to In_File mode in order to verify data that has been written --- to the file. Following this, the application resets the file to Append_File --- mode in order to continue the placement of data into the file, but modifies --- the original bounded line length for subsequent lines to be appended. - - -- Reset to Append mode; call outputs page terminator and - -- resets line length to Unbounded. - Reset1: - begin - Ada.Text_IO.Reset (A_Bounded_File, - TC_Mode_Selection (Report.Ident_Int(3))); - exception - when Ada.Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Append_File not supported for Text_IO" ); - raise Incomplete; - end Reset1; - - Ada.Text_IO.Set_Line_Length (A_Bounded_File, 15); - - -- Store line number for later comparison. - TC_Line := Natural(Ada.Text_IO.Line(A_Bounded_File)); - --- The application finds that fifteen columns are available on the current --- line but that the string item to be output exceeds this available space. --- It must be split at the end of the line, and the balance placed on the --- next file line. - - Ada.Text_IO.Put (File => A_Bounded_File, - Item => Nineteen_Characters); - - -- Test control code. - -- Positioned on new line at col 5. - if (Natural(Ada.Text_IO.Line (A_Bounded_File)) /= - (TC_Line + 1)) or - (Integer(Ada.Text_IO.Col (A_Bounded_File)) /= - Report.Ident_Int(5)) then - Report.Failed ("Incorrect position after 3rd Put"); - end if; - - - Test_Verification_Block: - declare - First_String : String (1 .. 80); - Second_String : String (1 .. 80); - Third_String : String (1 .. 80); - Fourth_String : String (1 .. 80); - TC_Width1 : Natural; - TC_Width2 : Natural; - TC_Width3 : Natural; - TC_Width4 : Natural; - begin - --- The application has the capability to reset the file to In_File mode to --- verify some or all of the data that is contained there. - - Reset2: - begin - Ada.Text_IO.Reset (A_Bounded_File, Ada.Text_IO.In_File); - exception - when others => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO" ); - raise Incomplete; - end Reset2; - - Ada.Text_IO.Get_Line - (A_Bounded_File, First_String, TC_Width1); - Ada.Text_IO.Get_Line - (A_Bounded_File, Second_String, TC_Width2); - Ada.Text_IO.Get_Line - (A_Bounded_File, Third_String, TC_Width3); - Ada.Text_IO.Get_Line - (A_Bounded_File, Fourth_String, TC_Width4); - - -- Test control code. - if (First_String (1..TC_Width1) /= Nineteen_Characters & "1") or - (Second_String (1..TC_Width2) /= "2Characters") or - (Third_String (1..TC_Width3) /= - Nineteen_Characters(1..15)) or - (Fourth_String (1..TC_Width4) /= "ters") - then - Report.Failed ("Data placed incorrectly in file"); - end if; - - exception - - when Incomplete => - raise; - - when Ada.Text_IO.End_Error => - Report.Failed ("Incorrect number of lines in file"); - - when others => - Report.Failed ("Error raised during data verification"); - - end Test_Verification_Block; - - exception - - when Ada.Text_IO.Layout_Error => - Report.Failed ("Layout Error raised when positioning text"); - - when others => - Report.Failed ("Exception in Text_IO processing"); - - end Operational_Test_Block; - - Final_Block: - begin - -- Delete the external file. - if Ada.Text_IO.Is_Open(A_Bounded_File) then - Ada.Text_IO.Delete (A_Bounded_File); - else - Ada.Text_IO.Open (A_Bounded_File, - Ada.Text_IO.In_File, - Bounded_File_Name); - Ada.Text_IO.Delete (A_Bounded_File); - end if; - - exception - when others => - Report.Failed - ( "Delete not properly implemented for Text_IO" ); - end Final_Block; - - Report.Result; - -exception - - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA006; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a deleted file mode 100644 index fe79c2d7a86..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a +++ /dev/null @@ -1,263 +0,0 @@ --- CXAA007.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 capabilities of Text_IO.Integer_IO perform correctly --- on files of Append_File mode, for instantiations with integer and --- user-defined subtypes. --- Check that the formatting parameters available in the package can --- be used and modified successfully in the storage and retrieval of --- data. --- --- TEST DESCRIPTION: --- This test simulates a receiving department inventory system. Data on --- items received is entered into an inventory database. This information --- consists of integer entry number, item number, and bar code. --- One item is placed into the inventory file immediately following file --- creation, subsequent items are entered following file opening in --- Append_File mode. Data items are validated by reading all data from --- the file and comparing against known values (those used to enter the --- data originally). --- --- This test verifies issues of create in Append_File mode, appending to --- a file previously appended to, opening in Append_File mode, resetting --- from Append_File mode to In_File mode, as well as a variety of Text_IO --- and Integer_IO predefined subprograms. --- --- APPLICABILITY CRITERIA: --- This test is applicable only to implementations that support text --- files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA007 is - use Ada; - - Inventory_File : Text_IO.File_Type; - Inventory_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAA007" ); - Incomplete : exception; - -begin - - Report.Test ("CXAA007", "Check that the capabilities of " & - "Text_IO.Integer_IO operate correctly for files " & - "with mode Append_File"); - - Test_for_Text_IO_Support: - begin - - -- An implementation that does not support Text_IO in a particular - -- environment will raise Use_Error on calls to various - -- Text_IO operations. This block statement encloses a call to - -- Create, which should raise the exception in a non-supportive - -- environment. This exception will be handled to produce a - -- Not_Applicable result. - - Text_IO.Create (File => Inventory_File, - Mode => Text_IO.Append_File, - Name => Inventory_Filename); - exception - when Text_IO.Use_Error | Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create with Append_File for Text_IO" ); - raise Incomplete; - end Test_for_Text_IO_Support; - - Operational_Test_Block: - declare - - Max_Entries_Per_Order : constant Natural := 4; - - type Bar_Code_Type is range 0 .. 127; -- Values to be stored as base - -- two numbers in file. - type Item_Type is record - Entry_Number : Natural := 0; - Item_Number : Integer := 0; - Bar_Code : Bar_Code_Type := 0; - end record; - - type Inventory_Type is - array (1 .. Max_Entries_Per_Order) of Item_Type; - - Inventory_List : Inventory_Type := ((1, 119, 87), -- Items received - (2, 206, 44), -- this order. - (3, -25, 126), - (4, -18, 31)); - - Daily_Order : constant := 1; - Entry_Field_Width : constant Natural := 1; - Item_Base : constant Natural := 16; - Items_Inventoried : Natural := 1; - Items_To_Inventory : Natural := 4; - - package Entry_IO is new Text_IO.Integer_IO (Natural); - package Item_IO is new Text_IO.Integer_IO (Integer); - package Bar_Code_IO is new Text_IO.Integer_IO (Bar_Code_Type); - - - -- The following procedure simulates the addition of inventory item - -- information into a data file. - - procedure Update_Inventory (The_Item : in Item_Type) is - Spacer : constant String := " "; - begin - -- Enter all the incoming data into the inventory file. - Entry_IO.Put (Inventory_File, The_Item.Entry_Number); - Text_IO.Put (Inventory_File, Spacer); - Item_IO.Put (Inventory_File, The_Item.Item_Number); - Text_IO.Put (Inventory_File, Spacer); - Bar_Code_IO.Put(File => Inventory_File, - Item => The_Item.Bar_Code, - Width => 13, - Base => 2); - Text_IO.New_Line(Inventory_File); - end Update_Inventory; - - - begin - - -- This code section simulates a receiving department maintaining a - -- data file containing information on items that have been ordered - -- and received. - -- - -- As new orders are received, the file is opened in Append_File - -- mode. - -- Data is taken from the inventory list and entered into the file, - -- in specific format. - -- Enter the order into the inventory file. This is item 1 in - -- the inventory list. - -- The data entry process can be repeated numerous times as required. - - Entry_IO.Put (Inventory_File, - Inventory_List(Daily_Order).Entry_Number); - Item_IO.Put (Inventory_File, - Inventory_List(Daily_Order).Item_Number); - Bar_Code_IO.Put (File => Inventory_File, - Item => Inventory_List(Daily_Order).Bar_Code); - Text_IO.New_Line (Inventory_File); - - Text_IO.Close (Inventory_File); - - - Entry_IO.Default_Width := Entry_Field_Width; -- Modify the default - -- width of Entry_IO. - Item_IO.Default_Base := Item_Base; -- Modify the default - -- number base of - -- Item_IO - Text_IO.Open (Inventory_File, - Text_IO.Append_File, -- Open in Append mode. - Inventory_Filename); - -- Enter items - while (Items_Inventoried < Items_To_Inventory) loop -- 2-4 into the - Items_Inventoried := Items_Inventoried + 1; -- inventory file. - Update_Inventory (The_Item => Inventory_List (Items_Inventoried)); - end loop; - - Test_Verification_Block: -- Read and check - declare -- all the data - TC_Entry : Natural; -- values that - TC_Item : Integer; -- have been - TC_Bar_Code : Bar_Code_Type; -- entered in the - TC_Item_Count : Natural := 0; -- data file. - begin - - Reset1: - begin - Text_IO.Reset (Inventory_File, Text_IO.In_File); -- Reset for - -- reading. - exception - when Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to mode In_File not supported for Text_IO" ); - raise Incomplete; - end Reset1; - - while not Text_IO.End_Of_File (Inventory_File) loop - Entry_IO.Get (Inventory_File, TC_Entry); - Item_IO.Get (Inventory_File, TC_Item); - Bar_Code_IO.Get (Inventory_File, TC_Bar_Code); - Text_IO.Skip_Line (Inventory_File); - TC_Item_Count := TC_Item_Count + 1; - - if (TC_Item /= Inventory_List(TC_Entry).Item_Number) or - (TC_Bar_Code /= Inventory_List(TC_Entry).Bar_Code) then - Report.Failed ("Error in integer data read from file"); - end if; - end loop; - - if (TC_Item_Count /= Max_Entries_Per_Order) then - Report.Failed ("Incorrect number of records read from file"); - end if; - - exception - when Incomplete => - raise; - when others => - Report.Failed ("Error raised during data verification"); - end Test_Verification_Block; - - exception - when Incomplete => - raise; - when others => - Report.Failed ("Exception in Text_IO.Integer_IO processing"); - end Operational_Test_Block; - - Final_Block: - begin - -- Delete the external file. - if Text_IO.Is_Open(Inventory_File) then - Text_IO.Delete (Inventory_File); - else - Text_IO.Open (Inventory_File, Text_IO.In_File, Inventory_Filename); - Text_IO.Delete (Inventory_File); - end if; - - exception - - when others => - Report.Failed ( "Delete not properly implemented for Text_IO" ); - - end Final_Block; - - Report.Result; - -exception - - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA007; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a deleted file mode 100644 index c21d07ea9ac..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a +++ /dev/null @@ -1,271 +0,0 @@ --- CXAA008.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 capabilities provided in instantiations of the --- Ada.Text_IO.Fixed_IO package operate correctly when the mode of --- the file is Append_File. Check that Fixed_IO procedures Put and Get --- properly transfer fixed point data to/from data files that are in --- Append_File mode. Check that the formatting parameters available in --- the package can be used and modified successfully in the appending and --- retrieval of data. --- --- TEST DESCRIPTION: --- This test simulates order processing, with data values being written --- to a file, in a specific format, using Fixed_IO. Validation is done --- on this process by reading the data values from the file, and --- comparing them for equality with the values originally written to --- the file. --- --- This test verifies issues of create in Append_File mode, appending to --- a file previously appended to, resetting to Append_File mode, --- resetting from Append_File mode to In_File mode, as well as a --- variety of Text_IO and Fixed_IO predefined subprograms. --- --- APPLICABILITY CRITERIA: --- This test is applicable only to implementations that support text --- files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA008 is - use Ada; - - Inventory_File : Text_IO.File_Type; - Inventory_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAA008" ); - Incomplete : exception; - -begin - - Report.Test ("CXAA008", "Check that the capabilities of " & - "Text_IO.Fixed_IO operate correctly for files " & - "with mode Append_File"); - - Test_for_Text_IO_Support: - begin - - -- An implementation that does not support Text_IO in a particular - -- environment will raise Use_Error on calls to various - -- Text_IO operations. This block statement encloses a call to - -- Create, which should raise the exception in a non-supportive - -- environment. This exception will be handled to produce a - -- Not_Applicable result. - - Text_IO.Create (File => Inventory_File, - Mode => Text_IO.Append_File, - Name => Inventory_Filename); - - exception - when Text_IO.Use_Error | Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create with Append_File for Text_IO" ); - raise Incomplete; - end Test_For_Text_IO_Support; - - Operational_Test_Block: - declare - - Daily_Orders_Received : constant Natural := 4; - - type Item_Type is delta 0.1 range 0.0 .. 5000.0; - type Cost_Type is delta 0.01 range 0.0 .. 10_000.0; - type Profit_Type is delta 0.01 range -100.0 .. 1000.0; - - type Product_Type is record - Item_Number : Item_Type := 0.0; - Unit_Cost : Cost_Type := 0.00; - Percent_Markup : Profit_Type := 0.00; - end record; - - type Inventory_Type is - array (1 .. Daily_Orders_Received) of Product_Type; - - Daily_Inventory : Inventory_Type := (( 1.0, 1.75, 50.00), - ( 155.0, 20.00, -5.50), - (3343.5, 2.50, 126.50), - (4986.0, 180.00, 31.75)); - - package Item_IO is new Text_IO.Fixed_IO (Item_Type); - package Cost_IO is new Text_IO.Fixed_IO (Cost_Type); - package Markup_IO is new Text_IO.Fixed_IO (Profit_Type); - - - function TC_Mode_Selection (Selector : Integer) - return Text_IO.File_Mode is - begin - case Selector is - when 1 => return Text_IO.In_File; - when 2 => return Text_IO.Out_File; - when others => return Text_IO.Append_File; - end case; - end TC_Mode_Selection; - - - -- The following function simulates the addition of inventory item - -- information into a data file. Boolean status of True is returned - -- if all of the data entry was successful, False otherwise. - - function Update_Inventory (The_List : Inventory_Type) - return Boolean is - begin - for I in 1 .. Daily_Orders_Received loop - Item_IO.Put (Inventory_File, The_List(I).Item_Number); - Cost_IO.Put (Inventory_File, The_List(I).Unit_Cost, 10, 4, 0); - Markup_IO.Put(File => Inventory_File, - Item => The_List(I).Percent_Markup, - Fore => 6, - Aft => 3, - Exp => 2); - Text_IO.New_Line (Inventory_File); - end loop; - return (True); -- Return a Status value. - exception - when others => return False; - end Update_Inventory; - - - begin - - -- This code section simulates a receiving department maintaining a - -- data file containing information on items that have been ordered - -- and received. - - -- Whenever items are received, the file is reset to Append_File - -- mode. Data is taken from an inventory list and entered into the - -- file, in specific format. - - Reset1: - begin -- Reset to - Text_IO.Reset (Inventory_File, -- Append mode. - TC_Mode_Selection (Report.Ident_Int(3))); - exception - when Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Append_File not supported for Text_IO" ); - end Reset1; - - -- Enter data. - if not Update_Inventory (The_List => Daily_Inventory) then - Report.Failed ("Exception occurred during inventory update"); - raise Incomplete; - end if; - - Test_Verification_Block: - declare - TC_Item : Item_Type; - TC_Cost : Cost_Type; - TC_Markup : Profit_Type; - TC_Item_Count : Natural := 0; - begin - - Reset2: - begin - Text_IO.Reset (Inventory_File, Text_IO.In_File); -- Reset for - -- reading. - exception - when Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO" ); - raise Incomplete; - end Reset2; - - while not Text_IO.End_Of_File (Inventory_File) loop - Item_IO.Get (Inventory_File, TC_Item); - Cost_IO.Get (Inventory_File, TC_Cost); - Markup_IO.Get (File => Inventory_File, - Item => TC_Markup, - Width => 0); - Text_IO.Skip_Line (Inventory_File); - TC_Item_Count := TC_Item_Count + 1; - - -- Verify all of the data fields read from the file. Compare - -- with the values that were originally entered into the file. - - if (TC_Item /= Daily_Inventory(TC_Item_Count).Item_Number) then - Report.Failed ("Error in Item_Number read from file"); - end if; - if (TC_Cost /= Daily_Inventory(TC_Item_Count).Unit_Cost) then - Report.Failed ("Error in Unit_Cost read from file"); - end if; - if not (TC_Markup = - Daily_Inventory(TC_Item_Count).Percent_Markup) then - Report.Failed ("Error in Percent_Markup read from file"); - end if; - - end loop; - - if (TC_Item_Count /= Daily_Orders_Received) then - Report.Failed ("Incorrect number of records read from file"); - end if; - - exception - when Incomplete => - raise; - when others => - Report.Failed ("Error raised during data verification"); - end Test_Verification_Block; - - exception - when Incomplete => - raise; - when others => - Report.Failed ("Exception in Text_IO.Fixed_IO processing"); - end Operational_Test_Block; - - Final_Block: - begin - -- Delete the external file. - if Text_IO.Is_Open (Inventory_File) then - Text_IO.Delete (Inventory_File); - else - Text_IO.Open (Inventory_File, Text_IO.In_File, Inventory_Filename); - Text_IO.Delete (Inventory_File); - end if; - - exception - - when others => - Report.Failed ( "Delete not properly implemented for Text_IO" ); - - end Final_Block; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA008; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a deleted file mode 100644 index d478060808a..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a +++ /dev/null @@ -1,290 +0,0 @@ --- CXAA009.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 capabilities provided in instantiations of the --- Ada.Text_IO.Float_IO package operate correctly when the mode of --- the file is Append_File. Check that Float_IO procedures Put and Get --- properly transfer floating point data to/from data files that are in --- Append_File mode. Check that the formatting parameters available in --- the package can be used and modified successfully in the appending and --- retrieval of data. --- --- TEST DESCRIPTION: --- This test is designed to simulate an environment where a data file --- that holds floating point information is created, written to, and --- closed. In the future, the file can be reopened in Append_File mode, --- additional data can be appended to it, and then closed. This process --- of Open/Append/Close can be repeated as necessary. All data written --- to the file is verified for accuracy when retrieved from the file. --- --- This test verifies issues of create in Append_File mode, appending to --- a file previously appended to, opening in Append_File mode, resetting --- from Append_File mode to In_File mode, as well as a variety of Text_IO --- and Float_IO predefined subprograms. --- --- APPLICABILITY CRITERIA: --- This test is applicable only to implementations that support text --- files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA009 is - - use Ada; - Loan_File : Text_IO.File_Type; - Loan_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAA009" ); - Incomplete : exception; - -begin - - Report.Test ("CXAA009", "Check that the capabilities of " & - "Text_IO.Float_IO operate correctly for files " & - "with mode Append_File"); - - Test_for_Text_IO_Support: - begin - - -- An implementation that does not support Text_IO in a particular - -- environment will raise Use_Error on calls to various - -- Text_IO operations. This block statement encloses a call to - -- Create, which should raise the exception in a non-supportive - -- environment. This exception will be handled to produce a - -- Not_Applicable result. - - Text_IO.Create (File => Loan_File, -- Create in - Mode => Text_IO.Out_File, -- Out_File mode. - Name => Loan_Filename); - - exception - - when Text_IO.Use_Error | Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Text_IO" ); - raise Incomplete; - - end Test_for_Text_IO_Support; - - Operational_Test_Block: - declare - Total_Loans_Outstanding : constant Natural := 3; - Transaction_Status : Boolean := False; - - type Account_Balance_Type is digits 6 range 0.0 .. 1.0E6; - type Loan_Balance_Type is digits 6; - type Interest_Rate_Type is digits 4 range 0.0 .. 30.00; - - type Loan_Info_Type is record - Account_Balance : Account_Balance_Type := 0.00; - Loan_Balance : Loan_Balance_Type := 0.00; - Loan_Interest_Rate : Interest_Rate_Type := 0.00; - end record; - - Home_Refinance_Loan : Loan_Info_Type := - (14_500.00, 135_000.00, 6.875); - Line_Of_Credit_Loan : Loan_Info_Type := - ( 5490.00, -3000.00, 13.75); - Small_Business_Loan : Loan_Info_Type := - (Account_Balance => 45_000.00, - Loan_Balance => 10_500.00, - Loan_Interest_Rate => 5.875); - - package Acct_IO is new Text_IO.Float_IO (Account_Balance_Type); - package Loan_IO is new Text_IO.Float_IO (Loan_Balance_Type); - package Rate_IO is new Text_IO.Float_IO (Interest_Rate_Type); - - - -- The following procedure performs the addition of loan information - -- into a data file. Boolean status of True is returned if all of - -- the data entry was successful, False otherwise. - -- This demonstrates use of Float_IO using a variety of data formats. - - procedure Update_Loan_Info (The_File : in out Text_IO.File_Type; - The_Loan : in Loan_Info_Type; - Status : out Boolean ) is - begin - Acct_IO.Put (The_File, The_Loan.Account_Balance); - Loan_IO.Put (The_File, The_Loan.Loan_Balance, 15, 2, 0); - Rate_IO.Put (File => The_File, - Item => The_Loan.Loan_Interest_Rate, - Fore => 6, - Aft => 3, - Exp => 0); - Text_IO.New_Line (The_File); - Status := True; - exception - when others => Status := False; - end Update_Loan_Info; - - - begin - - -- This code section simulates a bank maintaining a data file - -- containing information on loans that have been made. - -- The scenario: - -- The loan file was created in Out_File mode. - -- Some number of data records are added. - -- The file is closed. - -- The file is subsequently reopened in Append_File mode. - -- Data is appended to the file. - -- The file is closed. - -- Repeat the Open/Append/Close process as required. - -- Verify data in the file. - -- etc. - - Update_Loan_Info(Loan_File, Home_Refinance_Loan, Transaction_Status); - - if not Transaction_Status then - Report.Failed ("Failure in update of first loan data"); - end if; - - Text_IO.Close (Loan_File); - - -- When subsequent data items are to be added to the file, the file - -- is opened in Append_File mode. - - Text_IO.Open (Loan_File, -- Open with - Text_IO.Append_File, -- Append mode. - Loan_Filename); - - Update_Loan_Info(Loan_File, Line_Of_Credit_Loan, Transaction_Status); - - if not Transaction_Status then - Report.Failed("Failure in update of first loan data"); - end if; - - Text_IO.Close(Loan_File); - - -- To add additional data to the file, the file - -- is again opened in Append_File mode (appending to a file - -- previously appended to). - - Text_IO.Open (Loan_File, -- Open with - Text_IO.Append_File, -- Append mode. - Loan_Filename); - - Update_Loan_Info(Loan_File, Small_Business_Loan, Transaction_Status); - - if not Transaction_Status then - Report.Failed("Failure in update of first loan data"); - end if; - - Test_Verification_Block: - declare - type Ledger_Type is - array (1 .. Total_Loans_Outstanding) of Loan_Info_Type; - TC_Bank_Ledger : Ledger_Type; - TC_Item_Count : Natural := 0; - begin - - Reset1: - begin - Text_IO.Reset (Loan_File, Text_IO.In_File); -- Reset for - -- reading. - exception - when Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO" ); - raise Incomplete; - end Reset1; - - while not Text_IO.End_Of_File (Loan_File) loop - TC_Item_Count := TC_Item_Count + 1; - Acct_IO.Get (Loan_File, - TC_Bank_Ledger(TC_Item_Count).Account_Balance); - Loan_IO.Get (Loan_File, - TC_Bank_Ledger(TC_Item_Count).Loan_Balance, - 0); - Rate_IO.Get(File => Loan_File, - Item => - TC_Bank_Ledger(TC_Item_Count).Loan_Interest_Rate, - Width => 0); - Text_IO.Skip_Line(Loan_File); - - end loop; - - -- Verify all of the data fields read from the file. Compare - -- with the values that were originally entered into the file. - - if (TC_Bank_Ledger(1) /= Home_Refinance_Loan) or - (TC_Bank_Ledger(2) /= Line_Of_Credit_Loan) or - (TC_Bank_Ledger(3) /= Small_Business_Loan) then - Report.Failed("Error in data read from file"); - end if; - - if (TC_Item_Count /= Total_Loans_Outstanding) then - Report.Failed ("Incorrect number of records read from file"); - end if; - - exception - when Incomplete => - raise; - when others => - Report.Failed ("Error raised during data verification"); - end Test_Verification_Block; - - exception - when Incomplete => - raise; - when others => - Report.Failed ("Exception in Text_IO.Float_IO processing"); - end Operational_Test_Block; - - Final_Block: - begin - -- Delete the external file. - if Text_IO.Is_Open(Loan_File) then - Text_IO.Delete(Loan_File); - else - Text_IO.Open(Loan_File, Text_IO.In_File, Loan_Filename); - Text_IO.Delete(Loan_File); - end if; - - exception - - when Text_IO.Use_Error => - Report.Failed - ( "Delete not properly implemented for Text_IO" ); - - end Final_Block; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA009; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a deleted file mode 100644 index 5678aee6bcf..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a +++ /dev/null @@ -1,335 +0,0 @@ --- CXAA010.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 operations defined in package Ada.Text_IO.Decimal_IO --- are available, and that they function correctly when used for the --- input/output of Decimal types. --- --- TEST DESCRIPTION: --- This test demonstrates the Put and Get procedures found in the --- generic package Ada.Text_IO.Decimal_IO. Both Put and Get are --- overloaded to allow placement or extraction of decimal values --- to/from a text file or a string. This test demonstrates both forms --- of each subprogram. --- The test defines an array of records containing decimal value --- and string component fields. All component values are placed in a --- Text_IO file, with the decimal values being placed there using the --- version of Put defined for files, and using user-specified formatting --- parameters. The data is later extracted from the file, with the --- decimal values being removed using the version of Get defined for --- files. Decimal values are then written to strings, using the --- appropriate Put procedure. Finally, extraction of the decimal data --- from the strings completes the evaluation of the Decimal_IO package --- subprograms. --- The reconstructed data is verified at the end of the test against the --- data originally written to the file. --- --- APPLICABILITY CRITERIA: --- Applicable to all implementations capable of supporting external --- Text_IO files and Decimal Fixed Point Types --- --- All implementations must attempt to compile this test. --- --- For implementations validating against Information Systems Annex (F): --- this test must execute and report PASSED. --- --- For implementations not validating against Annex F: --- this test may report compile time errors at one or more points --- indicated by "-- ANX-F RQMT", in which case it may be graded as inapplicable. --- Otherwise, the test must execute and report PASSED. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 20 Feb 95 SAIC Modified test to allow for Use_Error/Name_Error --- generation by an implementation not supporting --- Text_IO operations. --- 14 Nov 95 SAIC Corrected string indexing for ACVC 2.0.1. --- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations --- 16 FEB 98 EDS Modified documentation. ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA010 is - use Ada.Text_IO; - Tax_Roll : Ada.Text_IO.File_Type; - Tax_Roll_Name : constant String := - Report.Legal_File_Name ( Nam => "CXAA010" ); - Incomplete : exception; -begin - - Report.Test ("CXAA010", "Check that the operations defined in package " & - "Ada.Text_IO.Decimal_IO are available, and " & - "that they function correctly when used for " & - "the input/output of Decimal types"); - - Test_for_Decimal_IO_Support: - begin - - -- An implementation that does not support Text_IO creation or naming - -- of external files in a particular environment will raise Use_Error - -- or Name_Error on a call to Text_IO Create. This block statement - -- encloses a call to Create, which should produce an exception in a - -- non-supportive environment. Either of these exceptions will be - -- handled to produce a Not_Applicable result. - - Ada.Text_IO.Create (Tax_Roll, Ada.Text_IO.Out_File, Tax_Roll_Name); - - exception - - when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Text_IO" ); - raise Incomplete; - - end Test_for_Decimal_IO_Support; - - Taxation: - declare - - ID_Length : constant := 5; - Price_String_Length : constant := 5; - Value_String_Length : constant := 6; - Total_String_Length : constant := 20; - Spacer : constant String := " "; -- Two blanks. - - type Price_Type is delta 0.1 digits 4; -- ANX-F RQMT - type Value_Type is delta 0.01 digits 5; -- ANX-F RQMT - - type Property_Type is - record - Parcel_ID : String (1..ID_Length); - Purchase_Price : Price_Type; - Assessed_Value : Value_Type; - end record; - - type City_Block_Type is array (1..4) of Property_Type; - - subtype Tax_Bill_Type is string (1..Total_String_Length); - type Tax_Bill_Array_Type is array (1..4) of Tax_Bill_Type; - - Neighborhood : City_Block_Type := - (("X9254", 123.0, 135.00), ("X3569", 345.0, 140.50), - ("X3434", 234.0, 179.50), ("X8838", 456.0, 158.00)); - - Neighborhood_Taxes : Tax_Bill_Array_Type; - - package Price_IO is new Ada.Text_IO.Decimal_IO (Price_Type); - package Value_IO is new Ada.Text_IO.Decimal_IO (Value_Type); - - begin -- Taxation - - Assessors_Office: - begin - - for Parcel in City_Block_Type'Range loop - -- Note: All data in the file will be separated with a - -- two-character blank spacer. - Ada.Text_IO.Put(Tax_Roll, Neighborhood(Parcel).Parcel_ID); - Ada.Text_IO.Put(Tax_Roll, Spacer); - - -- Use Decimal_IO.Put with non-default format parameters to - -- place decimal data into file. - Price_IO.Put (Tax_Roll, Neighborhood(Parcel).Purchase_Price, - Fore => 3, Aft =>1, Exp => 0); - Ada.Text_IO.Put(Tax_Roll, Spacer); - - Value_IO.Put (Tax_Roll, Neighborhood(Parcel).Assessed_Value, - Fore => 3, Aft =>2, Exp => 0); - Ada.Text_IO.New_Line(Tax_Roll); - end loop; - - Ada.Text_IO.Close (Tax_Roll); - - exception - when others => - Report.Failed ("Exception raised in Assessor's Office"); - end Assessors_Office; - - - Twice_A_Year: - declare - - procedure Collect_Tax(Index : in Integer; - Tax_Array : in out Tax_Bill_Array_Type) is - ID : String (1..ID_Length); - Price : Price_Type := 0.0; - Value : Value_Type := 0.00; - Price_String : String (1..Price_String_Length); - Value_String : String (1..Value_String_Length); - begin - - -- Extract information from the Text_IO file; one string, two - -- decimal values. - -- Note that the Spacers that were put in the file above are - -- not individually read here, due to the fact that each call - -- to Decimal_IO.Get below uses a zero in the Width field, - -- which allows each Get procedure to skip these leading blanks - -- prior to extracting the numeric value. - - Ada.Text_IO.Get (Tax_Roll, ID); - - -- A zero value of Width is provided, so the following - -- two calls to Decimal_IO.Get will skip the leading blanks, - -- (from the Spacer variable above), then read the numeric - -- literals. - - Price_IO.Get (Tax_Roll, Price, 0); - Value_IO.Get (Tax_Roll, Value, 0); - Ada.Text_IO.Skip_Line (Tax_Roll); - - -- Convert the values read from the file into string format, - -- using user-specified format parameters. - -- Format of the Price_String should be "nnn.n" - -- Format of the Value_String should be "nnn.nn" - - Price_IO.Put (To => Price_String, - Item => Price, - Aft => 1); - Value_IO.Put (Value_String, Value, 2); - - -- Construct a string of length 20 that contains the Parcel_ID, - -- the Purchase_Price, and the Assessed_Value, separated by - -- two-character blank data spacers. Store this string - -- into the string array out parameter. - -- Format of each Tax_Array element should be - -- "Xnnnn nnn.n nnn.nn" (with an 'n' signifying a digit). - - Tax_Array(Index) := ID & Spacer & - Price_String & Spacer & - Value_String; - exception - when Data_Error => - Report.Failed("Data Error raised during the extraction " & - "of decimal data from the file"); - when others => - Report.Failed("Exception in Collect_Tax procedure"); - end Collect_Tax; - - - begin -- Twice_A_Year - - Ada.Text_IO.Open (Tax_Roll, Ada.Text_IO.In_File, Tax_Roll_Name); - - -- Determine property tax bills for the entire neighborhood from - -- the information that is stored in the file. Store information - -- in the Neighborhood_Taxes string array. - - for Parcel in City_Block_Type'Range loop - Collect_Tax (Parcel, Neighborhood_Taxes); - end loop; - - exception - when others => - Report.Failed ("Exception in Twice_A_Year Block"); - end Twice_A_Year; - - -- Use Decimal_IO Get procedure to extract information from a string. - -- Verify data against original values. - Validation_Block: - declare - TC_ID : String (1..ID_Length); -- 1..5 - TC_Price : Price_Type; - TC_Value : Value_Type; - Length : Positive; - Front, - Rear : Integer := 0; - begin - - for Parcel in City_Block_Type'Range loop - -- Extract values from the strings of the string array. - -- Each element of the string array is 20 characters long; the - -- first five characters are the Parcel_ID, two blank characters - -- separate data, the next five characters contain the Price - -- decimal value, two blank characters separate data, the last - -- six characters contain the Value decimal value. - -- Extract each of these components in turn. - - Front := 1; -- 1 - Rear := ID_Length; -- 5 - TC_ID := Neighborhood_Taxes(Parcel)(Front..Rear); - - -- Extract the decimal value from the next slice of the string. - Front := Rear + 3; -- 8 - Rear := Front + Price_String_Length - 1; -- 12 - Price_IO.Get (Neighborhood_Taxes(Parcel)(Front..Rear), - Item => TC_Price, - Last => Length); - - -- Extract next decimal value from slice of string, based on - -- length of preceding strings read from string array element. - Front := Rear + 3; -- 15 - Rear := Total_String_Length; -- 20 - Value_IO.Get (Neighborhood_Taxes(Parcel)(Front..Rear), - Item => TC_Value, - Last => Length); - - if TC_ID /= Neighborhood(Parcel).Parcel_ID or - TC_Price /= Neighborhood(Parcel).Purchase_Price or - TC_Value /= Neighborhood(Parcel).Assessed_Value - then - Report.Failed ("Incorrect data validation"); - end if; - - end loop; - - exception - when others => Report.Failed ("Exception in Validation Block"); - end Validation_Block; - - -- Check that the Text_IO file is open, then delete. - - if not Ada.Text_IO.Is_Open (Tax_Roll) then - Report.Failed ("File not left open after processing"); - Ada.Text_IO.Open (Tax_Roll, Ada.Text_IO.Out_File, Tax_Roll_Name); - end if; - - Ada.Text_IO.Delete (Tax_Roll); - - exception - when others => - Report.Failed ("Exception in Taxation block"); - -- Check that the Text_IO file is open, then delete. - if not Ada.Text_IO.Is_Open (Tax_Roll) then - Ada.Text_IO.Open (Tax_Roll, - Ada.Text_IO.Out_File, - Tax_Roll_Name); - end if; - Ada.Text_IO.Delete (Tax_Roll); - end Taxation; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA010; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a deleted file mode 100644 index 8cc136d35ab..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a +++ /dev/null @@ -1,266 +0,0 @@ --- CXAA011.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 operations of Text_IO.Enumeration_IO perform correctly --- on files of Append_File mode, for instantiations using --- enumeration types. Check that Enumeration_IO procedures Put and Get --- properly transfer enumeration data to/from data files. --- Check that the formatting parameters available in the package can --- be used and modified successfully in the storage and retrieval of data. --- --- TEST DESCRIPTION: --- This test is designed to simulate an environment where a data file --- that holds enumeration type information is reset from it current mode --- to allow the appending of data to the end of the This process --- of Reset/Write can be repeated as necessary. All data written --- to the file is verified for accuracy when retrieved from the file. --- --- This test verifies issues of resetting a file created in Out_File mode --- to Append_File mode, resetting from Append_File mode to In_File mode, --- as well as a variety of Text_IO and Enumeration_IO predefined --- subprograms. --- --- APPLICABILITY CRITERIA: --- This test is applicable only to implementations that support text --- files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA011 is - use Ada; - - Status_Log : Text_IO.File_Type; - Status_Log_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAA011" ); - Incomplete : exception; - -begin - - Report.Test ("CXAA011", "Check that the operations of " & - "Text_IO.Enumeration_IO operate correctly for " & - "files with mode Append_File"); - - Test_for_Text_IO_Support: - begin - - -- An implementation that does not support Text_IO in a particular - -- environment will raise Use_Error on calls to various - -- Text_IO operations. This block statement encloses a call to - -- Create, which should raise the exception in a non-supportive - -- environment. This exception will be handled to produce a - -- Not_Applicable result. - - Text_IO.Create (File => Status_Log, - Mode => Text_IO.Out_File, - Name => Status_Log_Filename); - exception - - when Text_IO.Use_Error | Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Text_IO" ); - raise Incomplete; - - end Test_for_Text_IO_Support; - - - Operational_Test_Block: - declare - - type Days_In_Week is (Monday, Tuesday, Wednesday, Thursday, Friday, - Saturday, Sunday); - type Hours_In_Day is (A0000, A0600, P1200, P0600); -- Six hour - -- blocks. - type Status_Type is (Operational, Off_Line); - - type Status_Record_Type is record - Day : Days_In_Week; - Hour : Hours_In_Day; - Status : Status_Type; - end record; - - Morning_Reading : Status_Record_Type := - (Wednesday, A0600, Operational); - Evening_Reading : Status_Record_Type := - (Saturday, P0600, Off_Line); - - package Day_IO is new Text_IO.Enumeration_IO (Days_In_Week); - package Hours_IO is new Text_IO.Enumeration_IO (Hours_In_Day); - package Status_IO is new Text_IO.Enumeration_IO (Status_Type); - - - -- The following function simulates the hourly recording of equipment - -- status. - - function Record_Status (Reading : Status_Record_Type) - return Boolean is - use Text_IO; -- To provide visibility to type Type_Set and - -- enumeration literal Upper_Case. - begin - Day_IO.Put (File => Status_Log, - Item => Reading.Day, - Set => Type_Set'(Upper_Case)); - Hours_IO.Put (Status_Log, Reading.Hour, 7); - Status_IO.Put (Status_Log, Reading.Status, - Width => 8, Set => Lower_Case); - Text_IO.New_Line (Status_Log); - return (True); - exception - when others => return False; - end Record_Status; - - begin - - -- The usage scenario intended is as follows: - -- File is created. - -- Unrelated/unknown file processing occurs. - -- On six hour intervals, file is reset to Append_File mode. - -- Data is appended to file. - -- Unrelated/unknown file processing resumes. - -- Reset/Append process is repeated. - - Reset1: - begin - Text_IO.Reset (Status_Log, -- Reset to - Text_IO.Append_File); -- Append mode. - exception - when Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Append_File not supported for Text_IO" ); - raise Incomplete; - end Reset1; - - Day_IO.Default_Width := Days_In_Week'Width + 5; -- Default values - -- are modifiable. - - if not Record_Status (Morning_Reading) then -- Enter data. - Report.Failed ("Exception occurred during data file update"); - end if; - - Reset2: - begin - Text_IO.Reset (Status_Log, -- Reset to - Text_IO.Append_File); -- Append mode. - exception - when Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Append_File not supported for Text_IO" ); - raise Incomplete; - end Reset2; - - if not Record_Status (Evening_Reading) then -- Enter data. - Report.Failed ("Exception occurred during data file update"); - end if; - - Test_Verification_Block: - declare - TC_Reading1 : Status_Record_Type; - TC_Reading2 : Status_Record_Type; - begin - - Reset3: - begin - Text_IO.Reset (Status_Log, Text_IO.In_File); -- Reset for - -- reading. - exception - when Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO" ); - raise Incomplete; - end Reset3; - - Day_IO.Get (Status_Log, TC_Reading1.Day); -- Read data from - Hours_IO.Get (Status_Log, TC_Reading1.Hour); -- first record. - Status_IO.Get (Status_Log, TC_Reading1.Status); - Text_IO.Skip_Line (Status_Log); - - -- Verify the data read from the file. Compare with the - -- record that was originally entered into the file. - - if (TC_Reading1 /= Morning_Reading) then - Report.Failed ("Data error on reading first record"); - end if; - - Day_IO.Get (Status_Log, TC_Reading2.Day); -- Read data from - Hours_IO.Get (Status_Log, TC_Reading2.Hour); -- second record. - Status_IO.Get (Status_Log, TC_Reading2.Status); - Text_IO.Skip_Line (Status_Log); - - -- Verify all of the data fields read from the file. Compare - -- with the values that were originally entered into the file. - - if (TC_Reading2.Day /= Evening_Reading.Day) or - (TC_Reading2.Hour /= Evening_Reading.Hour) or - (TC_Reading2.Status /= Evening_Reading.Status) then - Report.Failed ("Data error on reading second record"); - end if; - - exception - when Incomplete => - raise; - when others => - Report.Failed ("Error raised during data verification"); - end Test_Verification_Block; - - exception - when Incomplete => - raise; - when others => - Report.Failed ("Exception in Text_IO.Enumeration_IO processing"); - end Operational_Test_Block; - - Final_Block: - begin - -- Delete the external file. - if Text_IO.Is_Open (Status_Log) then - Text_IO.Delete (Status_Log); - else - Text_IO.Open (Status_Log, Text_IO.Out_File, Status_Log_Filename); - Text_IO.Delete (Status_Log); - end if; - exception - when Text_IO.Use_Error => - Report.Failed - ( "Delete not properly implemented for Text_IO" ); - - end Final_Block; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA011; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a deleted file mode 100644 index 07523b44170..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a +++ /dev/null @@ -1,167 +0,0 @@ --- CXAA012.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 exception Mode_Error is raised when an attempt is made --- to read from (perform a Get_Line) or use the predefined End_Of_File --- function on a text file with mode Append_File. --- --- TEST DESCRIPTION: --- A scenario is created that demonstrates the potential for the --- incorrect usage of predefined text processing subprograms, resulting --- from their use with files of the wrong Mode. This results in the --- raising of Mode_Error exceptions, which is handled within blocks --- embedded in the test. --- A count is kept to ensure that each anticipated exception is in fact --- raised and handled properly. --- --- APPLICABILITY CRITERIA: --- This test is applicable only to implementations that support text --- files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA012 is - use Ada; - Text_File : Text_IO.File_Type; - Text_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAA012" ); - Incomplete : exception; -begin - - Report.Test ("CXAA012", "Check that the exception Mode_Error is " & - "raised when an attempt is made to read " & - "from (perform a Get_Line) or use the " & - "predefined End_Of_File function on a " & - "text file with mode Append_File"); - - Test_for_Text_IO_Support: - begin - - -- Use_Error or Name_Error will be raised if Text_IO operations - -- or external files are not supported. - - Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename); - - exception - when Text_IO.Use_Error | Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Text_IO" ); - raise Incomplete; - end Test_for_Text_IO_Support; - - -- The application writes some amount of data to the file. - - Text_IO.Put_Line (Text_File, "Data entered into the file"); - - Text_IO.Close (Text_File); - - Operational_Test_Block: - declare - TC_Number_Of_Forced_Mode_Errors : constant Natural := 2; - TC_Mode_Errors : Natural := 0; - begin - - Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename); - - Test_for_Reading: - declare - TC_Data : String (1..80); - TC_Length : Natural := 0; - begin - --- During the course of its processing, the application may become confused --- and erroneously attempt to read data from the file that is currently in --- Append_File mode (instead of the anticipated In_File mode). --- This would result in the raising of Mode_Error. - - Text_IO.Get_Line (Text_File, TC_Data, TC_Length); - Report.Failed ("Exception not raised by Get_Line"); - --- An exception handler present within the application handles the exception --- and processing can continue. - - exception - when Text_IO.Mode_Error => - TC_Mode_Errors := TC_Mode_Errors + 1; - when others => - Report.Failed ("Exception in Get_Line processing"); - end Test_for_Reading; - - - Test_for_End_Of_File: - declare - TC_End_Of_File : Boolean; - begin - --- Again, during the course of its processing, the application attempts to --- call the End_Of_File function for the file that is currently in --- Append_File mode (instead of the anticipated In_File mode). - - TC_End_Of_File := Text_IO.End_Of_File (Text_File); - Report.Failed ("Exception not raised by End_Of_File"); - --- Once again, an exception handler present within the application handles --- the exception and processing continues. - - exception - when Text_IO.Mode_Error => - TC_Mode_Errors := TC_Mode_Errors + 1; - when others => - Report.Failed("Exception in End_Of_File processing"); - end Test_for_End_Of_File; - - - if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then - Report.Failed ("Incorrect number of exceptions handled"); - end if; - - end Operational_Test_Block; - - -- Delete the external file. - if Text_IO.Is_Open (Text_File) then - Text_IO.Delete (Text_File); - else - Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); - Text_IO.Delete (Text_File); - end if; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA012; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a deleted file mode 100644 index be658ca13e0..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a +++ /dev/null @@ -1,167 +0,0 @@ --- CXAA013.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 exception Mode_Error is raised when an attempt is made --- to skip a line or page using the predefined Skip_Line and Skip_Page --- procedures on a text file with mode Append_File. --- --- TEST DESCRIPTION: --- A scenario is created that demonstrates the potential for the --- incorrect usage of predefined text processing subprograms, which --- results in the raising of a Mode_Error exception. --- A count is kept to ensure that each anticipated exception is in fact --- raised and handled properly. --- --- APPLICABILITY CRITERIA: --- This test is applicable only to implementations that support text --- files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA013 is - use Ada; - Text_File : Text_IO.File_Type; - Text_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAA013" ); - Incomplete : exception; - -begin - - Report.Test ("CXAA013", "Check that the exception Mode_Error is " & - "raised when an attempt is made to skip " & - "a line or page using the predefined " & - "Skip_Line and Skip_Page procedures on " & - "a text file with mode Append_File"); - - Test_for_Text_IO_Support: - begin - --- An application creates a text file with mode Append_File. --- Use_Error will be raised if Text_IO operations or external files are not --- supported. - - Text_IO.Create (Text_File, Text_IO.Append_File, Text_Filename); - - exception - - when Text_IO.Use_Error | Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Append_File for Text_IO" ); - raise Incomplete; - - end Test_for_Text_IO_Support; - --- The application writes some amount of data to the file. - - Text_IO.Put_Line (Text_File, "Data entered into the file"); - - Operational_Test_Block: - declare - TC_Number_Of_Forced_Mode_Errors : constant Natural := 2; - TC_Mode_Errors : Natural := 0; - begin - - Test_for_Skip_Line: - declare - TC_Spacing : constant Text_IO.Count := 3; - begin - --- During the course of its processing, the application may attempt to --- invoke the Skip_Line procedure on a file that is currently in Append_File --- mode (instead of the anticipated In_File mode). This results in the --- raising of Mode_Error. - - Text_IO.Skip_Line (Text_File, TC_Spacing); - Report.Failed ("Exception not raised by Skip_Line"); - --- An exception handler present within the application handles the exception --- and processing can continue. - - exception - when Text_IO.Mode_Error => - TC_Mode_Errors := TC_Mode_Errors + 1; - when others => - Report.Failed("Exception in Skip_Line processing"); - end Test_for_Skip_Line; - - Test_for_Skip_Page: - begin - --- Again, during the course of its processing, the application incorrectly --- assumes that the file mode is In_File, this time attempting to call the --- Skip_Page procedure for the file (that is currently in Append_File mode). - - Text_IO.Skip_Page (Text_File); - Report.Failed ("Exception not raised by Skip_Page"); - --- Once again, an exception handler present within the application handles --- the exception and processing continues. - - exception - when Text_IO.Mode_Error => - TC_Mode_Errors := TC_Mode_Errors + 1; - when others => - Report.Failed("Exception in Skip_Page processing"); - end Test_for_Skip_Page; - - if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then - Report.Failed ("Incorrect number of exceptions handled"); - end if; - - end Operational_Test_Block; - - Deletion: - begin - -- Delete the external file. - if Text_IO.Is_Open (Text_File) then - Text_IO.Delete (Text_File); - else - Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); - Text_IO.Delete (Text_File); - end if; - exception - when others => - Report.Failed - ( "Delete not properly implemented for Text_IO" ); - end Deletion; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA013; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a deleted file mode 100644 index 0b74c616959..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a +++ /dev/null @@ -1,178 +0,0 @@ --- CXAA014.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 exception Mode_Error is raised when an attempt is made --- to check for the end of a line or page using the predefined functions --- End_Of_Line or End_Of_Page on a text file with mode Append_File. --- --- TEST DESCRIPTION: --- A scenario is created that demonstrates the potential for the --- incorrect usage of predefined text processing subprograms, which --- results in the raising of a Mode_Error exception. --- A count is kept to ensure that each anticipated exception is in fact --- raised and handled properly. --- --- APPLICABILITY CRITERIA: --- This test is applicable only to implementations that support text --- files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA014 is - use Ada; - Text_File : Text_IO.File_Type; - Text_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAA014" ); - Incomplete : exception; - -begin - - Report.Test ("CXAA014", "Check that the exception Mode_Error is " & - "raised when an attempt is made to check " & - "for the end of a line or page using the " & - "predefined functions End_Of_Line or " & - "End_Of_Page on a text file with mode " & - "Append_File"); - - Test_for_Text_IO_Support: - begin - --- Use_Error will be raised if Text_IO operations or external files are not --- supported. - - Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename); - - exception - - when Text_IO.Use_Error | Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Text_IO" ); - raise Incomplete; - - end Test_for_Text_IO_Support; - - --- The application writes some amount of data to the file. - - for I in 1 .. 10 loop - Text_IO.Put_Line (Text_File, "Data entered into the file"); - end loop; - - Text_IO.Close (Text_File); - - Operational_Test_Block: - declare - TC_Number_Of_Forced_Mode_Errors : constant Natural := 2; - TC_Mode_Errors : Natural := 0; - begin - - Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename); - - Test_for_End_Of_Line: - declare - TC_End_Of_Line : Boolean; - begin - --- During the course of its processing, the application may attempt to --- invoke the End_Of_Line function on a file that is currently in Append_File --- mode (instead of the anticipated In_File mode). This results in the --- raising of Mode_Error. - - TC_End_Of_Line := Text_IO.End_Of_Line (Text_File); - Report.Failed ("Exception not raised by End_Of_Line"); - --- An exception handler present within the application handles the exception --- and processing can continue. - - exception - when Text_IO.Mode_Error => - TC_Mode_Errors := TC_Mode_Errors + 1; - when others => - Report.Failed("Exception in End_Of_Line processing"); - end Test_for_End_Of_Line; - - - Test_for_End_Of_Page: - declare - TC_End_Of_Page : Boolean; - begin - --- Again, during the course of its processing, the application incorrectly --- assumes that the file mode is In_File, this time attempting to call the --- End_Of_Page function for the file (that is currently in Append_File mode). - - TC_End_Of_Page := Text_IO.End_Of_Page (Text_File); - Report.Failed ("Exception not raised by End_Of_Page"); - --- Once again, an exception handler present within the application handles --- the exception and processing continues. - - exception - when Text_IO.Mode_Error => - TC_Mode_Errors := TC_Mode_Errors + 1; - when others => - Report.Failed("Exception in End_Of_Page processing"); - end Test_for_End_Of_Page; - - - if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then - Report.Failed ("Incorrect number of exceptions handled"); - end if; - - end Operational_Test_Block; - - Deletion: - begin - -- Delete the external file. - if Text_IO.Is_Open (Text_File) then - Text_IO.Delete (Text_File); - else - Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); - Text_IO.Delete (Text_File); - end if; - exception - when others => - Report.Failed - ( "Delete not properly implemented for Text_IO" ); - end Deletion; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA014; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a deleted file mode 100644 index 919ef05ca7e..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a +++ /dev/null @@ -1,227 +0,0 @@ --- CXAA015.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 exception Status_Error is raised when an attempt is --- made to create or open a file in Append_File mode when the file is --- already open. --- Check that the exception Name_Error is raised by procedure Open when --- attempting to open a file in Append_File mode when the name supplied --- as the filename does not correspond to an existing external file. --- --- TEST DESCRIPTION: --- A scenario is created that demonstrates the potential for the --- inappropriate usage of text processing subprograms Create and Open, --- resulting in the raising of Status_Error and Name_Error exceptions. --- A count is kept to ensure that each anticipated exception is in fact --- raised and handled properly. --- --- APPLICABILITY CRITERIA: --- This test is applicable only to implementations that support text --- files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations ---! - -with Ada.Text_IO; -with Report; - -procedure CXAA015 is - use Ada; - Text_File : Text_IO.File_Type; - Text_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAA015" ); - Incomplete : exception; - -begin - - Report.Test ("CXAA015", "Check that the appropriate exceptions " & - "are raised when procedures Create and " & - "Open are used to inappropriately operate " & - "on files of mode Append_File"); - - Test_for_Text_IO_Support: - begin - --- An application creates a text file with mode Append_File. --- Use_Error will be raised if Text_IO operations or external files are not --- supported. - - Text_IO.Create (Text_File, Text_IO.Append_File, Text_Filename); - exception - - when Text_IO.Use_Error | Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Append_File for Text_IO" ); - raise Incomplete; - - end Test_for_Text_IO_Support; - - --- The application writes some amount of data to the file. - - for I in 1 .. 5 loop - Text_IO.Put_Line (Text_File, "Data entered into the file"); - end loop; - - Operational_Test_Block: - declare - TC_Number_Of_Forced_Errors : constant Natural := 3; - TC_Errors : Natural := 0; - begin - - - Test_for_Create: - begin - --- During the course of its processing, the application may (erroneously) --- attempt to create the same file already in existence in Append_File mode. --- This results in the raising of Status_Error. - - Text_IO.Create (Text_File, - Text_IO.Append_File, - Text_Filename); - Report.Failed ("Exception not raised by Create"); - --- An exception handler present within the application handles the exception --- and processing can continue. - - exception - when Text_IO.Status_Error => - TC_Errors := TC_Errors + 1; - when others => - Report.Failed("Exception in Create processing"); - end Test_for_Create; - - - First_Test_For_Open: - begin - --- Again, during the course of its processing, the application incorrectly --- attempts to Open a file (in Append_File mode) that is already open. - - Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename); - Report.Failed ("Exception not raised by improper Open - 1"); - --- Once again, an exception handler present within the application handles --- the exception and processing continues. - - exception - when Text_IO.Status_Error => - TC_Errors := TC_Errors + 1; - --- At some point in its processing, the application closes the file that is --- currently open. - - Text_IO.Close (Text_File); - when others => - Report.Failed("Exception in Open processing - 1"); - end First_Test_For_Open; - - - Open_With_Wrong_Filename: - declare - TC_Wrong_Filename : constant String := - Report.Legal_File_Name(2); - begin - --- At this point, the application attempts to Open (in Append_File mode) the --- file used in previous processing, but it attempts this Open using a name --- string that does not correspond to any existing external file. --- First make sure the file doesn't exist. (If it did, then the check --- for open in append mode wouldn't work.) - - Verify_No_File: - begin - Text_IO.Open (Text_File, - Text_IO.In_File, - TC_Wrong_Filename); - exception - when Text_IO.Name_Error => - null; - when others => - Report.Failed ( "Unexpected exception on Open check" ); - end Verify_No_File; - - Delete_No_File: - begin - if Text_IO.Is_Open (Text_File) then - Text_IO.Delete (Text_File); - end if; - exception - when others => - Report.Failed ( "Unexpected exception - Delete check" ); - end Delete_No_File; - - Text_IO.Open (Text_File, - Text_IO.Append_File, - TC_Wrong_Filename); - Report.Failed ("Exception not raised by improper Open - 2"); - --- An exception handler for the Name_Error, present within the application, --- catches the exception and processing continues. - - exception - when Text_IO.Name_Error => - TC_Errors := TC_Errors + 1; - when others => - Report.Failed("Exception in Open processing - 2"); - end Open_With_Wrong_Filename; - - - if (TC_Errors /= TC_Number_Of_Forced_Errors) then - Report.Failed ("Incorrect number of exceptions handled"); - end if; - - end Operational_Test_Block; - - Deletion: - begin - -- Delete the external file. - if Text_IO.Is_Open (Text_File) then - Text_IO.Delete (Text_File); - else - Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); - Text_IO.Delete (Text_File); - end if; - exception - when others => - Report.Failed - ( "Delete not properly implemented for Text_IO" ); - end Deletion; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAA015; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a deleted file mode 100644 index 8ae69a12664..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a +++ /dev/null @@ -1,462 +0,0 @@ --- CXAA016.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 type File_Access is available in Ada.Text_IO, and that --- objects of this type designate File_Type objects. --- Check that function Set_Error will set the current default error file. --- Check that versions of Ada.Text_IO functions Standard_Input, --- Standard_Output, Standard_Error return File_Access values designating --- the standard system input, output, and error files. --- Check that versions of Ada.Text_IO functions Current_Input, --- Current_Output, Current_Error return File_Access values designating --- the current system input, output, and error files. --- --- TEST DESCRIPTION: --- This test tests the use of File_Access objects in referring --- to File_Type objects, as well as several new functions that return --- File_Access objects as results. --- Four user-defined files are created. These files will be set to --- function as current system input, output, and error files. --- Data will be read from and written to these files during the --- time at which they function as the current system files. --- An array of File_Access objects will be defined. It will be --- initialized using functions that return File_Access objects --- referencing the Standard and Current Input, Output, and Error files. --- This "saves" the initial system environment, which will be modified --- to use the user-defined files as the current default Input, Output, --- and Error files. At the end of the test, the data in this array --- will be used to restore the initial system environment. --- --- APPLICABILITY CRITERIA: --- This test is applicable to implementations capable of supporting --- external Text_IO files. --- --- --- CHANGE HISTORY: --- 25 May 95 SAIC Initial prerelease version. --- 22 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations. --- 18 Jan 99 RLB Repaired to allow Not_Applicable systems to --- fail delete. ---! - -with Ada.Text_IO; -package CXAA016_0 is - New_Input_File, - New_Output_File, - New_Error_File_1, - New_Error_File_2 : aliased Ada.Text_IO.File_Type; -end CXAA016_0; - - -with Report; -with Ada.Exceptions; -with Ada.Text_IO; use Ada.Text_IO; -with CXAA016_0; use CXAA016_0; - -procedure CXAA016 is - - Non_Applicable_System : exception; - No_Reset : exception; - Not_Applicable_System : Boolean := False; - - procedure Delete_File ( A_File : in out Ada.Text_IO.File_Type; - ID_Num : in Integer ) is - begin - if not Ada.Text_IO.Is_Open ( A_File ) then - Ada.Text_IO.Open ( A_File, - Ada.Text_IO.In_File, - Report.Legal_File_Name ( ID_Num ) ); - end if; - Ada.Text_IO.Delete ( A_File ); - exception - when Ada.Text_IO.Name_Error => - if Not_Applicable_System then - null; -- File probably wasn't created. - else - Report.Failed ( "Can't open file for Text_IO" ); - end if; - when Ada.Text_IO.Use_Error => - if Not_Applicable_System then - null; -- File probably wasn't created. - else - Report.Failed ( "Delete not properly implemented for Text_IO" ); - end if; - when others => - Report.Failed ( "Unexpected exception in Delete_File" ); - end Delete_File; - -begin - - Report.Test ("CXAA016", "Check that the type File_Access is available " & - "in Ada.Text_IO, and that objects of this " & - "type designate File_Type objects"); - Test_Block: - declare - - use Ada.Exceptions; - - type System_File_Array_Type is - array (Integer range <>) of File_Access; - - -- Fill the following array with the File_Access results of six - -- functions. - - Initial_Environment : System_File_Array_Type(1..6) := - ( Standard_Input, - Standard_Output, - Standard_Error, - Current_Input, - Current_Output, - Current_Error ); - - New_Input_Ptr : File_Access := New_Input_File'Access; - New_Output_Ptr : File_Access := New_Output_File'Access; - New_Error_Ptr : File_Access := New_Error_File_1'Access; - - Line : String(1..80); - Length : Natural := 0; - - Line_1 : constant String := "This is the first line in the Output file"; - Line_2 : constant String := "This is the next line in the Output file"; - Line_3 : constant String := "This is the first line in Error file 1"; - Line_4 : constant String := "This is the next line in Error file 1"; - Line_5 : constant String := "This is the first line in Error file 2"; - Line_6 : constant String := "This is the next line in Error file 2"; - - - - procedure New_File (The_File : in out File_Type; - Mode : in File_Mode; - Next : in Integer) is - begin - Create (The_File, Mode, Report.Legal_File_Name(Next)); - exception - -- The following two exceptions may be raised if a system is not - -- capable of supporting external Text_IO files. The handler will - -- raise a user-defined exception which will result in a - -- Not_Applicable result for the test. - when Use_Error | Name_Error => raise Non_Applicable_System; - end New_File; - - - - procedure Check_Initial_Environment (Env : System_File_Array_Type) is - begin - -- Check that the system has defined the following sources/ - -- destinations for input/output/error, and that the six functions - -- returning File_Access values are available. - if not (Env(1) = Standard_Input and - Env(2) = Standard_Output and - Env(3) = Standard_Error and - Env(4) = Current_Input and - Env(5) = Current_Output and - Env(6) = Current_Error) - then - Report.Failed("At the start of the test, the Standard and " & - "Current File_Access values associated with " & - "system Input, Output, and Error files do " & - "not correspond"); - end if; - end Check_Initial_Environment; - - - - procedure Load_Input_File (Input_Ptr : in File_Access) is - begin - -- Load data into the file that will function as the user-defined - -- system input file. - Put_Line(Input_Ptr.all, Line_1); - Put_Line(Input_Ptr.all, Line_2); - Put_Line(Input_Ptr.all, Line_3); - Put_Line(Input_Ptr.all, Line_4); - Put_Line(Input_Ptr.all, Line_5); - Put_Line(Input_Ptr.all, Line_6); - end Load_Input_File; - - - - procedure Restore_Initial_Environment - (Initial_Env : System_File_Array_Type) is - begin - -- Restore the Current Input, Output, and Error files to their - -- original states. - - Set_Input (Initial_Env(4).all); - Set_Output(Initial_Env(5).all); - Set_Error (Initial_Env(6).all); - - -- At this point, the user-defined files that were functioning as - -- the Current Input, Output, and Error files have been replaced in - -- that capacity by the state of the original environment. - - declare - - -- Capture the state of the current environment. - - Current_Env : System_File_Array_Type (1..6) := - (Standard_Input, Standard_Output, Standard_Error, - Current_Input, Current_Output, Current_Error); - begin - - -- Compare the current environment with that of the saved - -- initial environment. - - if Current_Env /= Initial_Env then - Report.Failed("Restored file environment was not the same " & - "as the initial file environment"); - end if; - end; - end Restore_Initial_Environment; - - - - procedure Verify_Files (O_File, E_File_1, E_File_2 : in File_Type) is - Str_1, Str_2, Str_3, Str_4, Str_5, Str_6 : String (1..80); - Len_1, Len_2, Len_3, Len_4, Len_5, Len_6 : Natural; - begin - - -- Get the lines that are contained in all the files, and verify - -- them against the expected results. - - Get_Line(O_File, Str_1, Len_1); -- The user defined output file - Get_Line(O_File, Str_2, Len_2); -- should contain two lines of data. - - if Str_1(1..Len_1) /= Line_1 or - Str_2(1..Len_2) /= Line_2 - then - Report.Failed("Incorrect results from Current_Output file"); - end if; - - Get_Line(E_File_1, Str_3, Len_3); -- The first error file received - Get_Line(E_File_1, Str_4, Len_4); -- two lines of data originally, - Get_Line(E_File_1, Str_5, Len_5); -- then had two additional lines - Get_Line(E_File_1, Str_6, Len_6); -- appended from the second error - -- file. - if Str_3(1..Len_3) /= Line_3 or - Str_4(1..Len_4) /= Line_4 or - Str_5(1..Len_5) /= Line_5 or - Str_6(1..Len_6) /= Line_6 - then - Report.Failed("Incorrect results from first Error file"); - end if; - - Get_Line(E_File_2, Str_5, Len_5); -- The second error file - Get_Line(E_File_2, Str_6, Len_6); -- received two lines of data. - - if Str_5(1..Len_5) /= Line_5 or - Str_6(1..Len_6) /= Line_6 - then - Report.Failed("Incorrect results from second Error file"); - end if; - - end Verify_Files; - - - - begin - - Check_Initial_Environment (Initial_Environment); - - -- Create user-defined text files that will be set to serve as current - -- system input, output, and error files. - - New_File (New_Input_File, Out_File, 1); -- Will be reset prior to use. - New_File (New_Output_File, Out_File, 2); - New_File (New_Error_File_1, Out_File, 3); - New_File (New_Error_File_2, Out_File, 4); - - -- Enter several lines of text into the new input file. This file will - -- be reset to mode In_File to function as the current system input file. - -- Note: File_Access value used as parameter to this procedure. - - Load_Input_File (New_Input_Ptr); - - -- Reset the New_Input_File to mode In_File, to allow it to act as the - -- current system input file. - - Reset1: - begin - Reset (New_Input_File, In_File); - exception - when Ada.Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO - 1" ); - raise No_Reset; - end Reset1; - - -- Establish new files that will function as the current system Input, - -- Output, and Error files. - - Set_Input (New_Input_File); - Set_Output(New_Output_Ptr.all); - Set_Error (New_Error_Ptr.all); - - -- Perform various file processing tasks, exercising specific new - -- Text_IO functionality. - -- - -- Read two lines from Current_Input and write them to Current_Output. - - for i in 1..2 loop - Get_Line(Current_Input, Line, Length); - Put_Line(Current_Output, Line(1..Length)); - end loop; - - -- Read two lines from Current_Input and write them to Current_Error. - - for i in 1..2 loop - Get_Line(Current_Input, Line, Length); - Put_Line(Current_Error, Line(1..Length)); - end loop; - - -- Reset the Current system error file. - - Set_Error (New_Error_File_2); - - -- Read two lines from Current_Input and write them to Current_Error. - - for i in 1..2 loop - Get_Line(Current_Input, Line, Length); - Put_Line(Current_Error, Line(1..Length)); - end loop; - - -- At this point in the processing, the new Output file, and each of - -- the two Error files, contain two lines of data. - -- Note that New_Error_File_1 has been replaced by New_Error_File_2 - -- as the current system error file, allowing New_Error_File_1 to be - -- reset (Mode_Error raised otherwise). - -- - -- Reset the first Error file to Append_File mode, and then set it to - -- function as the current system error file. - - Reset2: - begin - Reset (New_Error_File_1, Append_File); - exception - when Ada.Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Append_File not supported for Text_IO - 2" ); - raise No_Reset; - end Reset2; - - Set_Error (New_Error_File_1); - - -- Reset the second Error file to In_File mode, then set it to become - -- the current system input file. - - Reset3: - begin - Reset (New_Error_File_2, In_File); - exception - when Ada.Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO - 3" ); - raise No_Reset; - end Reset3; - - New_Error_Ptr := New_Error_File_2'Access; - Set_Input (New_Error_Ptr.all); - - -- Append all of the text lines (2) in the new current system input - -- file onto the current system error file. - - while not End_Of_File(Current_Input) loop - Get_Line(Current_Input, Line, Length); - Put_Line(Current_Error, Line(1..Length)); - end loop; - - -- Restore the original system file environment, based upon the values - -- stored at the start of this test. - -- Check that the original environment has been restored. - - Restore_Initial_Environment (Initial_Environment); - - -- Reset all three files to In_File_Mode prior to verification. - -- Note: If these three files had still been the designated Current - -- Input, Output, or Error files for the system, a Reset - -- operation at this point would raise Mode_Error. - -- However, at this point, the environment has been restored to - -- its original state, and these user-defined files are no longer - -- designated as current system files, allowing a Reset. - - Reset4: - begin - Reset(New_Error_File_1, In_File); - exception - when Ada.Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO - 4" ); - raise No_Reset; - end Reset4; - - Reset5: - begin - Reset(New_Error_File_2, In_File); - exception - when Ada.Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO - 5" ); - raise No_Reset; - end Reset5; - - Reset6: - begin - Reset(New_Output_File, In_File); - exception - when Ada.Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO - 6" ); - raise No_Reset; - end Reset6; - - -- Check that all the files contain the appropriate data. - - Verify_Files (New_Output_File, New_Error_File_1, New_Error_File_2); - - exception - when No_Reset => - null; - when Non_Applicable_System => - Report.Not_Applicable("System not capable of supporting external " & - "text files -- Name_Error/Use_Error raised " & - "during text file creation"); - Not_Applicable_System := True; - when The_Error : others => - Report.Failed ("The following exception was raised in the " & - "Test_Block: " & Exception_Name(The_Error)); - end Test_Block; - - Delete_Block: - begin - Delete_File ( New_Input_File, 1 ); - Delete_File ( New_Output_File, 2 ); - Delete_File ( New_Error_File_1, 3 ); - Delete_File ( New_Error_File_2, 4 ); - end Delete_Block; - - Report.Result; - -end CXAA016; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a deleted file mode 100644 index 17d0922cc24..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a +++ /dev/null @@ -1,400 +0,0 @@ --- CXAA017.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 Ada.Text_IO function Look_Ahead sets parameter End_Of_Line --- to True if at the end of a line; otherwise check that it returns the --- next character from a file (without consuming it), while setting --- End_Of_Line to False. --- --- Check that Ada.Text_IO function Get_Immediate will return the next --- control or graphic character in parameter Item from the specified --- file. Check that the version of Ada.Text_IO function Get_Immediate --- with the Available parameter will, if a character is available in the --- specified file, return the character in parameter Item, and set --- parameter Available to True. --- --- TEST DESCRIPTION: --- This test exercises specific capabilities of two Text_IO subprograms, --- Look_Ahead and Get_Immediate. A file is prepared that contains a --- variety of graphic and control characters on several lines. --- In processing this file, a call to Look_Ahead is performed to ensure --- that characters are available, then individual characters are --- extracted from the current line using Get_Immediate. The characters --- returned from both subprogram calls are compared with the expected --- character result. Processing on each file line continues until --- Look_Ahead indicates that the end of the line is next. Separate --- verification is performed to ensure that all characters of each line --- are processed, and that the Available and End_Of_Line parameters --- of the subprograms are properly set in the appropriate instances. --- --- APPLICABILITY CRITERIA: --- This test is applicable to implementations capable of supporting --- external Text_IO files. --- --- --- CHANGE HISTORY: --- 30 May 95 SAIC Initial prerelease version. --- 01 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations. ---! - -with Ada.Text_IO; -package CXAA017_0 is - - User_Defined_Input_File : aliased Ada.Text_IO.File_Type; - -end CXAA017_0; - - -with CXAA017_0; use CXAA017_0; -with Ada.Characters.Latin_1; -with Ada.Exceptions; -with Ada.Text_IO; -with Report; - -procedure CXAA017 is - - use Ada.Characters.Latin_1; - use Ada.Exceptions; - use Ada.Text_IO; - - Non_Applicable_System : exception; - No_Reset : exception; - -begin - - Report.Test ("CXAA017", "Check that Ada.Text_IO subprograms " & - "Look_Ahead and Get_Immediate are available " & - "and produce correct results"); - - Test_Block: - declare - - User_Input_Ptr : File_Access := User_Defined_Input_File'Access; - - UDLA_Char, -- Acronym UDLA => "User Defined Look Ahead" - UDGI_Char, -- Acronym UDGI => "User Defined Get Immediate" - TC_Char : Character := Ada.Characters.Latin_1.NUL; - - UDLA_End_Of_Line, - UDGI_Available : Boolean := False; - - Char_Pos : Natural; - - -- This string contains five ISO 646 Control characters and six ISO 646 - -- Graphic characters: - TC_String_1 : constant String := STX & - SI & - DC2 & - CAN & - US & - Space & - Ampersand & - Solidus & - 'A' & - LC_X & - DEL; - - -- This string contains two ISO 6429 Control and six ISO 6429 Graphic - -- characters: - TC_String_2 : constant String := IS4 & - SCI & - Yen_Sign & - Masculine_Ordinal_Indicator & - UC_I_Grave & - Multiplication_Sign & - LC_C_Cedilla & - LC_Icelandic_Thorn; - - TC_Number_Of_Strings : constant := 2; - - type String_Access_Type is access constant String; - type String_Ptr_Array_Type is - array (1..TC_Number_Of_Strings) of String_Access_Type; - - TC_String_Ptr_Array : String_Ptr_Array_Type := - (new String'(TC_String_1), - new String'(TC_String_2)); - - - - procedure Create_New_File (The_File : in out File_Type; - Mode : in File_Mode; - Next : in Integer) is - begin - Create (The_File, Mode, Report.Legal_File_Name(Next)); - exception - -- The following two exceptions can be raised if a system is not - -- capable of supporting external Text_IO files. The handler will - -- raise a user-defined exception which will result in a - -- Not_Applicable result for the test. - when Use_Error | Name_Error => raise Non_Applicable_System; - end Create_New_File; - - - - procedure Load_File (The_File : in out File_Type) is - -- This procedure will load several strings into the file denoted - -- by the input parameter. A call to New_Line will add line/page - -- termination characters, which will be available for processing - -- along with the text in the file. - begin - Put_Line (The_File, TC_String_Ptr_Array(1).all); - New_Line (The_File, Spacing => 1); - Put_Line (The_File, TC_String_Ptr_Array(2).all); - end Load_File; - - - begin - - -- Create user-defined text file that will serve as the appropriate - -- sources of input to the procedures under test. - - Create_New_File (User_Defined_Input_File, Out_File, 1); - - -- Enter several lines of text into the new input file. - -- The characters that make up these text strings will be processed - -- using the procedures being exercised in this test. - - Load_File (User_Defined_Input_File); - - -- Check that Mode_Error is raised by Look_Ahead and Get_Immedidate - -- if the mode of the file object is not In_File. - -- Currently, the file mode is Out_File. - - begin - Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line); - Report.Failed("Mode_Error not raised by Look_Ahead"); - Report.Comment("This char should never be printed: " & UDLA_Char); - exception - when Mode_Error => null; -- OK, expected exception. - when The_Error : others => - Report.Failed ("The following exception was raised during the " & - "check that Look_Ahead raised Mode_Error when " & - "provided a file object that is not in In_File " & - "mode: " & Exception_Name(The_Error)); - end; - - begin - Get_Immediate(User_Defined_Input_File, UDGI_Char); - Report.Failed("Mode_Error not raised by Get_Immediate"); - Report.Comment("This char should never be printed: " & UDGI_Char); - exception - when Mode_Error => null; -- OK, expected exception. - when The_Error : others => - Report.Failed ("The following exception was raised during the " & - "check that Get_Immediate raised Mode_Error " & - "when provided a file object that is not in " & - "In_File mode: " & Exception_Name(The_Error)); - end; - - - -- The file will then be reset to In_File mode to properly function as - -- a source of input. - - Reset1: - begin - Reset (User_Defined_Input_File, In_File); - exception - when Ada.Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO" ); - raise No_Reset; - end Reset1; - - -- Process the input file, exercising various Text_IO - -- functionality, and validating the results at each step. - -- Note: The designated File_Access object is used in processing - -- the New_Default_Input_File in the second loop below. - - -- Process characters in first line of text of each file. - - Char_Pos := 1; - - -- Check that the first line is not blank. - - Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line); - - while not UDLA_End_Of_Line loop - - -- Use the Get_Immediate procedure on the file to get the next - -- available character on the current line. - - Get_Immediate(User_Defined_Input_File, UDGI_Char); - - -- Check that the characters returned by both procedures are the - -- same, and that they match the expected character from the file. - - if UDLA_Char /= TC_String_Ptr_Array(1).all(Char_Pos) or - UDGI_Char /= TC_String_Ptr_Array(1).all(Char_Pos) - then - Report.Failed("Incorrect retrieval of character " & - Integer'Image(Char_Pos) & " of first string"); - end if; - - -- Increment the character position counter. - Char_Pos := Char_Pos + 1; - - -- Check the next character on the line. If at the end of line, - -- the processing flow will exit the While loop. - - Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line); - - end loop; - - -- Check to ensure that the "end of line" results returned from the - -- Look_Ahead procedure (used to exit the above While loop) corresponds - -- with the result of Function End_Of_Line. - - if not End_Of_Line(User_Defined_Input_File) - then - Report.Failed("Result of procedure Look_Ahead that indicated " & - "being at the end of the line does not correspond " & - "with the result of function End_Of_Line"); - end if; - - -- Check that all characters in the string were processed. - - if Char_Pos-1 /= TC_String_1'Length then - Report.Failed("Not all of the characters on the first line " & - "were processed"); - end if; - - - -- Call procedure Skip_Line to advance beyond the end of the first line. - - Skip_Line(User_Defined_Input_File); - - - -- Process the second line in the file (a blank line). - - Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line); - - if not UDLA_End_Of_Line then - Report.Failed("Incorrect end of line determination from procedure " & - "Look_Ahead when processing a blank line"); - end if; - - -- Call procedure Skip_Line to advance beyond the end of the second line. - - Skip_Line(User_Input_Ptr.all); - - - -- Process characters in the third line of the file (second line - -- of text) - -- Note: The version of Get_Immediate used in processing this line has - -- the Boolean parameter Available. - - Char_Pos := 1; - - -- Check whether the line is blank (i.e., at end of line, page, or file). - - Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line); - - while not UDLA_End_Of_Line loop - - -- Use the Get_Immediate procedure on the file to get access to the - -- next character on the current line. - - Get_Immediate(User_Input_Ptr.all, UDGI_Char, UDGI_Available); - - -- Check that the Available parameter of Get_Immediate was set - -- to indicate that a character was available in the file. - -- Check that the characters returned by both procedures are the - -- same, and they all match the expected character from the file. - - if not UDGI_Available or - UDLA_Char /= TC_String_Ptr_Array(2).all(Char_Pos) or - UDGI_Char /= TC_String_Ptr_Array(2).all(Char_Pos) - then - Report.Failed("Incorrect retrieval of character " & - Integer'Image(Char_Pos) & " of second string"); - end if; - - -- Increment the character position counter. - - Char_Pos := Char_Pos + 1; - - -- Check the next character on the line. If at the end of line, - -- the processing flow will exit the While loop. - - Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line); - - end loop; - - -- Check to ensure that the "end of line" results returned from the - -- Look_Ahead procedure (used to exit the above While loop) corresponds - -- with the result of Function End_Of_Line. - - if not End_Of_Line(User_Defined_Input_File) - then - Report.Failed("Result of procedure Look_Ahead that indicated " & - "being at the end of the line does not correspond " & - "with the result of function End_Of_Line"); - end if; - - -- Check that all characters in the second string were processed. - - if Char_Pos-1 /= TC_String_2'Length then - Report.Failed("Not all of the characters on the second line " & - "were processed"); - end if; - - - Deletion: - begin - -- Delete the user defined file. - - if Is_Open(User_Defined_Input_File) then - Delete(User_Defined_Input_File); - else - Open(User_Defined_Input_File, Out_File, Report.Legal_File_Name(1)); - Delete(User_Defined_Input_File); - end if; - exception - when others => - Report.Failed - ( "Delete not properly implemented for Text_IO" ); - end Deletion; - - - exception - - when No_Reset => - null; - - when Non_Applicable_System => - Report.Not_Applicable("System not capable of supporting external " & - "text files -- Name_Error/Use_Error raised " & - "during text file creation"); - when The_Error : others => - Report.Failed ("The following exception was raised in the " & - "Test_Block: " & Exception_Name(The_Error)); - end Test_Block; - - Report.Result; - -end CXAA017; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a deleted file mode 100644 index 53b16fea498..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a +++ /dev/null @@ -1,277 +0,0 @@ --- CXAA018.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 subprograms defined in the package Text_IO.Modular_IO --- provide correct results. --- --- TEST DESCRIPTION: --- This test checks that the subprograms defined in the --- Ada.Text_IO.Modular_IO package provide correct results. --- A modular type is defined and used to instantiate the generic --- package Ada.Text_IO.Modular_IO. Values of the modular type are --- written to a Text_IO file, and to a series of string variables, using --- different versions of the procedure Put from the instantiated IO --- package. These modular data items are retrieved from the file and --- string variables using the appropriate instantiated version of --- procedure Get. A variety of Base and Width parameter values are --- used in the procedure calls. --- --- APPLICABILITY CRITERIA: --- This test is applicable to all implementations that support Text_IO --- processing and external files. --- --- --- CHANGE HISTORY: --- 03 Jul 95 SAIC Initial prerelease version. --- 01 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- ---! - -with Ada.Text_IO; -with System; -with Report; - -procedure CXAA018 is -begin - - Report.Test ("CXAA018", "Check that the subprograms defined in " & - "the package Text_IO.Modular_IO provide " & - "correct results"); - - Test_for_Text_IO_Support: - declare - Data_File : Ada.Text_IO.File_Type; - Data_Filename : constant String := Report.Legal_File_Name; - begin - - -- An application creates a text file in mode Out_File, with the - -- intention of entering modular data into the file as appropriate. - -- In the event that the particular environment where the application - -- is running does not support Text_IO, Use_Error or Name_Error will be - -- raised on calls to Text_IO operations. Either of these exceptions - -- will be handled to produce a Not_Applicable result. - - Ada.Text_IO.Create (File => Data_File, - Mode => Ada.Text_IO.Out_File, - Name => Data_Filename); - - Test_Block: - declare - - type Mod_Type is mod System.Max_Binary_Modulus; - -- Max_Binary_Modulus must be at least 2**16, which would result - -- in a base range of 0..65535 (zero to one less than the given - -- modulus) for this modular type. - - package Mod_IO is new Ada.Text_IO.Modular_IO(Mod_Type); - use Ada.Text_IO, Mod_IO; - use type Mod_Type; - - Number_Of_Modular_Items : constant := 6; - Number_Of_Error_Items : constant := 1; - - TC_Modular : Mod_Type; - TC_Last_Character_Read : Positive; - - Modular_Array : array (1..Number_Of_Modular_Items) of Mod_Type := - ( 0, 97, 255, 1025, 12097, 65535 ); - - - procedure Load_File (The_File : in out Ada.Text_IO.File_Type) is - begin - -- This procedure does not create, open, or close the data file; - -- The_File file object must be Open at this point. - -- This procedure is designed to load Modular_Type data into a - -- data file. - -- - -- Use the Modular_IO procedure Put to enter modular data items - -- into the data file. - - for i in 1..Number_Of_Modular_Items loop - -- Use default Base parameter of 10. - Mod_IO.Put(File => Data_File, - Item => Modular_Array(i), - Width => 6, - Base => Mod_IO.Default_Base); - end loop; - - -- Enter data into the file such that on the corresponding "Get" - -- of this data, Data_Error must be raised. This value is outside - -- the base range of Modular_Type. - -- Text_IO is used to enter the value in the file. - - for i in 1..Number_Of_Error_Items loop - Ada.Text_IO.Put(The_File, "-10"); - end loop; - - end Load_File; - - - - procedure Process_File(The_File : in out Ada.Text_IO.File_Type) is - begin - -- This procedure does not create, open, or close the data file; - -- The_File file object must be Open at this point. - -- Use procedure Get (for Files) to extract the modular data from - -- the Text_IO file. - - for i in 1..Number_Of_Modular_Items loop - Mod_IO.Get(The_File, TC_Modular, Width => 6); - - if TC_Modular /= Modular_Array(i) then - Report.Failed("Incorrect modular data read from file " & - "data item #" & Integer'Image(i)); - end if; - end loop; - - -- The final item in the Data_File is a modular value that is - -- outside the base range 0..Num'Last. This value should raise - -- Data_Error on an attempt to "Get" it from the file. - - for i in 1..Number_Of_Error_Items loop - begin - Mod_IO.Get(The_File, TC_Modular, Mod_IO.Default_Width); - Report.Failed - ("Exception Data_Error not raised when Get " & - "was used to read modular data outside base " & - "range of type, item # " & - Integer'Image(i)); - exception - when Ada.Text_IO.Data_Error => - null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised when Get " & - "was used to read modular data outside " & - "base range of type from Data_File, " & - "data item #" & Integer'Image(i)); - end; - end loop; - - exception - when others => - Report.Failed - ("Unexpected exception raised in Process_File"); - end Process_File; - - - - begin -- Test_Block. - - -- Place modular values into data file. - - Load_File(Data_File); - Ada.Text_IO.Close(Data_File); - - -- Read modular values from data file. - - Ada.Text_IO.Open(Data_File, Ada.Text_IO.In_File, Data_Filename); - Process_File(Data_File); - - -- Verify versions of Modular_IO procedures Put and Get for Strings. - - Modular_IO_in_Strings: - declare - TC_String_Array : array (1..Number_Of_Modular_Items) - of String(1..30) := (others =>(others => ' ')); - begin - - -- Place modular values into strings using the Procedure Put, - -- Use a variety of different "Base" parameter values. - -- Note: This version of Put uses the length of the given - -- string as the value of the "Width" parameter. - - for i in 1..2 loop - Mod_IO.Put(To => TC_String_Array(i), - Item => Modular_Array(i), - Base => Mod_IO.Default_Base); - end loop; - for i in 3..4 loop - Mod_IO.Put(TC_String_Array(i), - Modular_Array(i), - Base => 2); - end loop; - for i in 5..6 loop - Mod_IO.Put(TC_String_Array(i), Modular_Array(i), 16); - end loop; - - -- Get modular values from strings using the Procedure Get. - -- Compare with expected modular values. - - for i in 1..Number_Of_Modular_Items loop - - Mod_IO.Get(From => TC_String_Array(i), - Item => TC_Modular, - Last => TC_Last_Character_Read); - - if TC_Modular /= Modular_Array(i) then - Report.Failed("Incorrect modular data value obtained " & - "from String following use of Procedures " & - "Put and Get from Strings, Modular_Array " & - "item #" & Integer'Image(i)); - end if; - end loop; - - exception - when others => - Report.Failed("Unexpected exception raised during the " & - "evaluation of Put and Get for Strings"); - end Modular_IO_in_Strings; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - -- Delete the external file. - if Ada.Text_IO.Is_Open(Data_File) then - Ada.Text_IO.Delete(Data_File); - else - Ada.Text_IO.Open(Data_File, - Ada.Text_IO.In_File, - Data_Filename); - Ada.Text_IO.Delete(Data_File); - end if; - - exception - - -- Since Use_Error can be raised if, for the specified mode, - -- the environment does not support Text_IO operations, the - -- following handlers are included: - - when Ada.Text_IO.Use_Error => - Report.Not_Applicable ("Use_Error raised on Text_IO Create"); - - when Ada.Text_IO.Name_Error => - Report.Not_Applicable ("Name_Error raised on Text_IO Create"); - - when others => - Report.Failed ("Unexpected exception raised on text file Create"); - - end Test_for_Text_IO_Support; - - Report.Result; - -end CXAA018; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a deleted file mode 100644 index 04c257e97b6..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a +++ /dev/null @@ -1,138 +0,0 @@ --- CXAA019.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 Standard_Output can be flushed. Check that 'in' parameters of --- types Ada.Text_IO.File_Type and Ada.Streams.Stream_IO.File_Type can be --- flushed. (Defect Report 8652/0051). --- --- CHANGE HISTORY: --- 12 FEB 2001 PHL Initial version --- 16 MAR 2001 RLB Readied for release; fixed Not_Applicable check --- to terminate test gracefully. --- ---! -with Ada.Streams.Stream_Io; -use Ada.Streams; -with Ada.Text_Io; -with Ada.Wide_Text_Io; -with Report; -use Report; -procedure CXAA019 is - - procedure Check (File : in Ada.Text_Io.File_Type) is - begin - Ada.Text_Io.Put_Line - (File, " - CXAA019 About to flush a Text_IO file passed " & - "as 'in' parameter"); - Ada.Text_Io.Flush (File); - end Check; - - procedure Check (File : in Ada.Wide_Text_Io.File_Type) is - begin - Ada.Wide_Text_Io.Put_Line - (File, " - CXAA019 About to flush a Wide_Text_IO file passed " & - "as 'in' parameter"); - Ada.Wide_Text_Io.Flush (File); - end Check; - - procedure Check (File : in Stream_Io.File_Type) is - S : Stream_Element_Array (1 .. 10); - begin - for I in S'Range loop - S (I) := Stream_Element (Character'Pos ('A') + I); - end loop; - Stream_Io.Write (File, S); - Comment ("About to flush a Stream_IO file passed as 'in' parameter"); - Stream_Io.Flush (File); - end Check; - - -begin - Test ("CXAA019", - "Check that Standard_Output can be flushed; check that " & - "'in' Ada.Text_IO.File_Type and Ada.Streams.Stream_IO.File_Type" & - "parameters can be flushed"); - - Ada.Text_Io.Put_Line (Ada.Text_Io.Standard_Output, - " - CXAA019 About to flush Standard_Output"); - Ada.Text_Io.Flush (Ada.Text_Io.Standard_Output); - - Check (Ada.Text_Io.Current_Output); - - declare - TC_OK : Boolean := False; - F : Ada.Text_Io.File_Type; - begin - begin - Ada.Text_Io.Create (F, Name => Legal_File_Name (X => 1)); - TC_OK := True; - exception - when others => - Not_Applicable ("Unable to create Out mode Text_IO file"); - end; - if TC_OK then - Check (F); - Ada.Text_Io.Delete (F); - end if; - end; - - declare - TC_OK : Boolean := False; - F : Ada.Wide_Text_Io.File_Type; - begin - begin - Ada.Wide_Text_Io.Create (F, Name => Legal_File_Name (X => 2)); - TC_OK := True; - exception - when others => - Not_Applicable ("Unable to create Out mode Wide_Text_IO file"); - end; - if TC_OK then - Check (F); - Ada.Wide_Text_Io.Delete (F); - end if; - end; - - declare - TC_OK : Boolean := False; - F : Stream_Io.File_Type; - begin - begin - Stream_Io.Create (F, Name => Legal_File_Name (X => 3)); - TC_OK := True; - exception - when others => - Not_Applicable ("Unable to create Out mode Stream_IO file"); - end; - if TC_OK then - Check (F); - Stream_Io.Delete (F); - end if; - end; - - Result; -end CXAA019; - diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxab001.a b/gcc/testsuite/ada/acats/tests/cxa/cxab001.a deleted file mode 100644 index 483acd16cb2..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxab001.a +++ /dev/null @@ -1,272 +0,0 @@ --- CXAB001.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 operations defined in package Wide_Text_IO allow for --- the input/output of Wide_Character and Wide_String data. --- --- TEST DESCRIPTION: --- This test is designed to exercise the components of the Wide_Text_IO --- package, including the Put/Get utilities for Wide_Characters and --- Wide_String objects. --- The test utilizes the Put and Get procedures defined for --- Wide_Characters, as well as the Put, Get, Put_Line, and Get_Line --- procedures defined for Wide_Strings. In addition, many of the --- additional subprograms found in package Wide_Text_IO are used in this --- test. --- --- APPLICABILITY CRITERIA: --- This test is applicable to all implementations capable of supporting --- external Wide_Text_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 26 Feb 97 CTA.PWB Allowed for non-support of some IO operations. ---! - -with Ada.Wide_Text_IO; -with Report; - -procedure CXAB001 is - - Filter_File : Ada.Wide_Text_IO.File_Type; - Filter_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAB001" ); - Incomplete : exception; - - -begin - - Report.Test ("CXAB001", "Check that the operations defined in package " & - "Wide_Text_IO allow for the input/output of " & - "Wide_Character and Wide_String data"); - - - Test_for_Wide_Text_IO_Support: - begin - - -- An implementation that does not support Wide_Text_IO in a particular - -- environment will raise Use_Error on calls to various - -- Wide_Text_IO operations. This block statement encloses a call to - -- Create, which should raise an exception in a non-supportive - -- environment. This exception will be handled to produce a - -- Not_Applicable result. - - Ada.Wide_Text_IO.Create (File => Filter_File, -- Create. - Mode => Ada.Wide_Text_IO.Out_File, - Name => Filter_Filename); - - exception - - when Ada.Wide_Text_IO.Use_Error | Ada.Wide_Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Wide_Text_IO" ); - raise Incomplete; - - end Test_for_Wide_Text_IO_Support; - - Operational_Test_Block: - declare - - First_String : constant Wide_String := "Somewhere "; - Second_String : constant Wide_String := "Over The "; - Third_String : constant Wide_String := "Rainbow"; - Current_Char : Wide_Character := ' '; - - begin - - Enter_Data_In_File: - declare - Pos : Natural := 1; - Bad_Character_Found : Boolean := False; - begin - -- Use the Put procedure defined for Wide_Character data to - -- write all of the wide characters of the First_String into - -- the file individually, followed by a call to New_Line. - - while Pos <= First_String'Length loop - Ada.Wide_Text_IO.Put (Filter_File, First_String (Pos)); -- Put. - Pos := Pos + 1; - end loop; - Ada.Wide_Text_IO.New_Line (Filter_File); -- New_Line. - - -- Reset to In_File mode and read file contents, using the Get - -- procedure defined for Wide_Character data. - Reset1: - begin - Ada.Wide_Text_IO.Reset (Filter_File, -- Reset. - Ada.Wide_Text_IO.In_File); - exception - when Ada.Wide_Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Wide_Text_IO" ); - raise Incomplete; - end Reset1; - - Pos := 1; - while Pos <= First_String'Length loop - Ada.Wide_Text_IO.Get (Filter_File, Current_Char); -- Get. - -- Verify the wide character against the original string. - if Current_Char /= First_String(Pos) then - Bad_Character_Found := True; - end if; - Pos := Pos + 1; - end loop; - - if Bad_Character_Found then - Report.Failed ("Incorrect Wide_Character read from file - 1"); - end if; - - -- Following user file/string processing, the Wide_String data - -- of the Second_String and Third_String Wide_String objects are - -- appended to the file. - -- The Put procedure defined for Wide_String data is used to - -- transfer the Second_String, followed by a call to New_Line. - -- The Put_Line procedure defined for Wide_String data is used - -- to transfer the Third_String. - Reset2: - begin - Ada.Wide_Text_IO.Reset (Filter_File, -- Reset. - Ada.Wide_Text_IO.Append_File); - - exception - when Ada.Wide_Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Append_File not supported for Wide_Text_IO" ); - raise Incomplete; - end Reset2; - - Ada.Wide_Text_IO.Put (Filter_File, Second_String); -- Put. - Ada.Wide_Text_IO.New_Line (Filter_File); -- New_Line. - - Ada.Wide_Text_IO.Put_Line (Filter_File, Third_String); -- Put_Line. - Ada.Wide_Text_IO.Close (Filter_File); -- Close. - - exception - - when Incomplete => - raise; - - when others => - Report.Failed ("Exception in Enter_Data_In_File block"); - raise; - - end Enter_Data_In_File; - - --- - - Filter_Block: - declare - - Pos : Positive := 1; - TC_String2 : Wide_String (1..Second_String'Length); - TC_String3 : Wide_String (1..Third_String'Length); - Last : Natural := Natural'First; - - begin - - Ada.Wide_Text_IO.Open (Filter_File, -- Open. - Ada.Wide_Text_IO.In_File, - Filter_Filename); - - - -- Read the data of the First_String from the file, using the - -- Get procedure defined for Wide_Character data. - -- Verify that the character corresponds to the data originally - -- written to the file. - - while Pos <= First_String'Length loop - Ada.Wide_Text_IO.Get (Filter_File, Current_Char); -- Get. - if Current_Char /= First_String(Pos) then - Report.Failed - ("Incorrect Wide_Character read from file - 2"); - end if; - Pos := Pos + 1; - end loop; - - -- The first line of the file has been read, move to the second. - Ada.Wide_Text_IO.Skip_Line (Filter_File); -- Skip_Line. - - -- Read the Wide_String data from the second and third lines of - -- the file. - Ada.Wide_Text_IO.Get (Filter_File, TC_String2); -- Get. - Ada.Wide_Text_IO.Skip_Line (Filter_File); -- Skip_Line. - Ada.Wide_Text_IO.Get_Line (Filter_File, -- Get_Line. - TC_String3, Last); - - -- Verify data of second and third strings. - if TC_String2 /= Second_String then - Report.Failed ("Incorrect Wide_String read from file - 1"); - end if; - if TC_String3 /= Third_String then - Report.Failed ("Incorrect Wide_String read from file - 2"); - end if; - - -- The file should now be at EOF. - if not Ada.Wide_Text_IO.End_Of_File (Filter_File) then -- EOF. - Report.Failed ("File not empty following filtering"); - end if; - - exception - when others => - Report.Failed ("Exception in Filter_Block"); - raise; - end Filter_Block; - - exception - - when Incomplete => - raise; - when others => - Report.Failed ("Exception raised in Operational Test Block"); - - end Operational_Test_Block; - - Deletion: - begin - if Ada.Wide_Text_IO.Is_Open (Filter_File) then -- Is_Open. - Ada.Wide_Text_IO.Delete (Filter_File); -- Delete. - else - Ada.Wide_Text_IO.Open (Filter_File, -- Open. - Ada.Wide_Text_IO.Out_File, - Filter_Filename); - Ada.Wide_Text_IO.Delete (Filter_File); -- Delete. - end if; - exception - when others => - Report.Failed ("Delete not properly implemented for Wide_Text_IO"); - end Deletion; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAB001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac001.a b/gcc/testsuite/ada/acats/tests/cxa/cxac001.a deleted file mode 100644 index a77d561f5d6..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxac001.a +++ /dev/null @@ -1,292 +0,0 @@ --- CXAC001.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 attribute T'Write will, for any specific non-limited --- type T, write an item of the subtype to the stream. --- --- Check that the attribute T'Read will, for a specific non-limited --- type T, read a value of the subtype from the stream. --- --- TEST DESCRIPTION: --- The scenario depicted in this test is that of an environment where --- product data is stored in stream form, then reconstructed into the --- appropriate data structures. Several records of product information --- are stored in an array; the array is passed as a parameter to a --- procedure for storage in the stream. A header is created based on the --- number of data records stored in the array. The header is then written --- to the stream, followed by each record maintained in the array. --- In order to retrieve data from the stream, the header information is --- read from the stream, and the data stored in the header is used to --- perform the appropriate number of read operations of record data from --- the stream. All data read from the stream is validated against the ---- values that were written to the stream. --- --- APPLICABILITY CRITERIA: --- Applicable to all systems capable of supporting IO operations on --- external Stream_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 08 Nov 95 SAIC Corrected call to Read in Procedure Retrieve_Data --- for ACVC 2.0.1. --- 27 Feb 08 PWB.CTA Allowed for non-support of certain IO operations. ---! - -with Ada.Streams.Stream_IO; -with Report; - -procedure CXAC001 is - - package Strm_Pack renames Ada.Streams.Stream_IO; - The_File : Strm_Pack.File_Type; - The_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAC001" ); - Incomplete : exception; - - -begin - - Report.Test ("CXAC001", "Check that the 'Read and 'Write attributes " & - "will transfer an object of a specific, " & - "non-limited type to/from a stream"); - - Test_for_Stream_IO_Support: - begin - - -- If an implementation does not support Stream_IO in a particular - -- environment, the exception Use_Error or Name_Error will be raised on - -- calls to various Stream_IO operations. This block statement - -- encloses a call to Create, which should produce an exception in a - -- non-supportive environment. These exceptions will be handled to - -- produce a Not_Applicable result. - - Strm_Pack.Create (The_File, Strm_Pack.Out_File, The_Filename); - - exception - - when Ada.Streams.Stream_IO.Use_Error | - Ada.Streams.Stream_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Stream_IO" ); - raise Incomplete; - - end Test_for_Stream_IO_Support; - - Operational_Test_Block: - declare - - The_Stream : Strm_Pack.Stream_Access; - Todays_Date : String (1 .. 6) := "271193"; - - type ID_Type is range 1 .. 100; - type Size_Type is (Small, Medium, Large, XLarge); - - type Header_Type is record - Number_of_Elements : Natural := 0; - Origination_Date : String (1 .. 6); - end record; - - type Data_Type is record - ID : ID_Type; - Size : Size_Type; - end record; - - type Data_Array_Type is array (Positive range <>) of Data_Type; - - Product_Information_1 : Data_Array_Type (1 .. 3) := ((20, Large), - (55, Small), - (89, XLarge)); - - Product_Information_2 : Data_Array_Type (1 .. 4) := (( 5, XLarge), - (27, Small), - (79, Medium), - (93, XLarge)); - - procedure Store_Data ( The_Stream : in Strm_Pack.Stream_Access; - The_Array : in Data_Array_Type ) is - Header : Header_Type; - begin - - -- Fill in header info. - Header.Number_of_Elements := The_Array'Length; - Header.Origination_Date := Todays_Date; - - -- Write header to stream. - Header_Type'Write (The_Stream, Header); - - -- Write each record in the array to the stream. - for I in 1 .. Header.Number_of_Elements loop - Data_Type'Write (The_Stream, The_Array (I)); - end loop; - - end Store_Data; - - procedure Retrieve_Data (The_Stream : in Strm_Pack.Stream_Access; - The_Header : out Header_Type; - The_Array : out Data_Array_Type ) is - begin - - -- Read header from the stream. - Header_Type'Read (The_Stream, The_Header); - - -- Read the records from the stream into the array. - for I in 1 .. The_Header.Number_of_Elements loop - Data_Type'Read (The_Stream, The_Array (I)); - end loop; - - end Retrieve_Data; - - begin - - -- Assign access value. - The_Stream := Strm_Pack.Stream (The_File); - - -- Product information is to be stored in the stream file. These - -- data arrays are of different sizes (actually, the records - -- are stored individually, not as a single array). Prior to the - -- record data being written, a header record is initialized with - -- information about the data to be written, then itself is written - -- to the stream. - - Store_Data (The_Stream, Product_Information_1); - Store_Data (The_Stream, Product_Information_2); - - Test_Verification_Block: - declare - Product_Header_1 : Header_Type; - Product_Header_2 : Header_Type; - Product_Array_1 : Data_Array_Type (1 .. 3); - Product_Array_2 : Data_Array_Type (1 .. 4); - begin - - Reset1: - begin - Strm_Pack.Reset (The_File, Strm_Pack.In_File); - exception - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Stream_IO" ); - raise Incomplete; - end Reset1; - - -- Data is read from the stream, first the appropriate header, - -- then the associated data records, which are then reconstructed - -- into a data array of product information. - - Retrieve_Data (The_Stream, Product_Header_1, Product_Array_1); - - -- Validate a field in the header. - if (Product_Header_1.Origination_Date /= Todays_Date) or - (Product_Header_1.Number_of_Elements /= 3) - then - Report.Failed ("Incorrect Header_1 info read from stream"); - end if; - - -- Validate the data records read from the file. - for I in 1 .. Product_Header_1.Number_of_Elements loop - if (Product_Array_1(I) /= Product_Information_1(I)) then - Report.Failed ("Incorrect Product 1 info read from" & - " record: " & Integer'Image (I)); - end if; - end loop; - - -- Repeat this read and verify operation for the next parcel of - -- data. Again, header and data record information are read from - -- the same stream file. - Retrieve_Data (The_Stream, Product_Header_2, Product_Array_2); - - if (Product_Header_2.Origination_Date /= Todays_Date) or - (Product_Header_2.Number_of_Elements /= 4) - then - Report.Failed ("Incorrect Header_2 info read from stream"); - end if; - - for I in 1 .. Product_Header_2.Number_of_Elements loop - if (Product_Array_2(I) /= Product_Information_2(I)) then - Report.Failed ("Incorrect Product_2 info read from" & - " record: " & Integer'Image (I)); - end if; - end loop; - - exception - - when Incomplete => - raise; - - when Strm_Pack.End_Error => -- If correct number of - -- items not in file (data - -- overwritten), then fail. - Report.Failed ("Incorrect number of record elements in file"); - if not Strm_Pack.Is_Open (The_File) then - Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename); - end if; - - when others => - Report.Failed ("Exception raised in Data Verification Block"); - if not Strm_Pack.Is_Open (The_File) then - Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename); - end if; - - end Test_Verification_Block; - - exception - - when Incomplete => - raise; - - when others => - Report.Failed ("Exception raised in Operational Test Block"); - - end Operational_Test_Block; - - Deletion: - begin - -- Delete the file. - if Strm_Pack.Is_Open (The_File) then - Strm_Pack.Delete (The_File); - else - Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename); - Strm_Pack.Delete (The_File); - end if; - - exception - - when others => - Report.Failed - ( "Delete not properly implemented for Stream_IO" ); - end Deletion; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAC001; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac002.a b/gcc/testsuite/ada/acats/tests/cxa/cxac002.a deleted file mode 100644 index e4b303c4bc9..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxac002.a +++ /dev/null @@ -1,426 +0,0 @@ --- CXAC002.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 subprograms defined in package Ada.Streams.Stream_IO --- are accessible, and that they provide the appropriate functionality. --- --- TEST DESCRIPTION: --- This test simulates a user filter designed to capitalize the --- characters of a string. It utilizes a variety of the subprograms --- contained in the package Ada.Streams.Stream_IO. --- Its purpose is to demonstrate the use of a variety of the capabilities --- found in the Ada.Streams.Stream_IO package. --- --- APPLICABILITY CRITERIA: --- This test is applicable to all implementations capable of supporting --- external Stream_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 14 Nov 95 SAIC Corrected visibility problems; corrected --- subtest validating result from function Name --- for ACVC 2.0.1. --- 05 Oct 96 SAIC Removed calls to Close/Open in test and replaced --- them with a single call to Reset (per AI95-0001) --- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations. --- 09 Feb 01 RLB Corrected non-support check to avoid unintended --- failures. ---! - -package CXAC002_0 is - - -- This function searches for the first instance of a specified substring - -- within a specified string, returning boolean result. (Case insensitive - -- analysis) - - function Find (Str : in String; Sub : in String) return Boolean; - -end CXAC002_0; - -package body CXAC002_0 is - - function Find (Str : in String; Sub : in String) return Boolean is - - New_Str : String(Str'First..Str'Last); - New_Sub : String(Sub'First..Sub'Last); - Pos : Integer := Str'First; -- Character index. - - function Upper_Case (Str : in String) return String is - subtype Upper is Character range 'A'..'Z'; - subtype Lower is Character range 'a'..'z'; - Ret : String(Str'First..Str'Last); - Pos : Integer; - begin - for I in Str'Range loop - if (Str(I) in Lower) then - Pos := Upper'Pos(Upper'First) + - (Lower'Pos(Str(I)) - Lower'Pos(Lower'First)); - Ret(I) := Upper'Val(Pos); - else - Ret(I) := Str (I); - end if; - end loop; - return Ret; - end Upper_Case; - - begin - - New_Str := Upper_Case(Str); -- Convert Str and Sub to upper - New_Sub := Upper_Case(Sub); -- case for comparison. - - while (Pos <= New_Str'Last-New_Sub'Length+1) -- Search until no more - and then -- sub-string-length - (New_Str(Pos..Pos+New_Sub'Length-1) /= New_Sub) -- slices remain. - loop - Pos := Pos + 1; - end loop; - - if (Pos > New_Str'Last-New_Sub'Length+1) then -- Substring not found. - return False; - else - return True; - end if; - - end Find; - -end CXAC002_0; - - -with Ada.Streams.Stream_IO, CXAC002_0, Report; -procedure CXAC002 is - Filter_File : Ada.Streams.Stream_IO.File_Type; - Filter_Stream : Ada.Streams.Stream_IO.Stream_Access; - Filter_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAC002" ); - Incomplete : Exception; - -begin - - Report.Test ("CXAC002", "Check that the subprograms defined in " & - "package Ada.Streams.Stream_IO are accessible, " & - "and that they provide the appropriate " & - "functionality"); - - Test_for_Stream_IO_Support: - - begin - - -- If an implementation does not support Stream_IO in a particular - -- environment, the exception Use_Error or Name_Error will be raised on - -- calls to various Stream_IO operations. This block statement - -- encloses a call to Create, which should produce an exception in a - -- non-supportive environment. These exceptions will be handled to - -- produce a Not_Applicable result. - - Ada.Streams.Stream_IO.Create (Filter_File, -- Create. - Ada.Streams.Stream_IO.Out_File, - Filter_Filename); - exception - - when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Stream_IO" ); - raise Incomplete; - - end Test_for_Stream_IO_Support; - - Operational_Test_Block: - declare - - use CXAC002_0; - use type Ada.Streams.Stream_IO.File_Mode; - use type Ada.Streams.Stream_IO.Count; - - File_Size : Ada.Streams.Stream_IO.Count := -- Count. - Ada.Streams.Stream_IO.Count'First; -- (0) - File_Index : Ada.Streams.Stream_IO.Positive_Count := -- Pos. Count. - Ada.Streams.Stream_IO.Positive_Count'First; -- (1) - - First_String : constant String := "this is going to be "; - Second_String : constant String := "the best year of your life"; - Total_Length : constant Natural := First_String'Length + - Second_String'Length; - Current_Char : Character := ' '; - - Cap_String : String (1..Total_Length) := (others => ' '); - - TC_Capital_String : constant String := - "THIS IS GOING TO BE THE BEST YEAR OF YOUR LIFE"; - - begin - - if not Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open - Report.Failed ("File not open following Create"); - end if; - - -- Call function Find to determine if the filename (Sub) is contained - -- in the result of Function Name. - - if not Find(Str => Ada.Streams.Stream_IO.Name(Filter_File), -- Name. - Sub => Filter_Filename) - then - Report.Failed ("Function Name provided incorrect filename"); - end if; - -- Stream. - Filter_Stream := Ada.Streams.Stream_IO.Stream (Filter_File); - - --- - - Enter_Data_In_Stream: - declare - Pos : Natural := 1; - Bad_Character_Found : Boolean := False; - begin - - -- Enter data from the first string into the stream. - while Pos <= Natural(First_String'Length) loop - -- Write all characters of the First_String to the stream. - Character'Write (Filter_Stream, First_String (Pos)); - Pos := Pos + 1; - -- Ensure data put in file on a regular basis. - if Pos mod 5 = 0 then - Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush. - end if; - end loop; - - Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush. - -- Reset to In_File mode and read stream contents. - Reset1: - begin - Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset. - Ada.Streams.Stream_IO.In_File); - exception - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Stream_IO" ); - raise Incomplete; - end Reset1; - - Pos := 1; - while Pos <= First_String'Length loop - -- Read one character from the stream. - Character'Read (Filter_Stream, Current_Char); -- 'Read - -- Verify character against the original string. - if Current_Char /= First_String(Pos) then - Bad_Character_Found := True; - end if; - Pos := Pos + 1; - end loop; - - if Bad_Character_Found then - Report.Failed ("Incorrect character read from stream"); - end if; - - -- Following user stream/string processing, the stream file is - -- appended to as follows: - - Reset2: - begin - Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset. - Ada.Streams.Stream_IO.Append_File); - exception - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Append_File not supported for Stream_IO" ); - raise Incomplete; - end Reset2; - - if Ada.Streams.Stream_IO.Mode (Filter_File) /= -- Mode. - Ada.Streams.Stream_IO.Append_File - then - Report.Failed ("Incorrect mode following Reset to Append"); - end if; - - Pos := 1; - while Pos <= Natural(Second_String'Length) loop - -- Write all characters of the Second_String to the stream. - Character'Write (Filter_Stream, Second_String (Pos)); -- 'Write - Pos := Pos + 1; - end loop; - - Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush. - - -- Record file statistics. - File_Size := Ada.Streams.Stream_IO.Size (Filter_File); -- Size. - - Index_Might_Not_Be_Supported: - begin - File_Index := Ada.Streams.Stream_IO.Index (Filter_File); -- Index. - exception - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable ( "Index not supported for Stream_IO" ); - raise Incomplete; - end Index_Might_Not_Be_Supported; - - exception - when Incomplete => - raise; - when others => - Report.Failed ("Exception in Enter_Data_In_Stream block"); - raise; - end Enter_Data_In_Stream; - - --- - - Filter_Block: - declare - Pos : Positive := 1; - Full_String : constant String := First_String & Second_String; - - function Capitalize (Char : Character) return Character is - begin - if Char /= ' ' then - return Character'Val( Character'Pos(Char) - - (Character'Pos('a') - Character'Pos('A'))); - else - return Char; - end if; - end Capitalize; - - begin - - Reset3: - begin - Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset. - Ada.Streams.Stream_IO.In_File); - exception - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Stream_IO" ); - raise Incomplete; - end Reset3; - - if Ada.Streams.Stream_IO.Mode (Filter_File) /= -- Mode. - Ada.Streams.Stream_IO.In_File - then - Report.Failed ("Incorrect mode following Reset to In_File"); - end if; - - if not Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open - Report.Failed ( "Reset command did not leave file open" ); - end if; - - if Ada.Streams.Stream_IO.Size (Filter_File) /= -- Size. - File_Size - then - Report.Failed ("Reset file is not correct size"); - end if; - - if Ada.Streams.Stream_IO.Index (Filter_File) /= 1 then -- Index. - -- File position should have been reset to start of file. - Report.Failed ("Index of file not set to 1 following Reset"); - end if; - - while Pos <= Full_String'Length loop - -- Read one character from the stream. - Character'Read (Filter_Stream, Current_Char); -- 'Read - -- Verify character against the original string. - if Current_Char /= Full_String(Pos) then - Report.Failed ("Incorrect character read from stream"); - else - -- Capitalize the characters read from the stream, and - -- place them in a string variable. - Cap_String(Pos) := Capitalize (Current_Char); - end if; - Pos := Pos + 1; - end loop; - - -- File index should now be set to the position following the final - -- character in the file (the same as the index value stored at - -- the completion of the Enter_Data_In_Stream block). - if Ada.Streams.Stream_IO.Index (Filter_File) /= -- Index. - File_Index - then - Report.Failed ("Incorrect file index position"); - end if; - - -- The stream file should now be at EOF. -- EOF. - if not Ada.Streams.Stream_IO.End_Of_File (Filter_File) then - Report.Failed ("File not empty following filtering"); - end if; - - exception - - when Incomplete => - raise; - when others => - Report.Failed ("Exception in Filter_Block"); - raise; - end Filter_Block; - - --- - - Verification_Block: - begin - - -- Verify that the entire string was examined, and that the - -- process of capitalizing the character data was successful. - if Cap_String /= TC_Capital_String then - Report.Failed ("Incorrect Capitalization"); - end if; - - exception - when others => - Report.Failed ("Exception in Verification_Block"); - end Verification_Block; - - - exception - - when Incomplete => - raise; - when others => - Report.Failed ("Exception raised in Operational Test Block"); - - end Operational_Test_Block; - - Deletion: - begin - if Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open. - Ada.Streams.Stream_IO.Delete (Filter_File); -- Delete. - else - Ada.Streams.Stream_IO.Open (Filter_File, -- Open. - Ada.Streams.Stream_IO.Out_File, - Filter_Filename); - Ada.Streams.Stream_IO.Delete (Filter_File); -- Delete. - end if; - exception - when others => - Report.Failed - ( "Delete not properly implemented for Stream_IO" ); - end Deletion; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAC002; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac003.a b/gcc/testsuite/ada/acats/tests/cxa/cxac003.a deleted file mode 100644 index cc1e044d0a2..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxac003.a +++ /dev/null @@ -1,376 +0,0 @@ --- CXAC003.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 correct exceptions are raised when improperly --- manipulating stream file objects. --- --- TEST DESCRIPTION: --- This test is designed to focus on Stream_IO file manipulation --- exceptions. Several potentially common user errors are examined in --- the test: --- --- A Status_Error should be raised whenever an attempt is made to perform --- an operation on a file that is closed. --- --- A Status_Error should be raised when an attempt is made to open a --- stream file that is currently open. --- --- A Mode_Error should be raised when attempting to read from (use the --- 'Read attribute) on an Out_File or Append_Mode file. --- --- A Mode_Error should be raised when checking for End Of File on a --- file with mode Out_File or Append_Mode. --- --- A Mode_Error should be raised when attempting to write to (use the --- 'Output attribute) on a file with mode In_File. --- --- A Name_Error should be raised when the string provided to the Name --- parameter of an Open operation does not allow association of an --- external file. --- --- APPLICABILITY CRITERIA: --- This test is applicable to all implementations capable of supporting --- external Stream_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations --- 02 Mar 01 PHL Check that Ada.Streams.Stream_IO.Stream raises --- Status_Error if the file is not open. (DR 8652/ --- 0056). --- 15 Mar 01 RLB Readied for release. ---! - -with Ada.Streams.Stream_IO; -with Report; - -procedure CXAC003 is - - Stream_File_Object : Ada.Streams.Stream_IO.File_Type; - Stream_Access_Value : Ada.Streams.Stream_IO.Stream_Access; - Stream_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAC003" ); - Incomplete : exception; - -begin - - Report.Test ("CXAC003", "Check that the correct exceptions are " & - "raised when improperly manipulating stream " & - "file objects"); - - Test_for_Stream_IO_Support: - begin - -- If an implementation does not support Stream_IO in a particular - -- environment, the exception Use_Error or Name_Error will be raised on - -- calls to various Stream_IO operations. This block statement - -- encloses a call to Create, which should produce an exception in a - -- non-supportive environment. These exceptions will be handled to - -- produce a Not_Applicable result. - - Ada.Streams.Stream_IO.Create (Stream_File_Object, - Ada.Streams.Stream_IO.Out_File, - Stream_Filename); - - exception - - when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Stream_IO" ); - raise Incomplete; - - end Test_for_Stream_IO_Support; - - Operational_Test_Block: - begin - -- A potentially common error in a file processing environment - -- is to attempt to perform an operation on a stream file that is - -- not currently open. Status_Error should be raised in this case. - Check_Status_Error: - begin - Ada.Streams.Stream_IO.Close (Stream_File_Object); - -- Attempt to reset a file that is closed. - Ada.Streams.Stream_IO.Reset (Stream_File_Object, - Ada.Streams.Stream_IO.Out_File); - Report.Failed ("Exception not raised on Reset of closed file"); - exception - when Ada.Streams.Stream_IO.Status_Error => - null; - when others => - Report.Failed ("Incorrect exception raised - 1"); - end Check_Status_Error; - - -- A similar error is to use Ada.Streams.Stream_IO.Stream - -- to attempt to perform an operation on a stream file that is - -- not currently open. Status_Error should be raised in this case. - -- (Defect Report 8652/0046, as reflected in Technical Corrigendum 1.) - Check_Status_Error2: - begin - -- Ensure that the file is not open. - if Ada.Streams.Stream_Io.Is_Open (Stream_File_Object) then - Ada.Streams.Stream_Io.Close (Stream_File_Object); - end if; - Stream_Access_Value := - Ada.Streams.Stream_Io.Stream (Stream_File_Object); - Report.Failed ("Exception not raised on Stream of closed file"); - exception - when Ada.Streams.Stream_Io.Status_Error => - null; - when others => - Report.Failed ("Incorrect exception raised - 2"); - end Check_Status_Error2; - - -- Another potentially common error in a file processing environment - -- is to attempt to Open a stream file that is currently open. - -- Status_Error should be raised in this case. - Check_Status_Error3: - begin - -- Ensure that the file is open. - if not Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then - Ada.Streams.Stream_IO.Open (Stream_File_Object, - Ada.Streams.Stream_IO.In_File, - Stream_Filename); - end if; - Ada.Streams.Stream_IO.Open (Stream_File_Object, - Ada.Streams.Stream_IO.In_File, - Stream_Filename); - Report.Failed ("Exception not raised on Open of open file"); - exception - when Ada.Streams.Stream_IO.Status_Error => - null; - when others => - Report.Failed ("Incorrect exception raised - 3"); - end Check_Status_Error3; - - -- Another example of a potential error occurring in a file - -- processing environment is to attempt to use the 'Read attribute - -- on a stream file that is currently in Out_File or Append_File - -- mode. Mode_Error should be raised in both of these cases. - Check_Mode_Error: - declare - Int_Var : Integer := -10; - begin - - Reset1: - begin - Ada.Streams.Stream_IO.Reset (Stream_File_Object, - Ada.Streams.Stream_IO.Out_File); - exception - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Out_File not supported for Stream_IO - 1" ); - raise Incomplete; - end Reset1; - - Stream_Access_Value := - Ada.Streams.Stream_IO.Stream (Stream_File_Object); - Integer'Write (Stream_Access_Value, Int_Var); - - -- File contains an integer value, but is of mode Out_File. - Integer'Read (Stream_Access_Value, Int_Var); - Report.Failed ("Exception not raised by 'Read of Out_File"); - exception - when Incomplete => - raise; - when Ada.Streams.Stream_IO.Mode_Error => - null; - Try_Read: - begin - Reset2: - begin - Ada.Streams.Stream_IO.Reset - (Stream_File_Object, Ada.Streams.Stream_IO.Append_File); - exception - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Append_File not supported " & - "for Stream_IO - 2" ); - raise Incomplete; - end Reset2; - - Integer'Write (Stream_Access_Value, Int_Var); - -- Attempt read from Append_File mode file. - Integer'Read (Stream_Access_Value, Int_Var); - Report.Failed - ("Exception not raised by 'Read of Append file"); - exception - when Incomplete => - null; - when Ada.Streams.Stream_IO.Mode_Error => - null; - when others => - Report.Failed ("Incorrect exception raised - 4b"); - end Try_Read; - - when others => Report.Failed ("Incorrect exception raised - 4a"); - end Check_Mode_Error; - - -- Another example of a this type of potential error is to attempt - -- to check for End Of File on a stream file that is currently in - -- Out_File or Append_File mode. Mode_Error should also be raised - -- in both of these cases. - Check_End_File: - declare - Test_Boolean : Boolean := False; - begin - Reset3: - begin - Ada.Streams.Stream_IO.Reset (Stream_File_Object, - Ada.Streams.Stream_IO.Out_File); - exception - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Out_File not supported for Stream_IO - 3" ); - raise Incomplete; - end Reset3; - - Test_Boolean := - Ada.Streams.Stream_IO.End_Of_File (Stream_File_Object); - Report.Failed ("Exception not raised by EOF on Out_File"); - exception - when Incomplete => - null; - when Ada.Streams.Stream_IO.Mode_Error => - null; - EOF_For_Append_File: - begin - Reset4: - begin - Ada.Streams.Stream_IO.Reset - (Stream_File_Object, Ada.Streams.Stream_IO.Append_File); - exception - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable - ( "Reset to Append_File not supported " & - "for Stream_IO - 4" ); - raise Incomplete; - end Reset4; - - Test_Boolean := - Ada.Streams.Stream_IO.End_Of_File (Stream_File_Object); - Report.Failed - ("Exception not raised by EOF of Append file"); - exception - when Incomplete => - raise; - when Ada.Streams.Stream_IO.Mode_Error => - null; - when others => - Report.Failed ("Incorrect exception raised - 5b"); - end EOF_For_Append_File; - - when others => Report.Failed ("Incorrect exception raised - 5a"); - end Check_End_File; - - - - -- In a similar situation to the above cases for attribute 'Read, - -- an attempt to use the 'Output attribute on a stream file that - -- is currently in In_File mode should result in Mode_Error being - -- raised. - Check_Output_Mode_Error: - begin - Reset5: - begin - Ada.Streams.Stream_IO.Reset (Stream_File_Object, - Ada.Streams.Stream_IO.In_File); - exception - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Stream_IO - 6" ); - raise Incomplete; - end Reset5; - - Stream_Access_Value := - Ada.Streams.Stream_IO.Stream (Stream_File_Object); - String'Output (Stream_Access_Value, "User-Oriented String"); - Report.Failed ("Exception not raised by 'Output to In_File"); - exception - when Incomplete => - null; - when Ada.Streams.Stream_IO.Mode_Error => - null; - when others => - Report.Failed ("Incorrect exception raised - 6"); - end Check_Output_Mode_Error; - - -- Any case of attempting to Open a stream file with a string for - -- the parameter Name that does not allow the identification of an - -- external file will result in the exception Name_Error being - -- raised. - Check_Illegal_File_Name: - begin - if Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then - Ada.Streams.Stream_IO.Close (Stream_File_Object); - end if; - -- No external file exists with this filename, allowing no - -- association with an internal file object, resulting in the - -- raising of the exception Name_Error. - Ada.Streams.Stream_IO.Open(File => Stream_File_Object, - Mode => Ada.Streams.Stream_IO.Out_File, - Name => Report.Legal_File_Name(2)); - Report.Failed ("Exception not raised by bad filename on Open"); - exception - when Ada.Streams.Stream_IO.Name_Error => - null; - when others => - Report.Failed ("Incorrect exception raised - 7"); - end Check_Illegal_File_Name; - - exception - when Incomplete => - null; - when others => - Report.Failed ("Unexpected exception in Operational Test Block"); - - end Operational_Test_Block; - - Deletion: - begin - if Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then - Ada.Streams.Stream_IO.Delete (Stream_File_Object); - else - Ada.Streams.Stream_IO.Open (Stream_File_Object, - Ada.Streams.Stream_IO.Out_File, - Stream_Filename); - Ada.Streams.Stream_IO.Delete (Stream_File_Object); - end if; - exception - when others => - Report.Failed - ( "Delete not properly implemented for Stream_IO" ); - end Deletion; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAC003; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac004.a b/gcc/testsuite/ada/acats/tests/cxa/cxac004.a deleted file mode 100644 index 9cc88b93cfb..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxac004.a +++ /dev/null @@ -1,310 +0,0 @@ --- CXAC004.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 Stream_Access type and Stream function found in package --- Ada.Text_IO.Text_Streams allows a text file to be processed with the --- functionality of streams. --- --- TEST DESCRIPTION: --- This test verifies that the package Ada.Text_IO.Text_Streams is --- available and that the functionality it contains allows a text file to --- be manipulated as a stream. --- The test defines data objects of a variety of types that can be stored --- in a text file. A text file and associated text stream are then --- defined, and the 'Write attribute is used to enter the individual data --- items into the text stream. Once all the individual data items have --- been written to the stream, the 'Output attribute is used to write --- arrays of these same data objects to the stream. --- The text file is reset to serve as an input file, and the 'Read --- attribute is used to extract the individual data items from the --- stream. These items are then verified against the data originally --- written to the stream. Finally, the 'Input attribute is used to --- extract the data arrays from the stream. These arrays are then --- verified against the original data written to the stream. --- --- APPLICABILITY CRITERIA: --- Applicable to implementations that support external text files. --- --- CHANGE HISTORY: --- 06 Jul 95 SAIC Initial prerelease version. --- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations; --- removed requirement for support of decimal types. ---! - -with Report; -with Ada.Text_IO; -with Ada.Text_IO.Text_Streams; -with Ada.Characters.Latin_1; -with Ada.Strings.Unbounded; - -procedure CXAC004 is - - Data_File : Ada.Text_IO.File_Type; - Data_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXAC004" ); - Incomplete : exception; - -begin - - Report.Test ("CXAC004", "Check that the Stream_Access type and Stream " & - "function found in package " & - "Ada.Text_IO.Text_Streams allows a text file to " & - "be processed with the functionality of streams"); - - Test_for_IO_Support: - begin - - -- Check for Text_IO support in creating the data file. If the - -- implementation does not support external files, Name_Error or - -- Use_Error will be raised at the point of the following call to - -- Create, resulting in a Not_Applicable test result. - - Ada.Text_IO.Create(Data_File, Ada.Text_IO.Out_File, Data_Filename); - - exception - - when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Text_IO" ); - raise Incomplete; - - end Test_for_IO_Support; - - Test_Block: - declare - use Ada.Characters.Latin_1, Ada.Strings.Unbounded; - TC_Items : constant := 3; - - -- Declare types and objects that will be used as data values to be - -- written to and read from the text file/stream. - - type Enum_Type is (Red, Yellow, Green, Blue, Indigo); - type Fixed_Type is delta 0.125 range 0.0..255.0; - type Float_Type is digits 7 range 0.0..1.0E5; - type Modular_Type is mod 256; - subtype Str_Type is String(1..4); - - type Char_Array_Type is array (1..TC_Items) of Character; - type Enum_Array_Type is array (1..TC_Items) of Enum_Type; - type Fixed_Array_Type is array (1..TC_Items) of Fixed_Type; - type Float_Array_Type is array (1..TC_Items) of Float_Type; - type Int_Array_Type is array (1..TC_Items) of Integer; - type Mod_Array_Type is array (1..TC_Items) of Modular_Type; - type Str_Array_Type is array (1..TC_Items) of Str_Type; - type Unb_Str_Array_Type is array (1..TC_Items) of Unbounded_String; - - Char_Array : Char_Array_Type := ('A', 'z', Yen_Sign); - TC_Char_Array_1, - TC_Char_Array_2 : Char_Array_Type := (others => Space); - - Enum_Array : Enum_Array_Type := (Blue, Yellow, Indigo); - TC_Enum_Array_1, - TC_Enum_Array_2 : Enum_Array_Type := (others => Red); - - Fix_Array : Fixed_Array_Type := (0.125, 123.5, 250.750); - TC_Fix_Array_1, - TC_Fix_Array_2 : Fixed_Array_Type := (others => 0.0); - - Flt_Array : Float_Array_Type := (1.0, 150.0, 1500.0); - TC_Flt_Array_1, - TC_Flt_Array_2 : Float_Array_Type := (others => 0.0); - - Int_Array : Int_Array_Type := (124, 2349, -24_001); - TC_Int_Array_1, - TC_Int_Array_2 : Int_Array_Type := (others => -99); - - Mod_Array : Mod_Array_Type := (10, 127, 255); - TC_Mod_Array_1, - TC_Mod_Array_2 : Mod_Array_Type := (others => 0); - - Str_Array : Str_Array_Type := ("abcd", "klmn", "wxyz"); - TC_Str_Array_1, - TC_Str_Array_2 : Str_Array_Type := (others => " "); - - UStr_Array : Unb_Str_Array_Type := - (To_Unbounded_String("cat"), - To_Unbounded_String("testing"), - To_Unbounded_String("ACVC")); - TC_UStr_Array_1, - TC_UStr_Array_2 : Unb_Str_Array_Type := - (others => Null_Unbounded_String); - - -- Create a stream access object pointing to the data file. - - Data_Stream : Ada.Text_IO.Text_Streams.Stream_Access := - Ada.Text_IO.Text_Streams.Stream(File => Data_File); - - begin - - -- Use the 'Write attribute to enter the three sets of data items - -- into the data stream. - -- Note that the data will be mixed within the text file. - - for i in 1..TC_Items loop - Character'Write (Data_Stream, Char_Array(i)); - Enum_Type'Write (Data_Stream, Enum_Array(i)); - Fixed_Type'Write (Data_Stream, Fix_Array(i)); - Float_Type'Write (Data_Stream, Flt_Array(i)); - Integer'Write (Data_Stream, Int_Array(i)); - Modular_Type'Write (Data_Stream, Mod_Array(i)); - Str_Type'Write (Data_Stream, Str_Array(i)); - Unbounded_String'Write(Data_Stream, UStr_Array(i)); - end loop; - - -- Use the 'Output attribute to enter the entire arrays of each - -- type of data items into the data stream. - -- Note that the array bounds will be written to the stream as part - -- of the action of the 'Output attribute. - - Char_Array_Type'Output (Data_Stream, Char_Array); - Enum_Array_Type'Output (Data_Stream, Enum_Array); - Fixed_Array_Type'Output (Data_Stream, Fix_Array); - Float_Array_Type'Output (Data_Stream, Flt_Array); - Int_Array_Type'Output (Data_Stream, Int_Array); - Mod_Array_Type'Output (Data_Stream, Mod_Array); - Str_Array_Type'Output (Data_Stream, Str_Array); - Unb_Str_Array_Type'Output (Data_Stream, UStr_Array); - - -- Reset the data file to mode In_File. The data file will now serve - -- as the source of data which will be compared to the original data - -- written to the file above. - Reset1: - begin - Ada.Text_IO.Reset (File => Data_File, Mode => Ada.Text_IO.In_File); - exception - when Ada.Text_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Text_IO" ); - raise Incomplete; - end Reset1; - - -- Extract and validate all the single data items from the stream. - - for i in 1..TC_Items loop - Character'Read (Data_Stream, TC_Char_Array_1(i)); - Enum_Type'Read (Data_Stream, TC_Enum_Array_1(i)); - Fixed_Type'Read (Data_Stream, TC_Fix_Array_1(i)); - Float_Type'Read (Data_Stream, TC_Flt_Array_1(i)); - Integer'Read (Data_Stream, TC_Int_Array_1(i)); - Modular_Type'Read (Data_Stream, TC_Mod_Array_1(i)); - Str_Type'Read (Data_Stream, TC_Str_Array_1(i)); - Unbounded_String'Read (Data_Stream, TC_UStr_Array_1(i)); - end loop; - - if TC_Char_Array_1 /= Char_Array then - Report.Failed("Character values do not match"); - end if; - if TC_Enum_Array_1 /= Enum_Array then - Report.Failed("Enumeration values do not match"); - end if; - if TC_Fix_Array_1 /= Fix_Array then - Report.Failed("Fixed point values do not match"); - end if; - if TC_Flt_Array_1 /= Flt_Array then - Report.Failed("Floating point values do not match"); - end if; - if TC_Int_Array_1 /= Int_Array then - Report.Failed("Integer values do not match"); - end if; - if TC_Mod_Array_1 /= Mod_Array then - Report.Failed("Modular values do not match"); - end if; - if TC_Str_Array_1 /= Str_Array then - Report.Failed("String values do not match"); - end if; - if TC_UStr_Array_1 /= UStr_Array then - Report.Failed("Unbounded_String values do not match"); - end if; - - -- Extract and validate all data arrays from the data stream. - -- Note that the 'Input attribute denotes a function, whereas the - -- other stream oriented attributes in this test denote procedures. - - TC_Char_Array_2 := Char_Array_Type'Input(Data_Stream); - TC_Enum_Array_2 := Enum_Array_Type'Input(Data_Stream); - TC_Fix_Array_2 := Fixed_Array_Type'Input(Data_Stream); - TC_Flt_Array_2 := Float_Array_Type'Input(Data_Stream); - TC_Int_Array_2 := Int_Array_Type'Input(Data_Stream); - TC_Mod_Array_2 := Mod_Array_Type'Input(Data_Stream); - TC_Str_Array_2 := Str_Array_Type'Input(Data_Stream); - TC_UStr_Array_2 := Unb_Str_Array_Type'Input(Data_Stream); - - if TC_Char_Array_2 /= Char_Array then - Report.Failed("Character array values do not match"); - end if; - if TC_Enum_Array_2 /= Enum_Array then - Report.Failed("Enumeration array values do not match"); - end if; - if TC_Fix_Array_2 /= Fix_Array then - Report.Failed("Fixed point array values do not match"); - end if; - if TC_Flt_Array_2 /= Flt_Array then - Report.Failed("Floating point array values do not match"); - end if; - if TC_Int_Array_2 /= Int_Array then - Report.Failed("Integer array values do not match"); - end if; - if TC_Mod_Array_2 /= Mod_Array then - Report.Failed("Modular array values do not match"); - end if; - if TC_Str_Array_2 /= Str_Array then - Report.Failed("String array values do not match"); - end if; - if TC_UStr_Array_2 /= UStr_Array then - Report.Failed("Unbounded_String array values do not match"); - end if; - - exception - when Incomplete => - raise; - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Deletion: - begin - -- Delete the data file. - if not Ada.Text_IO.Is_Open(Data_File) then - Ada.Text_IO.Open(Data_File, Ada.Text_IO.In_File, Data_Filename); - end if; - Ada.Text_IO.Delete(Data_File); - - exception - when others => - Report.Failed - ( "Delete not properly implemented for Text_IO" ); - - end Deletion; - - Report.Result; - -exception - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXAC004; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac005.a b/gcc/testsuite/ada/acats/tests/cxa/cxac005.a deleted file mode 100644 index 34a971f7a51..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxac005.a +++ /dev/null @@ -1,343 +0,0 @@ --- CXAC005.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 stream file positioning work as specified. (Defect Report --- 8652/0055). --- --- CHANGE HISTORY: --- 12 FEB 2001 PHL Initial version. --- 14 MAR 2001 RLB Readied for release; fixed Not_Applicable check --- to terminate test gracefully. --- ---! -with Ada.Streams.Stream_Io; -use Ada.Streams; -with Ada.Exceptions; -use Ada.Exceptions; -with Report; -use Report; -procedure CXAC005 is - - Incomplete : exception; - - procedure TC_Assert (Condition : Boolean; Message : String) is - begin - if not Condition then - Failed (Message); - end if; - end TC_Assert; - - 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; - Name : in String := ""; - Form : in String := ""); - - procedure Open (File : in out File_Type; - Mode : in Stream_Io.File_Mode; - Name : in String; - Form : in String := ""); - - procedure Close (File : in out File_Type); - procedure Delete (File : in out File_Type); - - procedure Reset (File : in out File_Type; - Mode : in Stream_Io.File_Mode); - procedure Reset (File : in out File_Type); - - procedure Read (File : in out File_Type; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset; - From : in Stream_Io.Positive_Count); - - procedure Read (File : in out File_Type; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset); - - procedure Write (File : in out File_Type; - Item : in Stream_Element_Array; - To : in Stream_Io.Positive_Count); - - procedure Write (File : in out File_Type; - Item : in Stream_Element_Array); - - procedure Set_Index (File : in out File_Type; - To : in Stream_Io.Positive_Count); - - function Index (File : in File_Type) return Stream_Io.Positive_Count; - - procedure Set_Mode (File : in out File_Type; - Mode : in Stream_Io.File_Mode); - - private - type File_Type (Max_Size : Stream_Element_Count) is - record - File : Stream_Io.File_Type; - Index : Stream_Io.Positive_Count; - Contents : - Stream_Element_Array - (Stream_Element_Offset (Ident_Int (1)) .. Max_Size); - end record; - end Checked_Stream_Io; - - package body Checked_Stream_Io 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 := ""; - Form : in String := "") is - begin - Stream_Io.Create (File.File, Mode, Name, Form); - File.Index := Stream_Io.Index (File.File); - if Mode = Append_File then - TC_Assert (File.Index = Stream_Io.Size (File.File) + 1, - "Index /= Size + 1 -- Create - Append_File"); - else - TC_Assert (File.Index = 1, "Index /= 1 -- Create - " & - File_Mode'Image (Mode)); - end if; - end Create; - - procedure Open (File : in out File_Type; - Mode : in Stream_Io.File_Mode; - Name : in String; - Form : in String := "") is - begin - Stream_Io.Open (File.File, Mode, Name, Form); - File.Index := Stream_Io.Index (File.File); - if Mode = Append_File then - TC_Assert (File.Index = Stream_Io.Size (File.File) + 1, - "Index /= Size + 1 -- Open - Append_File"); - else - TC_Assert (File.Index = 1, "Index /= 1 -- Open - " & - File_Mode'Image (Mode)); - end if; - end Open; - - procedure Close (File : in out File_Type) is - begin - Stream_Io.Close (File.File); - end Close; - - procedure Delete (File : in out File_Type) is - begin - Stream_Io.Delete (File.File); - end Delete; - - procedure Reset (File : in out File_Type; - Mode : in Stream_Io.File_Mode) is - begin - Stream_Io.Reset (File.File, Mode); - File.Index := Stream_Io.Index (File.File); - if Mode = Append_File then - TC_Assert (File.Index = Stream_Io.Size (File.File) + 1, - "Index /= Size + 1 -- Reset - Append_File"); - else - TC_Assert (File.Index = 1, "Index /= 1 -- Reset - " & - File_Mode'Image (Mode)); - end if; - end Reset; - - procedure Reset (File : in out File_Type) is - begin - Reset (File, Stream_Io.Mode (File.File)); - end Reset; - - - procedure Read (File : in out File_Type; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset; - From : in Stream_Io.Positive_Count) is - begin - Set_Index (File, From); - Read (File, Item, Last); - end Read; - - procedure Read (File : in out File_Type; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset) is - Index : constant Stream_Element_Offset := - Stream_Element_Offset (File.Index); - begin - Stream_Io.Read (File.File, Item, Last); - if Last < Item'Last then - TC_Assert (Item (Item'First .. Last) = - File.Contents (Index .. Index + Last - Item'First), - "Incorrect data read from file - 1"); - TC_Assert (Count (Index + Last - Item'First) = - Stream_Io.Size (File.File), - "Read stopped before end of file"); - File.Index := Count (Index + Last - Item'First) + 1; - else - TC_Assert (Item = File.Contents (Index .. Index + Item'Length - 1), - "Incorrect data read from file - 2"); - File.Index := File.Index + Item'Length; - end if; - end Read; - - procedure Write (File : in out File_Type; - Item : in Stream_Element_Array; - To : in Stream_Io.Positive_Count) is - begin - Set_Index (File, To); - Write (File, Item); - end Write; - - procedure Write (File : in out File_Type; - Item : in Stream_Element_Array) is - Index : constant Stream_Element_Offset := - Stream_Element_Offset (File.Index); - begin - Stream_Io.Write (File.File, Item); - File.Contents (Index .. Index + Item'Length - 1) := Item; - File.Index := File.Index + Item'Length; - TC_Assert (File.Index = Stream_Io.Index (File.File), - "Write failed to move the index"); - end Write; - - procedure Set_Index (File : in out File_Type; - To : in Stream_Io.Positive_Count) is - begin - Stream_Io.Set_Index (File.File, To); - File.Index := Stream_Io.Index (File.File); - TC_Assert (File.Index = To, "Set_Index failed"); - end Set_Index; - - function Index (File : in File_Type) return Stream_Io.Positive_Count is - New_Index : constant Count := Stream_Io.Index (File.File); - begin - TC_Assert (New_Index = File.Index, "Index changed unexpectedly"); - return New_Index; - end Index; - - procedure Set_Mode (File : in out File_Type; - Mode : in Stream_Io.File_Mode) is - Old_Index : constant Count := File.Index; - begin - Stream_Io.Set_Mode (File.File, Mode); - File.Index := Stream_Io.Index (File.File); - if Mode = Append_File then - TC_Assert (File.Index = Stream_Io.Size (File.File) + 1, - "Index /= Size + 1 -- Set_Mode - Append_File"); - else - TC_Assert (File.Index = Old_Index, "Set_Mode changed the index"); - end if; - end Set_Mode; - - end Checked_Stream_Io; - - package Csio renames Checked_Stream_Io; - - F : Csio.File_Type (100); - S : Stream_Element_Array (1 .. 10); - Last : Stream_Element_Offset; - -begin - - Test ("CXAC005", "Check that stream file positioning work as specified"); - - declare - Name : constant String := Legal_File_Name; - begin - begin - Csio.Create (F, Name => Name); - exception - when others => - Not_Applicable ("Files not supported - Creation with Out_File for Stream_IO"); - raise Incomplete; - end; - - for I in Stream_Element range 1 .. 10 loop - Csio.Write (F, ((1 => I + 2))); - end loop; - Csio.Write (F, (1 .. 15 => 11)); - Csio.Write (F, (1 .. 15 => 12), To => 15); - - Csio.Reset (F); - - for I in Stream_Element range 1 .. 10 loop - Csio.Write (F, (1 => I)); - end loop; - Csio.Write (F, (1 .. 15 => 13)); - Csio.Write (F, (1 .. 15 => 14), To => 15); - Csio.Write (F, (1 => 90)); - - Csio.Set_Mode (F, Stream_Io.In_File); - - Csio.Read (F, S, Last); - Csio.Read (F, S, Last, From => 3); - Csio.Read (F, S, Last, From => 28); - - Csio.Set_Mode (F, Stream_Io.Append_File); - Csio.Write (F, (1 .. 5 => 88)); - - Csio.Close (F); - - Csio.Open (F, Name => Name, Mode => Stream_Io.Append_File); - Csio.Write (F, (1 .. 3 => 33)); - - Csio.Set_Mode (F, Stream_Io.In_File); - Csio.Read (F, S, Last, From => 20); - Csio.Read (F, S, Last); - Csio.Reset (F, Stream_Io.Out_File); - - Csio.Write (F, (1 .. 9 => 99)); - - -- Check the contents of the entire file. - declare - S : Stream_Element_Array - (1 .. Stream_Element_Offset - (Stream_Io.Size (Csio.Stream_Io_File (F)))); - begin - Csio.Reset (F, Stream_Io.In_File); - Csio.Read (F, S, Last); - end; - - Csio.Delete (F); - end; - - Result; -exception - when Incomplete => - Report.Result; - when E:others => - Report.Failed ("Unexpected exception raised - " & Exception_Name (E) & - " - " & Exception_Message (E)); - Report.Result; - -end CXAC005; - diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a b/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a deleted file mode 100644 index cda8776a53d..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a +++ /dev/null @@ -1,291 +0,0 @@ --- CXACA01.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 default attributes 'Write and 'Read work properly when --- used with objects of a variety of types, including records with --- default discriminants, records without default discriminants, but --- which have the discriminant described in a representation clause for --- the type, and arrays. --- --- TEST DESCRIPTION: --- This test simulates a basic sales record system, using Stream_IO to --- allow the storage of heterogeneous data in a single stream file. --- --- Four types of data are written to the stream file for each product. --- First, the "header" information on the product is written. --- This is an object of a discriminated (with default) record --- type. This is followed by an integer object containing a count of --- the number of sales data records to follow. The corresponding number --- of sales records follow in the stream. These are of a record type --- with a discriminant without a default, but where the discriminant is --- included in the representation clause for the type. Finally, an --- array object with statistical sales information for the product is --- written to the stream. --- --- Objects of both record types specified below (discriminated records --- with defaults, and discriminated records w/o defaults that have the --- discriminant included in a representation clause for the type) should --- have their discriminants included in the stream when using 'Write. --- Likewise, discriminants should be extracted from the stream when --- using 'Read. --- --- APPLICABILITY CRITERIA: --- Applicable to all implementations that support external --- Stream_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with FXACA00; -with Ada.Streams.Stream_IO; -with Report; - -procedure CXACA01 is - -begin - - Report.Test ("CXACA01", "Check that 'Write and 'Read work properly " & - "when used with complex data types"); - - Test_for_Stream_IO_Support: - declare - - Info_File : Ada.Streams.Stream_IO.File_Type; - Info_Stream : Ada.Streams.Stream_IO.Stream_Access; - The_Filename : constant String := Report.Legal_File_Name; - - begin - - -- If an implementation does not support Stream_IO in a particular - -- environment, the exception Use_Error or Name_Error will be raised on - -- calls to various Stream_IO operations. This block statement - -- encloses a call to Create, which should produce an exception in a - -- non-supportive environment. These exceptions will be handled to - -- produce a Not_Applicable result. - - Ada.Streams.Stream_IO.Create (Info_File, - Ada.Streams.Stream_IO.Out_File, - The_Filename); - - Operational_Test_Block: - declare - - begin - - Info_Stream := Ada.Streams.Stream_IO.Stream (Info_File); - - -- Write all of the product information (record, integer, and array - -- objects) defined in package FXACA00 into the stream. - - Store_Data_Block: - begin - - -- Write information about first product to the stream. - FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_01); - Integer'Write (Info_Stream, FXACA00.Sale_Count_01); - FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_01); - FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_02); - FXACA00.Sales_Statistics_Type'Write - (Info_Stream, FXACA00.Product_01_Stats); - - -- Write information about second product to the stream. - -- Note: No Sales_Record_Type objects. - FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_02); - Integer'Write (Info_Stream, FXACA00.Sale_Count_02); - FXACA00.Sales_Statistics_Type'Write - (Info_Stream, FXACA00.Product_02_Stats); - - -- Write information about third product to the stream. - FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_03); - Integer'Write (Info_Stream, FXACA00.Sale_Count_03); - FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_03); - FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_04); - FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_05); - FXACA00.Sales_Statistics_Type'Write - (Info_Stream, FXACA00.Product_03_Stats); - - end Store_Data_Block; - - - Verify_Data_Block: - declare - - use FXACA00; -- Used within this block only. - - type Domestic_Rec_Array_Type is - array (Positive range <>) of Sales_Record_Type (Domestic); - - type Foreign_Rec_Array_Type is - array (Positive range <>) of Sales_Record_Type (Foreign); - - TC_Rec1 : Domestic_Rec_Array_Type (1..2); - TC_Rec3 : Foreign_Rec_Array_Type (1..3); - - TC_Product1 : Product_Type; - TC_Product2, - TC_Product3 : Product_Type (Foreign); - - TC_Count1, - TC_Count2, - TC_Count3 : Integer := -10; -- Initialized to dummy value. - - TC_Stat1, - TC_Stat2, - TC_Stat3 : Sales_Statistics_Type := (others => 500); - - begin - - Ada.Streams.Stream_IO.Reset (Info_File, - Ada.Streams.Stream_IO.In_File); - - -- Read all of the data that is contained in the stream. - -- Compare all data with the original data in package FXACA00 - -- that was written to the stream. - -- The calls to the read attribute are in anticipated order, based - -- on the order of data written to the stream. Possible errors, - -- such as data placement, overwriting, etc., will be manifest as - -- exceptions raised by the attribute during an unsuccessful read - -- attempt. - - -- Extract data on first product. - Product_Type'Read (Info_Stream, TC_Product1); - Integer'Read (Info_Stream, TC_Count1); - - -- Two "domestic" variant sales records will be read from the - -- stream. - for i in 1 .. TC_Count1 loop - Sales_Record_Type'Read (Info_Stream, TC_Rec1(i) ); - end loop; - - Sales_Statistics_Type'Read (Info_Stream, TC_Stat1); - - - -- Extract data on second product. - Product_Type'Read (Info_Stream, TC_Product2); - Integer'Read (Info_Stream, TC_Count2); - Sales_Statistics_Type'Read (Info_Stream, TC_Stat2); - - - -- Extract data on third product. - Product_Type'Read (Info_Stream, TC_Product3); - Integer'Read (Info_Stream, TC_Count3); - - -- Three "foreign" variant sales records will be read from the - -- stream. - for i in 1 .. TC_Count3 loop - Sales_Record_Type'Read (Info_Stream, TC_Rec3(i) ); - end loop; - - Sales_Statistics_Type'Read (Info_Stream, TC_Stat3); - - - -- After all the data has been correctly extracted, the file - -- should be empty. - - if not Ada.Streams.Stream_IO.End_Of_File (Info_File) then - Report.Failed ("Stream file not empty"); - end if; - - -- Verify that the data values read from the stream are the same - -- as those written to the stream. - - -- Verify the information of the first product. - if ((Product_01 /= TC_Product1) or else - (Product_01.Manufacture /= TC_Product1.Manufacture) or else - (Sale_Count_01 /= TC_Count1) or else - (Sale_Rec_01 /= TC_Rec1(1)) or else - (Sale_Rec_01.Buyer /= TC_Rec1(1).Buyer) or else - (Sale_Rec_02 /= TC_Rec1(2)) or else - (Sale_Rec_02.Buyer /= TC_Rec1(2).Buyer) or else - (Product_01_Stats /= TC_Stat1)) - then - Report.Failed ("Product 1 information incorrect"); - end if; - - -- Verify the information of the second product. - if not ((Product_02 = TC_Product2) and then - (Sale_Count_02 = TC_Count2) and then - (Product_02_Stats = TC_Stat2)) - then - Report.Failed ("Product 2 information incorrect"); - end if; - - -- Verify the information of the third product. - if ((Product_03 /= TC_Product3) or else - (Product_03.Manufacture /= TC_Product3.Manufacture) or else - (Sale_Count_03 /= TC_Count3) or else - (Sale_Rec_03 /= TC_Rec3(1)) or else - (Sale_Rec_03.Buyer /= TC_Rec3(1).Buyer) or else - (Sale_Rec_04 /= TC_Rec3(2)) or else - (Sale_Rec_04.Buyer /= TC_Rec3(2).Buyer) or else - (Sale_Rec_05 /= TC_Rec3(3)) or else - (Sale_Rec_05.Buyer /= TC_Rec3(3).Buyer) or else - (Product_03_Stats /= TC_Stat3)) - then - Report.Failed ("Product 3 information incorrect"); - end if; - - end Verify_Data_Block; - - exception - - when others => - Report.Failed ("Exception raised in Operational Test Block"); - - end Operational_Test_Block; - - if Ada.Streams.Stream_IO.Is_Open (Info_File) then - Ada.Streams.Stream_IO.Delete (Info_File); - else - Ada.Streams.Stream_IO.Open (Info_File, - Ada.Streams.Stream_IO.In_File, - The_Filename); - Ada.Streams.Stream_IO.Delete (Info_File); - end if; - - exception - - -- Since Use_Error or Name_Error can be raised if, for the specified - -- mode, the environment does not support Stream_IO operations, - -- the following handlers are included: - - when Ada.Streams.Stream_IO.Name_Error => - Report.Not_Applicable ("Name_Error raised on Stream IO Create"); - - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable ("Use_Error raised on Stream IO Create"); - - when others => - Report.Failed ("Unexpected exception raised on Stream IO Create"); - - end Test_for_Stream_IO_Support; - - Report.Result; - -end CXACA01; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a b/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a deleted file mode 100644 index 5106dd3991d..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a +++ /dev/null @@ -1,360 +0,0 @@ --- CXACA02.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 user defined subprograms can override the default --- attributes 'Read and 'Write using attribute definition clauses. --- Use objects of record types. --- --- TEST DESCRIPTION: --- This test demonstrates that the default implementations of the --- 'Read and 'Write attributes can be overridden by user specified --- subprograms in conjunction with attribute definition clauses. --- These attributes have been overridden below, and in the user defined --- substitutes, values are added or subtracted to global variables. --- The global variables are evaluated to ensure that the user defined --- subprograms were used in overriding the type-related default --- attributes. --- --- APPLICABILITY CRITERIA: --- Applicable to all implementations that support external --- Stream_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 21 Nov 95 SAIC Corrected recursive attribute definitions --- for ACVC 2.0.1. --- 24 Aug 96 SAIC Corrected typo in test verification criteria. --- ---! - -with Report; -with Ada.Streams.Stream_IO; - -procedure CXACA02 is -begin - - Report.Test ("CXACA02", "Check that user defined subprograms can " & - "override the default attributes 'Read and " & - "'Write using attribute definition clauses"); - - Test_for_Stream_IO_Support: - declare - - Data_File : Ada.Streams.Stream_IO.File_Type; - Data_Stream : Ada.Streams.Stream_IO.Stream_Access; - The_Filename : constant String := Report.Legal_File_Name; - - begin - - -- If an implementation does not support Stream_IO in a particular - -- environment, the exception Use_Error or Name_Error will be raised on - -- calls to various Stream_IO operations. This block statement - -- encloses a call to Create, which should produce an exception in a - -- non-supportive environment. These exceptions will be handled to - -- produce a Not_Applicable result. - - Ada.Streams.Stream_IO.Create (Data_File, - Ada.Streams.Stream_IO.Out_File, - The_Filename); - - Operational_Test_Block: - declare - - type Origin_Type is (Foreign, Domestic); - subtype String_Data_Type is String(1..8); - - type Product_Type is - record - Item : String_Data_Type; - ID : Natural range 1..100; - Manufacture : Origin_Type := Domestic; - Distributor : String_Data_Type; - Importer : String_Data_Type; - end record; - - type Sales_Record_Type is - record - Name : String_Data_Type; - Sale_Item : Boolean := False; - Buyer : Origin_Type; - Quantity_Discount : Boolean; - Cash_Discount : Boolean; - end record; - - - -- Mode conformant, user defined subprograms that will override - -- the type-related attributes. - -- In this test, the user defines these subprograms to add/subtract - -- specific values from global variables. - - procedure Product_Read - ( Stream : access Ada.Streams.Root_Stream_Type'Class; - The_Item : out Product_Type ); - - procedure Product_Write - ( Stream : access Ada.Streams.Root_Stream_Type'Class; - The_Item : Product_Type ); - - procedure Sales_Read - ( Stream : access Ada.Streams.Root_Stream_Type'Class; - The_Item : out Sales_Record_Type ); - - procedure Sales_Write - ( Stream : access Ada.Streams.Root_Stream_Type'Class; - The_Item : Sales_Record_Type ); - - -- Attribute definition clauses. - - for Product_Type'Read use Product_Read; - for Product_Type'Write use Product_Write; - - for Sales_Record_Type'Read use Sales_Read; - for Sales_Record_Type'Write use Sales_Write; - - - -- Object Declarations - - Product_01 : Product_Type := - ("Product1", 1, Domestic, "Distrib1", "Import 1"); - Product_02 : Product_Type := - ("Product2", 2, Foreign, "Distrib2", "Import 2"); - - Sale_Rec_01 : Sales_Record_Type := - ("Buyer 01", False, Domestic, True, True); - Sale_Rec_02 : Sales_Record_Type := - ("Buyer 02", True, Domestic, True, False); - Sale_Rec_03 : Sales_Record_Type := (Name => "Buyer 03", - Sale_Item => True, - Buyer => Foreign, - Quantity_Discount => False, - Cash_Discount => True); - Sale_Rec_04 : Sales_Record_Type := - ("Buyer 04", True, Foreign, False, False); - Sale_Rec_05 : Sales_Record_Type := - ("Buyer 05", False, Foreign, False, False); - - TC_Read_Total : Integer := 100; - TC_Write_Total : Integer := 0; - - - -- Subprogram bodies. - -- These subprograms are designed to override the default attributes - -- 'Read and 'Write for the specified types. Each adds/subtracts - -- a quantity to/from a program control variable, indicating its - -- activity. In addition, each component of the record is - -- individually read from or written to the stream, using the - -- appropriate 'Read or 'Write attribute for the component type. - -- The string components are moved to/from the stream using the - -- 'Input and 'Output attributes for the string subtype, so that - -- the bounds of the strings are also written/read. - - procedure Product_Read - ( Stream : access Ada.Streams.Root_Stream_Type'Class; - The_Item : out Product_Type ) is - begin - TC_Read_Total := TC_Read_Total - 10; - - The_Item.Item := String_Data_Type'Input(Data_Stream); -- Field 1. - Natural'Read(Data_Stream, The_Item.ID); -- Field 2. - Origin_Type'Read(Data_Stream, -- Field 3. - The_Item.Manufacture); - The_Item.Distributor := -- Field 4. - String_Data_Type'Input(Data_Stream); - The_Item.Importer := -- Field 5. - String_Data_Type'Input(Data_Stream); - end Product_Read; - - - procedure Product_Write - ( Stream : access Ada.Streams.Root_Stream_Type'Class; - The_Item : Product_Type ) is - begin - TC_Write_Total := TC_Write_Total + 5; - - String_Data_Type'Output(Data_Stream, The_Item.Item); -- Field 1. - Natural'Write(Data_Stream, The_Item.ID); -- Field 2. - Origin_Type'Write(Data_Stream, -- Field 3. - The_Item.Manufacture); - String_Data_Type'Output(Data_Stream, -- Field 4. - The_Item.Distributor); - String_Data_Type'Output(Data_Stream, -- Field 5. - The_Item.Importer); - end Product_Write; - - - procedure Sales_Read - ( Stream : access Ada.Streams.Root_Stream_Type'Class; - The_Item : out Sales_Record_Type ) is - begin - TC_Read_Total := TC_Read_Total - 20; - - The_Item.Name := String_Data_Type'Input(Data_Stream); -- Field 1. - Boolean'Read(Data_Stream, The_Item.Sale_Item); -- Field 2. - Origin_Type'Read(Data_Stream, The_Item.Buyer); -- Field 3. - Boolean'Read(Data_Stream, The_Item.Quantity_Discount); -- Field 4. - Boolean'Read(Data_Stream, The_Item.Cash_Discount); -- Field 5. - end Sales_Read; - - - procedure Sales_Write - ( Stream : access Ada.Streams.Root_Stream_Type'Class; - The_Item : Sales_Record_Type ) is - begin - TC_Write_Total := TC_Write_Total + 10; - - String_Data_Type'Output(Data_Stream, The_Item.Name); -- Field 1. - Boolean'Write(Data_Stream, The_Item.Sale_Item); -- Field 2. - Origin_Type'Write(Data_Stream, The_Item.Buyer); -- Field 3. - Boolean'Write(Data_Stream, The_Item.Quantity_Discount); -- Field 4. - Boolean'Write(Data_Stream, The_Item.Cash_Discount); -- Field 5. - end Sales_Write; - - - - begin - - Data_Stream := Ada.Streams.Stream_IO.Stream (Data_File); - - -- Write product and sales data to the stream. - - Product_Type'Write (Data_Stream, Product_01); - Sales_Record_Type'Write (Data_Stream, Sale_Rec_01); - Sales_Record_Type'Write (Data_Stream, Sale_Rec_02); - - Product_Type'Write (Data_Stream, Product_02); - Sales_Record_Type'Write (Data_Stream, Sale_Rec_03); - Sales_Record_Type'Write (Data_Stream, Sale_Rec_04); - Sales_Record_Type'Write (Data_Stream, Sale_Rec_05); - - -- Read data from the stream, and verify the use of the user specified - -- attributes. - - Verify_Data_Block: - declare - - TC_Product1, - TC_Product2 : Product_Type; - - TC_Sale1, - TC_Sale2, - TC_Sale3, - TC_Sale4, - TC_Sale5 : Sales_Record_Type; - - begin - - -- Reset the mode of the stream file so that Read/Input - -- operations may be performed. - - Ada.Streams.Stream_IO.Reset (Data_File, - Ada.Streams.Stream_IO.In_File); - - -- Data is read/reconstructed from the stream, in the order that - -- the data was placed into the stream. - - Product_Type'Read (Data_Stream, TC_Product1); - Sales_Record_Type'Read (Data_Stream, TC_Sale1); - Sales_Record_Type'Read (Data_Stream, TC_Sale2); - - Product_Type'Read (Data_Stream, TC_Product2); - Sales_Record_Type'Read (Data_Stream, TC_Sale3); - Sales_Record_Type'Read (Data_Stream, TC_Sale4); - Sales_Record_Type'Read (Data_Stream, TC_Sale5); - - -- Verify product data was correctly written to/read from stream. - - if TC_Product1 /= Product_01 then - Report.Failed ("Data verification error, Product 1"); - end if; - if TC_Product2 /= Product_02 then - Report.Failed ("Data verification error, Product 2"); - end if; - - if TC_Sale1 /= Sale_Rec_01 then - Report.Failed ("Data verification error, Sale_Rec_01"); - end if; - if TC_Sale2 /= Sale_Rec_02 then - Report.Failed ("Data verification error, Sale_Rec_02"); - end if; - if TC_Sale3 /= Sale_Rec_03 then - Report.Failed ("Data verification error, Sale_Rec_03"); - end if; - if TC_Sale4 /= Sale_Rec_04 then - Report.Failed ("Data verification error, Sale_Rec_04"); - end if; - if TC_Sale5 /= Sale_Rec_05 then - Report.Failed ("Data verification error, Sale_Rec_05"); - end if; - - -- Verify that the user defined subprograms were used to - -- override the default 'Read and 'Write attributes. - -- There were two "product" reads and two writes; there - -- were five "sale record" reads and five writes. - - if (TC_Read_Total /= -20) or (TC_Write_Total /= 60) then - Report.Failed ("Incorrect use of user defined attributes"); - end if; - - end Verify_Data_Block; - - exception - - when others => - Report.Failed ("Exception raised in Operational Test Block"); - - end Operational_Test_Block; - - if Ada.Streams.Stream_IO.Is_Open (Data_File) then - Ada.Streams.Stream_IO.Delete (Data_File); - else - Ada.Streams.Stream_IO.Open (Data_File, - Ada.Streams.Stream_IO.Out_File, - The_Filename); - Ada.Streams.Stream_IO.Delete (Data_File); - end if; - - - exception - - -- Since Use_Error or Name_Error can be raised if, for the specified - -- mode, the environment does not support Stream_IO operations, - -- the following handlers are included: - - when Ada.Streams.Stream_IO.Name_Error => - Report.Not_Applicable ("Name_Error raised on Stream IO Create"); - - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable ("Use_Error raised on Stream IO Create"); - - when others => - Report.Failed ("Unexpected exception raised"); - - end Test_for_Stream_IO_Support; - - Report.Result; - -end CXACA02; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a b/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a deleted file mode 100644 index ac4a905e830..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a +++ /dev/null @@ -1,264 +0,0 @@ --- CXACB01.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 default attributes 'Input and 'Output work properly when --- used with objects of a variety of types, including two-dimensional --- arrays and records without default discriminants. --- --- TEST DESCRIPTION: --- This test simulates utility company service record storage, using --- Stream_IO to allow the storage of heterogeneous data in a single --- stream file. --- --- Three types of data are written to the stream file for each utility --- service customer. --- First, the general information on the customer is written. --- This is an object of a discriminated (without default) record --- type. This is followed by an integer object containing a count of --- the number of service months for the customer. Finally, a --- two-dimensional array object with monthly consumption information for --- the customer is written to the stream. --- --- Objects of record types with discriminants without defaults should --- have their discriminants included in the stream when using 'Output. --- Likewise, discriminants should be extracted --- from the stream when using 'Input. Similarly, array bounds are written --- to and read from the stream when using 'Output and 'Input with array --- objects. --- --- APPLICABILITY CRITERIA: --- Applicable to all implementations that support external --- Stream_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with FXACB00; -with Ada.Streams.Stream_IO; -with Report; - -procedure CXACB01 is -begin - - Report.Test ("CXACB01", "Check that the default attributes 'Input and " & - "'Output work properly when used with objects " & - "of record, natural, and array types" ); - - Test_for_Stream_IO_Support: - declare - - Util_File : Ada.Streams.Stream_IO.File_Type; - Util_Stream : Ada.Streams.Stream_IO.Stream_Access; - Utility_Service_Filename : constant String := Report.Legal_File_Name; - - begin - - -- If an implementation does not support Stream_IO in a particular - -- environment, the exception Use_Error or Name_Error will be raised on - -- calls to various Stream_IO operations. This block statement - -- encloses a call to Create, which should produce an exception in a - -- non-supportive environment. These exceptions will be handled to - -- produce a Not_Applicable result. - - Ada.Streams.Stream_IO.Create (Util_File, - Ada.Streams.Stream_IO.Out_File, - Utility_Service_Filename); - - Operational_Test_Block: - declare - - -- The following procedure will store all of the customer specific - -- information into the stream. - - procedure Store_Data_In_Stream - (Customer : in FXACB00.Service_Type; - Months : in FXACB00.Months_In_Service_Type; - History : in FXACB00.Service_History_Type) is - begin - FXACB00.Service_Type'Output (Util_Stream, Customer); - FXACB00.Months_In_Service_Type'Output (Util_Stream, Months); - FXACB00.Service_History_Type'Output (Util_Stream, History); - end Store_Data_In_Stream; - - - -- The following procedure will remove from the stream all of the - -- customer related information. - - procedure Retrieve_Data_From_Stream - (Customer : out FXACB00.Service_Type; - Months : out FXACB00.Months_In_Service_Type; - History : out FXACB00.Service_History_Type) is - begin - Customer := FXACB00.Service_Type'Input (Util_Stream); - Months := FXACB00.Months_In_Service_Type'Input (Util_Stream); - History := FXACB00.Service_History_Type'Input (Util_Stream); - end Retrieve_Data_From_Stream; - - - begin - - Util_Stream := Ada.Streams.Stream_IO.Stream (Util_File); - - -- Write all of the customer service information (record, numeric, - -- and array objects) defined in package FXACB00 into the stream. - - Data_Storage_Block: - begin - - Store_Data_In_Stream (Customer => FXACB00.Customer1, - Months => FXACB00.C1_Months, - History => FXACB00.C1_Service_History); - - Store_Data_In_Stream (FXACB00.Customer2, - FXACB00.C2_Months, - History => FXACB00.C2_Service_History); - - Store_Data_In_Stream (Months => FXACB00.C3_Months, - History => FXACB00.C3_Service_History, - Customer => FXACB00.Customer3); - end Data_Storage_Block; - - - Data_Verification_Block: - declare - - TC_Residence : FXACB00.Service_Type (FXACB00.Residence); - TC_Apartment : FXACB00.Service_Type (FXACB00.Apartment); - TC_Commercial : FXACB00.Service_Type (FXACB00.Commercial); - - - TC_Months1, - TC_Months2, - TC_Months3 : FXACB00.Months_In_Service_Type := - FXACB00.Months_In_Service_Type'First; - - - TC_History1 : - FXACB00.Service_History_Type (FXACB00.Quarterly_Period_Type, - FXACB00.Month_In_Quarter_Type) := - (others => (others => FXACB00.Electric_Usage_Type'Last)); - - TC_History2 : - FXACB00.Service_History_Type - (FXACB00.Quarterly_Period_Type range - FXACB00.Spring .. FXACB00.Summer, - FXACB00.Month_In_Quarter_Type) := - (others => (others => FXACB00.Electric_Usage_Type'Last)); - - TC_History3 : - FXACB00.Service_History_Type (FXACB00.Quarterly_Period_Type, - FXACB00.Month_In_Quarter_Type) := - (others => (others => FXACB00.Electric_Usage_Type'Last)); - - begin - - Ada.Streams.Stream_IO.Reset (Util_File, - Ada.Streams.Stream_IO.In_File); - - -- Input all of the data that is contained in the stream. - -- Compare all data with the original data in package FXACB00 - -- that was written to the stream. - - Retrieve_Data_From_Stream (TC_Residence, TC_Months1, TC_History1); - Retrieve_Data_From_Stream (TC_Apartment, TC_Months2, TC_History2); - Retrieve_Data_From_Stream (Customer => TC_Commercial, - Months => TC_Months3, - History => TC_History3); - - -- After all the data has been correctly extracted, the file - -- should be empty. - - if not Ada.Streams.Stream_IO.End_Of_File (Util_File) then - Report.Failed ("Stream file not empty"); - end if; - - -- Verify that the data values read from the stream are the same - -- as those written to the stream. - - if ((FXACB00."/="(FXACB00.Customer1, TC_Residence)) or else - (FXACB00."/="(FXACB00.Customer2, TC_Apartment)) or else - (FXACB00."/="(FXACB00.Customer3, TC_Commercial))) - then - Report.Failed ("Customer information incorrect"); - end if; - - if ((FXACB00."/="(FXACB00.C1_Months, TC_Months1)) or - (FXACB00."/="(FXACB00.C2_Months, TC_Months2)) or - (FXACB00."/="(FXACB00.C3_Months, TC_Months3))) - then - Report.Failed ("Number of Months information incorrect"); - end if; - - if not ((FXACB00."="(FXACB00.C1_Service_History, TC_History1)) and - (FXACB00."="(FXACB00.C2_Service_History, TC_History2)) and - (FXACB00."="(FXACB00.C3_Service_History, TC_History3))) - then - Report.Failed ("Service history information incorrect"); - end if; - - end Data_Verification_Block; - - exception - - when others => - Report.Failed ("Exception raised in Operational Test Block"); - - end Operational_Test_Block; - - -- Delete the file. - if Ada.Streams.Stream_IO.Is_Open (Util_File) then - Ada.Streams.Stream_IO.Delete (Util_File); - else - Ada.Streams.Stream_IO.Open (Util_File, - Ada.Streams.Stream_IO.Out_File, - Utility_Service_Filename); - Ada.Streams.Stream_IO.Delete (Util_File); - end if; - - - exception - - -- Since Use_Error or Name_Error can be raised if, for the specified - -- mode, the environment does not support Stream_IO operations, - -- the following handlers are included: - - when Ada.Streams.Stream_IO.Name_Error => - Report.Not_Applicable ("Name_Error raised on Stream IO Create"); - - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable ("Use_Error raised on Stream IO Create"); - - when others => - Report.Failed ("Unexpected exception raised"); - - end Test_for_Stream_IO_Support; - - Report.Result; - -end CXACB01; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a b/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a deleted file mode 100644 index a0ade9ebe1c..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a +++ /dev/null @@ -1,421 +0,0 @@ --- CXACB02.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 user defined subprograms can override the default --- attributes 'Input and 'Output using attribute definition clauses, --- when used with objects of discriminated record and multi-dimensional --- array types. --- --- TEST DESCRIPTION: --- This test demonstrates that the default implementations of the --- 'Input and 'Output attributes can be overridden by user specified --- subprograms in conjunction with attribute definition clauses. --- These attributes have been overridden below, and in the user defined --- substitutes, values are added or subtracted to global variables. --- Following the completion of the writing/reading test, the global --- variables are evaluated to ensure that the user defined subprograms --- were used in overriding the type-related default attributes. --- --- APPLICABILITY CRITERIA: --- Applicable to all implementations that support external --- Stream_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 14 Nov 95 SAIC Corrected test errors for ACVC 2.0.1. --- ---! - -with Report; -with Ada.Streams.Stream_IO; - -procedure CXACB02 is -begin - - Report.Test ("CXACB02", "Check that user defined subprograms can " & - "override the default attributes 'Input and " & - "'Output using attribute definition clauses"); - - Test_for_Stream_IO_Support: - declare - - Util_File : Ada.Streams.Stream_IO.File_Type; - Util_Stream : Ada.Streams.Stream_IO.Stream_Access; - Utility_Filename : constant String := Report.Legal_File_Name; - - begin - - -- If an implementation does not support Stream_IO in a particular - -- environment, the exception Use_Error or Name_Error will be raised on - -- calls to various Stream_IO operations. This block statement - -- encloses a call to Create, which should produce an exception in a - -- non-supportive environment. These exceptions will be handled to - -- produce a Not_Applicable result. - - Ada.Streams.Stream_IO.Create (Util_File, - Ada.Streams.Stream_IO.Out_File, - Utility_Filename); - - Operational_Test_Block: - declare - - type Customer_Type is (Residence, Apartment, Commercial); - type Electric_Usage_Type is range 0..100000; - type Months_In_Service_Type is range 1..12; - type Quarterly_Period_Type is (Spring, Summer, Autumn, Winter); - subtype Month_In_Quarter_Type is Positive range 1..3; - type Service_History_Type is - array (Quarterly_Period_Type range <>, - Month_In_Quarter_Type range <>) of Electric_Usage_Type; - - type Service_Type (Customer : Customer_Type) is - record - Name : String (1..21); - Account_ID : Natural range 0..100; - case Customer is - when Residence | Apartment => - Low_Income_Credit : Boolean := False; - when Commercial => - Baseline_Allowance : Natural range 0..1000; - Quantity_Discount : Boolean := False; - end case; - end record; - - - -- Mode conformant, user defined subprograms that will override - -- the type-related attributes. - -- In this test, the user defines these subprograms to add/subtract - -- specific values from global variables. - - function Service_Input - (Stream : access Ada.Streams.Root_Stream_Type'Class) - return Service_Type; - - procedure Service_Output - (Stream : access Ada.Streams.Root_Stream_Type'Class; - Item : Service_Type); - - function History_Input - (Stream : access Ada.Streams.Root_Stream_Type'Class) - return Service_History_Type; - - procedure History_Output - (Stream : access Ada.Streams.Root_Stream_Type'Class; - Item : Service_History_Type); - - - -- Attribute definition clauses. - - for Service_Type'Input use Service_Input; - for Service_Type'Output use Service_Output; - - for Service_History_Type'Input use History_Input; - for Service_History_Type'Output use History_Output; - - - -- Object Declarations - - Customer1 : Service_Type (Residence) := - (Residence, "1221 Morningstar Lane", 44, False); - Customer2 : Service_Type (Apartment) := - (Customer => Apartment, - Account_ID => 67, - Name => "15 South Front St. #8", - Low_Income_Credit => True); - Customer3 : Service_Type (Commercial) := - (Commercial, - "12442 Central Avenue ", - 100, - Baseline_Allowance => 938, - Quantity_Discount => True); - - C1_Service_History : - Service_History_Type (Quarterly_Period_Type, - Month_In_Quarter_Type) := - (Spring => (1 => 35, 2 => 39, 3 => 32), - Summer => (1 => 34, 2 => 33, 3 => 39), - Autumn => (1 => 45, 2 => 40, 3 => 38), - Winter => (1 => 53, 2 => 0, 3 => 0)); - - C2_Service_History : - Service_History_Type (Quarterly_Period_Type range Spring..Summer, - Month_In_Quarter_Type) := - (Spring => (23, 22, 0), Summer => (0, 0, 0)); - - C3_Service_History : - Service_History_Type (Quarterly_Period_Type, - Month_In_Quarter_Type) := - (others => (others => 200)); - - - TC_Input_Total : Integer := 0; - TC_Output_Total : Integer := 0; - - - -- Subprogram bodies. - -- These subprograms are designed to override the default attributes - -- 'Input and 'Output for the specified types. Each adds/subtracts - -- a quantity to/from a program control variable, indicating its - -- activity. Each user defined "Input" function uses the 'Read - -- attribute for the type to accomplish the operation. Likewise, - -- each user defined "Output" subprogram uses the 'Write attribute - -- for the type. - - function Service_Input - ( Stream : access Ada.Streams.Root_Stream_Type'Class ) - return Service_Type is - Customer : Customer_Type; - begin - TC_Input_Total := TC_Input_Total + 1; - - -- Extract the discriminant value from the stream. - -- This discriminant would not otherwise be extracted from the - -- stream when the Service_Type'Read attribute is used below. - Customer_Type'Read (Stream, Customer); - - declare - -- Declare a constant of Service_Type, using the value just - -- read from the stream as the discriminant value of the - -- object. - Service : Service_Type(Customer); - begin - Service_Type'Read (Stream, Service); - return Service; - end; - end Service_Input; - - - procedure Service_Output - ( Stream : access Ada.Streams.Root_Stream_Type'Class; - Item : Service_Type ) is - begin - TC_Output_Total := TC_Output_Total + 2; - -- Write the discriminant value to the stream. - -- The attribute 'Write (for the record type) will not write the - -- discriminant of the record object to the stream. Therefore, it - -- must be explicitly written using the 'Write attribute of the - -- discriminant type. - Customer_Type'Write (Stream, Item.Customer); - -- Write the record component values (but not the discriminant) to - -- the stream. - Service_Type'Write (Stream, Item); - end Service_Output; - - - function History_Input - ( Stream : access Ada.Streams.Root_Stream_Type'Class ) - return Service_History_Type is - Quarter_Bound_Low : Quarterly_Period_Type; - Quarter_Bound_High : Quarterly_Period_Type; - Month_Bound_Low : Month_In_Quarter_Type; - Month_Bound_High : Month_In_Quarter_Type; - begin - TC_Input_Total := TC_Input_Total + 3; - - -- Read the value of the array bounds from the stream. - -- Use these bounds in the creation of an array object that will - -- be used to store data from the stream. - -- The array bound values would not otherwise be read from the - -- stream by use of the Service_History_Type'Read attribute. - Quarterly_Period_Type'Read (Stream, Quarter_Bound_Low); - Quarterly_Period_Type'Read (Stream, Quarter_Bound_High); - Month_In_Quarter_Type'Read (Stream, Month_Bound_Low); - Month_In_Quarter_Type'Read (Stream, Month_Bound_High); - - declare - Service_History_Array : - Service_History_Type - (Quarterly_Period_Type range - Quarter_Bound_Low..Quarter_Bound_High, - Month_In_Quarter_Type range - Month_Bound_Low .. Month_Bound_High); - begin - Service_History_Type'Read (Stream, Service_History_Array); - return Service_History_Array; - end; - end History_Input; - - - procedure History_Output - ( Stream : access Ada.Streams.Root_Stream_Type'Class; - Item : Service_History_Type ) is - begin - TC_Output_Total := TC_Output_Total + 7; - -- Write the upper/lower bounds of the array object dimensions to - -- the stream. - Quarterly_Period_Type'Write (Stream, Item'First(1)); - Quarterly_Period_Type'Write (Stream, Item'Last(1)); - Month_In_Quarter_Type'Write (Stream, Item'First(2)); - Month_In_Quarter_Type'Write (Stream, Item'Last(2)); - -- Write the array values to the stream in canonical order (last - -- dimension varying fastest). - Service_History_Type'Write (Stream, Item); - end History_Output; - - - - begin - - Util_Stream := Ada.Streams.Stream_IO.Stream (Util_File); - - -- Write data to the stream. A customer service record is followed - -- by a service history array. - - Service_Type'Output (Util_Stream, Customer1); - Service_History_Type'Output (Util_Stream, C1_Service_History); - - Service_Type'Output (Util_Stream, Customer2); - Service_History_Type'Output (Util_Stream, C2_Service_History); - - Service_Type'Output (Util_Stream, Customer3); - Service_History_Type'Output (Util_Stream, C3_Service_History); - - - -- Read data from the stream, and verify the use of the user specified - -- attributes. - - Verify_Data_Block: - declare - - TC_Residence : Service_Type (Residence); - TC_Apartment : Service_Type (Apartment); - TC_Commercial : Service_Type (Commercial); - - TC_History1 : Service_History_Type (Quarterly_Period_Type, - Month_In_Quarter_Type) := - (others => (others => Electric_Usage_Type'First)); - - TC_History2 : Service_History_Type (Quarterly_Period_Type - range Spring .. Summer, - Month_In_Quarter_Type) := - (others => (others => Electric_Usage_Type'First)); - - TC_History3 : Service_History_Type (Quarterly_Period_Type, - Month_In_Quarter_Type) := - (others => (others => Electric_Usage_Type'First)); - - begin - - -- Reset Stream file to mode In_File. - - Ada.Streams.Stream_IO.Reset (Util_File, - Ada.Streams.Stream_IO.In_File); - - -- Read data from the stream. - - TC_Residence := Service_Type'Input (Util_Stream); - TC_History1 := Service_History_Type'Input (Util_Stream); - - TC_Apartment := Service_Type'Input (Util_Stream); - TC_History2 := Service_History_Type'Input (Util_Stream); - - TC_Commercial := Service_Type'Input (Util_Stream); - TC_History3 := Service_History_Type'Input (Util_Stream); - - - -- Verify product data was correctly written to/read from stream, - -- including discriminants and array bounds. - - if (TC_Residence /= Customer1) or - (TC_Residence.Customer /= Customer1.Customer) or - (TC_History1'Last(1) /= C1_Service_History'Last(1)) or - (TC_History1'First(1) /= C1_Service_History'First(1)) or - (TC_History1'Last(2) /= C1_Service_History'Last(2)) or - (TC_History1'First(2) /= C1_Service_History'First(2)) - then - Report.Failed ("Incorrect data from stream - 1"); - end if; - - if (TC_Apartment /= Customer2) or - (TC_Apartment.Customer /= Customer2.Customer) or - (TC_History2 /= C2_Service_History) or - (TC_History2'Last(1) /= C2_Service_History'Last(1)) or - (TC_History2'First(1) /= C2_Service_History'First(1)) or - (TC_History2'Last(2) /= C2_Service_History'Last(2)) or - (TC_History2'First(2) /= C2_Service_History'First(2)) - then - Report.Failed ("Incorrect data from stream - 2"); - end if; - - if (TC_Commercial /= Customer3) or - (TC_Commercial.Customer /= Customer3.Customer) or - (TC_History3 /= C3_Service_History) or - (TC_History3'Last(1) /= C3_Service_History'Last(1)) or - (TC_History3'First(1) /= C3_Service_History'First(1)) or - (TC_History3'Last(2) /= C3_Service_History'Last(2)) or - (TC_History3'First(2) /= C3_Service_History'First(2)) - then - Report.Failed ("Incorrect data from stream - 3"); - end if; - - -- Verify that the user defined subprograms were used to override - -- the default 'Input and 'Output attributes. - -- There were three calls on each of the user defined attributes. - - if (TC_Input_Total /= 12 ) or (TC_Output_Total /= 27 ) then - Report.Failed ("Incorrect use of user defined attributes"); - end if; - - end Verify_Data_Block; - - exception - - when others => - Report.Failed ("Exception raised in Operational Test Block"); - - end Operational_Test_Block; - - if Ada.Streams.Stream_IO.Is_Open (Util_File) then - Ada.Streams.Stream_IO.Delete (Util_File); - else - Ada.Streams.Stream_IO.Open (Util_File, - Ada.Streams.Stream_IO.Out_File, - Utility_Filename); - Ada.Streams.Stream_IO.Delete (Util_File); - end if; - - - exception - - -- Since Use_Error or Name_Error can be raised if, for the specified - -- mode, the environment does not support Stream_IO operations, - -- the following handlers are included: - - when Ada.Streams.Stream_IO.Name_Error => - Report.Not_Applicable ("Name_Error raised on Stream IO Create"); - - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable ("Use_Error raised on Stream IO Create"); - - when others => - Report.Failed ("Unexpected exception raised"); - - end Test_for_Stream_IO_Support; - - Report.Result; - -end CXACB02; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a b/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a deleted file mode 100644 index 3ab88f40e6d..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a +++ /dev/null @@ -1,299 +0,0 @@ --- CXACC01.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 use of 'Class'Output and 'Class'Input allow stream --- manipulation of objects of non-limited class-wide types. --- --- TEST DESCRIPTION: --- This test demonstrates the uses of 'Class'Output and 'Class'Input --- in moving objects of a particular class to and from a stream file. --- A procedure uses a class-wide parameter to move objects of specific --- types in the class to the stream, using the 'Class'Output attribute --- of the root type of the class. A function returns a class-wide object, --- using the 'Class'Input attribute of the root type of the class to --- extract the object from the stream. --- A field-by-field comparison of record objects is performed to validate --- the data read from the stream. Operator precedence rules are used --- in the comparison rather than parentheses. --- --- APPLICABILITY CRITERIA: --- This test is applicable to all implementations capable of supporting --- external Stream_IO files. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 14 Nov 95 SAIC Corrected prefix of 'Tag attribute for ACVC 2.0.1. --- 24 Aug 96 SAIC Changed a call to "Create" to "Reset". --- 26 Feb 97 CTA.PWB Allowed for non-support of some IO operations. ---! - -with FXACC00, Ada.Streams.Stream_IO, Ada.Tags, Report; - -procedure CXACC01 is - - Order_File : Ada.Streams.Stream_IO.File_Type; - Order_Stream : Ada.Streams.Stream_IO.Stream_Access; - Order_Filename : constant String := - Report.Legal_File_Name ( Nam => "CXACC01" ); - Incomplete : exception; - -begin - - Report.Test ("CXACC01", "Check that the use of 'Class'Output " & - "and 'Class'Input allow stream manipulation " & - "of objects of non-limited class-wide types"); - - Test_for_Stream_IO_Support: - begin - - -- If an implementation does not support Stream_IO in a particular - -- environment, the exception Use_Error or Name_Error will be raised on - -- calls to various Stream_IO operations. This block statement - -- encloses a call to Create, which should produce an exception in a - -- non-supportive environment. These exceptions will be handled to - -- produce a Not_Applicable result. - - Ada.Streams.Stream_IO.Create (Order_File, - Ada.Streams.Stream_IO.Out_File, - Order_Filename); - - exception - - when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error => - Report.Not_Applicable - ( "Files not supported - Create as Out_File for Stream_IO" ); - raise Incomplete; - - end Test_for_Stream_IO_Support; - - Operational_Test_Block: - declare - - -- Store tag values associated with objects of tagged types. - - TC_Box_Office_Tag : constant String := - Ada.Tags.External_Tag(FXACC00.Ticket_Request'Tag); - - TC_Summer_Tag : constant String := - Ada.Tags.External_Tag(FXACC00.Subscriber_Request'Tag); - - TC_Mayoral_Tag : constant String := - Ada.Tags.External_Tag(FXACC00.VIP_Request'Tag); - - TC_Late_Tag : constant String := - Ada.Tags.External_Tag(FXACC00.Last_Minute_Request'Tag); - - -- The following procedure will take an object of the Ticket_Request - -- class and output it to the stream. Objects of any extended type - -- in the class can be output to the stream with this procedure. - - procedure Order_Entry (Order : FXACC00.Ticket_Request'Class) is - begin - FXACC00.Ticket_Request'Class'Output (Order_Stream, Order); - end Order_Entry; - - - -- The following function will retrieve from the stream an object of - -- the Ticket_Request class. - - function Order_Retrieval return FXACC00.Ticket_Request'Class is - begin - return FXACC00.Ticket_Request'Class'Input (Order_Stream); - end Order_Retrieval; - - begin - - Order_Stream := Ada.Streams.Stream_IO.Stream (Order_File); - - -- Store the data objects in the stream. - -- Each of the objects is of a different type within the class. - - Order_Entry (FXACC00.Box_Office_Request); -- Object of root type - Order_Entry (FXACC00.Summer_Subscription); -- Obj. of extended type - Order_Entry (FXACC00.Mayoral_Ticket_Request); -- Obj. of extended type - Order_Entry (FXACC00.Late_Request); -- Object of twice - -- extended type. - - -- Reset mode of stream to In_File prior to reading data from it. - Reset1: - begin - Ada.Streams.Stream_IO.Reset (Order_File, - Ada.Streams.Stream_IO.In_File); - exception - when Ada.Streams.Stream_IO.Use_Error => - Report.Not_Applicable - ( "Reset to In_File not supported for Stream_IO - 1" ); - raise Incomplete; - end Reset1; - - Process_Order_Block: - declare - - use FXACC00; - - -- Declare variables of the root type class, - -- and initialize them with class-wide objects returned from - -- the stream as function result. - - Order_1 : Ticket_Request'Class := Order_Retrieval; - Order_2 : Ticket_Request'Class := Order_Retrieval; - Order_3 : Ticket_Request'Class := Order_Retrieval; - Order_4 : Ticket_Request'Class := Order_Retrieval; - - -- Declare objects of the specific types from within the class - -- that correspond to the types of the data written to the - -- stream. Perform a type conversion on the class-wide objects. - - Ticket_Order : Ticket_Request := - Ticket_Request(Order_1); - Subscriber_Order : Subscriber_Request := - Subscriber_Request(Order_2); - VIP_Order : VIP_Request := - VIP_Request(Order_3); - Last_Minute_Order : Last_Minute_Request := - Last_Minute_Request(Order_4); - - begin - - -- Perform a field-by-field comparison of all the class-wide - -- objects input from the stream with specific type objects - -- originally written to the stream. - - if Ticket_Order.Location /= - Box_Office_Request.Location or - Ticket_Order.Number_Of_Tickets /= - Box_Office_Request.Number_Of_Tickets - then - Report.Failed ("Ticket_Request object validation failure"); - end if; - - if Subscriber_Order.Location /= - Summer_Subscription.Location or - Subscriber_Order.Number_Of_Tickets /= - Summer_Subscription.Number_Of_Tickets or - Subscriber_Order.Subscription_Number /= - Summer_Subscription.Subscription_Number - then - Report.Failed ("Subscriber_Request object validation failure"); - end if; - - if VIP_Order.Location /= - Mayoral_Ticket_Request.Location or - VIP_Order.Number_Of_Tickets /= - Mayoral_Ticket_Request.Number_Of_Tickets or - VIP_Order.Rank /= - Mayoral_Ticket_Request.Rank - then - Report.Failed ("VIP_Request object validation failure"); - end if; - - if Last_Minute_Order.Location /= - Late_Request.Location or - Last_Minute_Order.Number_Of_Tickets /= - Late_Request.Number_Of_Tickets or - Last_Minute_Order.Rank /= - Late_Request.Rank or - Last_Minute_Order.Special_Consideration /= - Late_Request.Special_Consideration or - Last_Minute_Order.Donation /= - Late_Request.Donation - then - Report.Failed ("Last_Minute_Request object validation failure"); - end if; - - -- Verify tag values from before and after processing. - -- The 'Tag attribute is used with objects of a class-wide type. - - if TC_Box_Office_Tag /= - Ada.Tags.External_Tag(Order_1'Tag) - then - Report.Failed("Failed tag comparison - 1"); - end if; - - if TC_Summer_Tag /= - Ada.Tags.External_Tag(Order_2'Tag) - then - Report.Failed("Failed tag comparison - 2"); - end if; - - if TC_Mayoral_Tag /= - Ada.Tags.External_Tag(Order_3'Tag) - then - Report.Failed("Failed tag comparison - 3"); - end if; - - if TC_Late_Tag /= - Ada.Tags.External_Tag(Order_4'Tag) - then - Report.Failed("Failed tag comparison - 4"); - end if; - - end Process_Order_Block; - - -- After all the data has been correctly extracted, the file - -- should be empty. - - if not Ada.Streams.Stream_IO.End_Of_File (Order_File) then - Report.Failed ("Stream file not empty"); - end if; - - exception - when Incomplete => - raise; - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Operational Block"); - when others => - Report.Failed ("Exception raised in Operational Test Block"); - end Operational_Test_Block; - - Deletion: - begin - if Ada.Streams.Stream_IO.Is_Open (Order_File) then - Ada.Streams.Stream_IO.Delete (Order_File); - else - Ada.Streams.Stream_IO.Open (Order_File, - Ada.Streams.Stream_IO.Out_File, - Order_Filename); - Ada.Streams.Stream_IO.Delete (Order_File); - end if; - exception - when others => - Report.Failed - ( "Delete not properly implemented for Stream_IO" ); - end Deletion; - - Report.Result; - -exception - - when Incomplete => - Report.Result; - when others => - Report.Failed ( "Unexpected exception" ); - Report.Result; - -end CXACC01; diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a b/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a deleted file mode 100644 index ae3497abde0..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a +++ /dev/null @@ -1,199 +0,0 @@ --- CXAF001.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 an implementation supports the functionality defined --- in Package Ada.Command_Line. --- --- TEST DESCRIPTION: --- This test verifies that an implementation supports the subprograms --- contained in package Ada.Command_Line. Each of the subprograms --- is exercised in a general sense, to ensure that it is available, --- and that it provides the prescribed results in a known test --- environment. Function Argument_Count must return zero, or the --- number of arguments passed to the program calling it. Function --- Argument is called with a parameter value one greater than the --- actual number of arguments passed to the executing program, which --- must result in Constraint_Error being raised. Function Command_Name --- should return the name of the executing program that called it --- (specifically, this test name). Function Set_Exit_Status is called --- with two different parameter values, the constants Failure and --- Success defined in package Ada.Command_Line. --- --- The setting of the variable TC_Verbose allows for some additional --- output to be displayed during the running of the test as an aid in --- tracing the processing flow of the test. --- --- APPLICABILITY CRITERIA: --- This test is applicable to implementations that support the --- declaration of package Command_Line as defined in the Ada Reference --- manual. --- An alternative declaration is allowed for package Command_Line if --- different functionality is appropriate for the external execution --- environment. --- --- --- CHANGE HISTORY: --- 10 Jul 95 SAIC Initial prerelease version. --- 02 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. --- 05 AUG 98 EDS Allow Null string result to be returned from --- Function Command ---! - -with Ada.Command_Line; -with Ada.Exceptions; -with Report; - -procedure CXAF001 is -begin - - Report.Test ("CXAF001", "Check that an implementation supports the " & - "functionality defined in Package " & - "Ada.Command_Line"); - - Test_Block: - declare - - use Ada.Exceptions; - - type String_Access is access all String; - - TC_Verbose : Boolean := False; - Number_Of_Arguments : Natural := Natural'Last; - Name_Of_Command : String_Access; - - begin - - -- Check the result of function Argument_Count. - -- Note: If the external environment does not support passing arguments - -- to the program invoking the function, the function result - -- will be zero. - - Number_Of_Arguments := Ada.Command_Line.Argument_Count; - if Number_Of_Arguments = Natural'Last then - Report.Failed("Argument_Count did not provide a return result"); - end if; - if TC_Verbose then - Report.Comment - ("Argument_Count = " & Integer'Image(Number_Of_Arguments)); - end if; - - - -- Check that the result of Function Argument is Constraint_Error - -- when the Number argument is outside the range of 1..Argument_Count. - - Test_Function_Argument_1 : - begin - declare - - -- Define a value that will be outside the range of - -- 1..Argument_Count. - -- Note: If the external execution environment does not support - -- passing arguments to a program, then Argument(N) for - -- any N will raise Constraint_Error, since - -- Argument_Count = 0; - - Arguments_Plus_One : Positive := - Ada.Command_Line.Argument_Count + 1; - - -- Using the above value in a call to Argument must result in - -- the raising of Constraint_Error. - - Argument_String : constant String := - Ada.Command_Line.Argument(Arguments_Plus_One); - - begin - Report.Failed("Constraint_Error not raised by Function " & - "Argument when provided a Number argument " & - "out of range"); - end; - exception - when Constraint_Error => null; -- OK, expected exception. - if TC_Verbose then - Report.Comment ("Argument_Count raised Constraint_Error"); - end if; - when others => - Report.Failed ("Unexpected exception raised by Argument " & - "in Test_Function_Argument_1 block"); - end Test_Function_Argument_1; - - - -- Check that Function Argument returns a string result. - - Test_Function_Argument_2 : - begin - if Ada.Command_Line.Argument_Count > 0 then - Report.Comment - ("Last argument is: " & - Ada.Command_Line.Argument(Ada.Command_Line.Argument_Count)); - elsif TC_Verbose then - Report.Comment("Argument_Count is zero, no test of Function " & - "Argument for string result"); - end if; - exception - when others => - Report.Failed ("Unexpected exception raised by Argument " & - "in Test_Function_Argument_2 block"); - end Test_Function_Argument_2; - - - -- Check the result of Function Command_Name. - - Name_Of_Command := new String'(Ada.Command_Line.Command_Name); - - if Name_Of_Command = null then - Report.Failed("Null string pointer returned from Function Command"); - elsif Name_Of_Command.all = "" then - Report.Comment("Null string result returned from Function Command"); - elsif TC_Verbose then - Report.Comment("Invoking command is " & Name_Of_Command.all); - end if; - - - -- Check that procedure Set_Exit_Status is available. - -- Note: If the external execution environment does not support - -- returning an exit value from a program, then Set_Exit_Status - -- does nothing. - - Ada.Command_Line.Set_Exit_Status(Ada.Command_Line.Failure); - if TC_Verbose then - Report.Comment("Exit status set to Failure"); - end if; - - Ada.Command_Line.Set_Exit_Status(Ada.Command_Line.Success); - if TC_Verbose then - Report.Comment("Exit status set to Success"); - end if; - - - exception - when The_Error : others => - Report.Failed ("The following exception was raised in the " & - "Test_Block: " & Exception_Name(The_Error)); - end Test_Block; - - Report.Result; - -end CXAF001; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a b/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a deleted file mode 100644 index be7e5069252..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a +++ /dev/null @@ -1,261 +0,0 @@ --- CXF1001.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 values of 2 and 10 are allowable values for Machine_Radix --- of a decimal first subtype. --- Check that the value of Decimal.Max_Decimal_Digits is at least 18; --- the value of Decimal.Max_Scale is at least 18; the value of --- Decimal.Min_Scale is at most 0. --- --- TEST DESCRIPTION: --- This test examines the Machine_Radix attribute definition clause --- and its effect on Decimal fixed point types, as well as several --- constants from the package Ada.Decimal. --- The first subtest checks that the Machine_Radix attribute will --- return the value set for Machine_Radix by an attribute definition --- clause. The second and third subtests examine differences between --- the binary and decimal scaling of a type, based on the radix --- representation. The final subtest examines the values --- assigned to constants Min_Scale, Max_Scale, and Max_Decimal_Digits, --- found in the package Ada.Decimal. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 29 Dec 94 SAIC Restructured Radix 10 and Radix 2 test blocks. --- ---! - -with Report; -with Ada.Decimal; - -procedure CXF1001 is -begin - - Report.Test ("CXF1001", "Check that values of 2 and 10 are allowable " & - "values for Machine_Radix of a decimal first " & - "subtype. Check that the value of " & - "Decimal.Max_Decimal_Digits is at least 18; " & - "the value of Decimal.Max_Scale is at least " & - "18; the value of Decimal.Min_Scale is at " & - "most 0"); - - Attribute_Check_Block: - declare - - Del : constant := 1.0/10**2; - Const_Digits : constant := 3; - Two : constant := 2; - Ten : constant := 10; - - type Radix_2_Type_1 is delta 0.01 digits 7; - type Radix_2_Type_2 is delta Ada.Decimal.Min_Delta digits 10; - type Radix_2_Type_3 is - delta 0.000_1 digits Ada.Decimal.Max_Decimal_Digits; - - type Radix_10_Type_1 is delta 10.0**(-Ada.Decimal.Max_Scale) digits 8; - type Radix_10_Type_2 is delta 10.0**(-Ada.Decimal.Min_Scale) digits 6; - type Radix_10_Type_3 is delta Ada.Decimal.Max_Delta digits 15; - - - -- Use an attribute definition clause to set the Machine_Radix for a - -- decimal first subtype to either 2 or 10. - for Radix_2_Type_1'Machine_Radix use 2; - for Radix_2_Type_2'Machine_Radix use Two; - for Radix_2_Type_3'Machine_Radix use 10-8; - - for Radix_10_Type_1'Machine_Radix use 2*15/Const_Digits; - for Radix_10_Type_2'Machine_Radix use Ten; - for Radix_10_Type_3'Machine_Radix use Radix_10_Type_2'Machine_Radix; - - - begin - - -- Check that the attribute 'Machine_Radix returns the value assigned - -- by the attribute definition clause. - - if Radix_2_Type_1'Machine_Radix /= 2 or else - Radix_2_Type_2'Machine_Radix /= 2 or else - Radix_2_Type_3'Machine_Radix /= 2 - then - Report.Failed("Incorrect radix value returned, 2 expected"); - end if; - - if Radix_10_Type_1'Machine_Radix /= 10 or else - Radix_10_Type_2'Machine_Radix /= 10 or else - Radix_10_Type_3'Machine_Radix /= 10 - then - Report.Failed("Incorrect radix value returned, 10 expected"); - end if; - - exception - when others => Report.Failed ("Exception raised in Attr_Check_Block"); - end Attribute_Check_Block; - - - - Radix_Block: - -- Premises: - -- 1) Choose several numbers, from types using either decimal scaling or - -- binary scaling. - -- 1) Repetitively add these numbers to themselves. - -- 3) Validate that the result is the expected result, regardless of the - -- scaling used in the definition of the type. - declare - - Number_Of_Values : constant := 3; - Loop_Count : constant := 1000; - - type Radix_2_Type is delta 0.0001 digits 10; - type Radix_10_Type is delta 0.0001 digits 10; - - for Radix_2_Type'Machine_Radix use 2; - for Radix_10_Type'Machine_Radix use 10; - - type Result_Record_Type is record - Rad_2 : Radix_2_Type; - Rad_10 : Radix_10_Type; - end record; - - type Result_Array_Type is array (1..Number_Of_Values) - of Result_Record_Type; - - Result_Array : Result_Array_Type := ((50.00, 50.00), - (613.00, 613.00), - (72.70, 72.70)); - - function Repetitive_Radix_2_Add (Value : in Radix_2_Type) - return Radix_2_Type is - Result : Radix_2_Type := 0.0; - begin - for i in 1..Loop_Count loop - Result := Result + Value; - end loop; - return Result; - end Repetitive_Radix_2_Add; - - function Repetitive_Radix_10_Add (Value : in Radix_10_Type) - return Radix_10_Type is - Result : Radix_10_Type := 0.0; - begin - for i in 1..Loop_Count loop - Result := Result + Value; - end loop; - return Result; - end Repetitive_Radix_10_Add; - - begin - - -- Radix 2 Cases, three different values. - -- Compare the result of the repetitive addition with the expected - -- Radix 2 result, as well as with the Radix 10 value after type - -- conversion. - - if Repetitive_Radix_2_Add(0.05) /= Result_Array(1).Rad_2 or - Repetitive_Radix_2_Add(0.05) /= Radix_2_Type(Result_Array(1).Rad_10) - then - Report.Failed("Incorrect Radix 2 Result, Case 1"); - end if; - - if Repetitive_Radix_2_Add(0.613) /= - Result_Array(2).Rad_2 or - Repetitive_Radix_2_Add(0.613) /= - Radix_2_Type(Result_Array(2).Rad_10) - then - Report.Failed("Incorrect Radix 2 Result, Case 2"); - end if; - - if Repetitive_Radix_2_Add(0.0727) /= - Result_Array(3).Rad_2 or - Repetitive_Radix_2_Add(0.0727) /= - Radix_2_Type(Result_Array(3).Rad_10) - then - Report.Failed("Incorrect Radix 2 Result, Case 3"); - end if; - - -- Radix 10 Cases, three different values. - -- Compare the result of the repetitive addition with the expected - -- Radix 10 result, as well as with the Radix 2 value after type - -- conversion. - - if Repetitive_Radix_10_Add(0.05) /= Result_Array(1).Rad_10 or - Repetitive_Radix_10_Add(0.05) /= Radix_10_Type(Result_Array(1).Rad_2) - then - Report.Failed("Incorrect Radix 10 Result, Case 1"); - end if; - - if Repetitive_Radix_10_Add(0.613) /= - Result_Array(2).Rad_10 or - Repetitive_Radix_10_Add(0.613) /= - Radix_10_Type(Result_Array(2).Rad_2) - then - Report.Failed("Incorrect Radix 10 Result, Case 2"); - end if; - - if Repetitive_Radix_10_Add(0.0727) /= - Result_Array(3).Rad_10 or - Repetitive_Radix_10_Add(0.0727) /= - Radix_10_Type(Result_Array(3).Rad_2) - then - Report.Failed("Incorrect Radix 10 Result, Case 3"); - end if; - - exception - when others => Report.Failed ("Exception raised in Radix_Block"); - end Radix_Block; - - - - Size_Block: - -- Check the implementation max/min values of constants declared in - -- package Ada.Decimal. - declare - Minimum_Required_Size : constant := 18; - Maximum_Allowed_Size : constant := 0; - begin - - -- Check that the Max_Decimal_Digits value is at least 18. - if not (Ada.Decimal.Max_Decimal_Digits >= Minimum_Required_Size) then - Report.Failed("Insufficient size provided for Max_Decimal_Digits"); - end if; - - -- Check that the Max_Scale value is at least 18. - if not (Ada.Decimal.Max_Scale >= Minimum_Required_Size) then - Report.Failed("Insufficient size provided for Max_Scale"); - end if; - - -- Check that the Min_Scale value is at most 0. - if not (Ada.Decimal.Min_Scale <= Maximum_Allowed_Size) then - Report.Failed("Too large a value provided for Min_Scale"); - end if; - - exception - when others => Report.Failed ("Exception raised in Size_Block"); - end Size_Block; - - Report.Result; - -end CXF1001; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a deleted file mode 100644 index 96d0a0a17d3..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a +++ /dev/null @@ -1,755 +0,0 @@ --- CXF2001.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 Divide procedure provides the following results: --- Quotient = Dividend divided by Divisor and --- Remainder = Dividend - (Divisor * Quotient) --- Check that the Remainder is calculated exactly. --- --- TEST DESCRIPTION: --- This test is designed to test the generic procedure Divide found in --- package Ada.Decimal. --- --- 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 --- 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 --- 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 --- quotient | Q | R | Q | R | Q | R | Q | R | Q | R | No. --- --------------------------------------------------------------------------- --- .05 .3 |.1 .02 1,21 --- (.01) (.1) |.1 0 2,22 --- | .16 .002 3,23 --- 0.166666.. | .16 .00 4,24 --- | .166 .0002 5,25 --- --------------------------------------------------------------------------- --- .15 20 | .00 .1500 6,26 --- (.01) (1) | .00 .150 7,27 --- | .00 .15 8,28 --- 0.0075 | .01 .007 9,29 --- | .007 .010 10,30 --- | .0075 .0000 11,31 --- --------------------------------------------------------------------------- --- .03125 .5 | .0625 .0000 12,32 --- (.00001) (.1) | .062 .00025 13,33 --- | .062 .0002 14,34 --- 0.0625 | .062 .000 15,35 --- | .00 .062 16,36 --- | .06 .00125 17,37 --- | .06 .0012 18,38 --- | .06 .001 19,39 --- | .06 .00 20,40 --- --------------------------------------------------------------------------- --- 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 --- 15 Nov 95 SAIC Incorporated reviewer fixes for ACVC 2.0.1. --- ---! - -with Report; -with Ada.Decimal; - -procedure CXF2001 is - - TC_Verbose : Boolean := False; - -begin - - Report.Test ("CXF2001", "Check that the Divide procedure provides " & - "correct results. Check that the Remainder " & - "is calculated exactly"); - Radix_10_Block: - declare - - - -- 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; - - for DT_1'Machine_Radix use 10; - for DT_0_1'Machine_Radix use 10; - for DT_0_01'Machine_Radix use 10; - for DT_0_001'Machine_Radix use 10; - for DT_0_0001'Machine_Radix use 10; - for DT_0_00001'Machine_Radix use 10; - - Dd_1, Dv_1, Quot_1, Rem_1 : DT_1 := 0.0; - Dd_0_1, Dv_0_1, Quot_0_1, Rem_0_1 : DT_0_1 := 0.0; - Dd_0_01, Dv_0_01, Quot_0_01, Rem_0_01 : DT_0_01 := 0.0; - Dd_0_001, Dv_0_001, Quot_0_001, Rem_0_001 : DT_0_001 := 0.0; - 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 - - - declare - procedure Div is - new Ada.Decimal.Divide(Dividend_Type => DT_0_01, - Divisor_Type => DT_0_1, - Quotient_Type => DT_0_1, - Remainder_Type => DT_0_01); - begin - if TC_Verbose then Report.Comment("Case 1"); 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_1, Rem_0_01); - if Quot_0_1 /= DT_0_1(0.1) or Rem_0_01 /= DT_0_01(0.02) then - Report.Failed("Incorrect values returned, Case 1"); - end if; - end; - - - declare - 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; - 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_1, Rem_0_1); - if Quot_0_1 /= DT_0_1(0.1) or Rem_0_1 /= DT_0_1(0.0) then - Report.Failed("Incorrect values returned, Case 2"); - end if; - end; - - - declare - 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; - 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_01, Rem_0_001); - if Quot_0_01 /= DT_0_01(0.16) or Rem_0_001 /= DT_0_001(0.002) then - Report.Failed("Incorrect values returned, Case 3"); - end if; - end; - - - declare - 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; - 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_01, Rem_0_01); - if Quot_0_01 /= DT_0_01(0.16) or Rem_0_01 /= DT_0_01(0.0) then - Report.Failed("Incorrect values returned, Case 4"); - end if; - end; - - - declare - 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) - then - Report.Failed("Incorrect values returned, Case 5"); - end if; - end; - - - declare - 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; - Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); - Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_0001); - if Quot_0_01 /= DT_0_01(0.0) or Rem_0_0001 /= DT_0_0001(0.1500) then - Report.Failed("Incorrect values returned, Case 6"); - end if; - end; - - - declare - 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; - Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); - Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_001); - if Quot_0_01 /= DT_0_01(0.0) or Rem_0_001 /= DT_0_001(0.150) then - Report.Failed("Incorrect values returned, Case 7"); - end if; - end; - - - declare - 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; - Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); - Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_01); - if Quot_0_01 /= DT_0_01(0.0) or Rem_0_01 /= DT_0_01(0.15) then - Report.Failed("Incorrect values returned, Case 8"); - end if; - end; - - - declare - 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; - Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); - Div(Dd_0_01, Dv_1, Quot_0_001, Rem_0_001); - if Quot_0_001 /= DT_0_001(0.007) or Rem_0_001 /= DT_0_001(0.01) then - Report.Failed("Incorrect values returned, Case 9"); - end if; - end; - - - declare - 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; - Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); - Div(Dd_0_01, Dv_1, Quot_0_001, Rem_0_01); - if Quot_0_001 /= DT_0_001(0.007) or Rem_0_01 /= DT_0_01(0.01) then - Report.Failed("Incorrect values returned, Case 10"); - end if; - end; - - - declare - 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) - then - Report.Failed("Incorrect values returned, Case 11"); - end if; - end; - - - declare - 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) - then - Report.Failed("Incorrect values returned, Case 12"); - end if; - end; - - - declare - 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 - Rem_0_00001 /= DT_0_00001(0.00025) - then - Report.Failed("Incorrect values returned, Case 13"); - end if; - end; - - - declare - 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 - Rem_0_0001 /= DT_0_0001(0.0002) - then - Report.Failed("Incorrect values returned, Case 14"); - end if; - end; - - - declare - 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; - 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_001); - if Quot_0_001 /= DT_0_001(0.062) or Rem_0_001 /= DT_0_001(0.000) - then - Report.Failed("Incorrect values returned, Case 15"); - end if; - end; - - - declare - 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; - 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_01); - if Quot_0_001 /= DT_0_001(0.062) or Rem_0_01 /= DT_0_01(0.00) then - Report.Failed("Incorrect values returned, Case 16"); - end if; - end; - - - declare - 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) - then - Report.Failed("Incorrect values returned, Case 17"); - end if; - end; - - - declare - 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) - then - Report.Failed("Incorrect values returned, Case 18"); - end if; - end; - - - declare - 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; - 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_001); - if Quot_0_01 /= DT_0_01(0.06) or Rem_0_001 /= DT_0_001(0.001) then - Report.Failed("Incorrect values returned, Case 19"); - end if; - end; - - - declare - 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; - 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_01); - if Quot_0_01 /= DT_0_01(0.06) or Rem_0_01 /= DT_0_01(0.0) then - Report.Failed("Incorrect values returned, Case 20"); - end if; - end; - - - exception - when others => Report.Failed("Exception raised in Radix_10_Block"); - end Radix_10_Block; - - - - Radix_2_Block: - declare - - -- 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; - - for DT_1'Machine_Radix use 2; - for DT_0_1'Machine_Radix use 2; - for DT_0_01'Machine_Radix use 2; - for DT_0_001'Machine_Radix use 2; - for DT_0_0001'Machine_Radix use 2; - for DT_0_00001'Machine_Radix use 2; - - Dd_1, Dv_1, Quot_1, Rem_1 : DT_1 := 0.0; - Dd_0_1, Dv_0_1, Quot_0_1, Rem_0_1 : DT_0_1 := 0.0; - Dd_0_01, Dv_0_01, Quot_0_01, Rem_0_01 : DT_0_01 := 0.0; - Dd_0_001, Dv_0_001, Quot_0_001, Rem_0_001 : DT_0_001 := 0.0; - 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 - - - declare - procedure Div is - new Ada.Decimal.Divide(Dividend_Type => DT_0_01, - Divisor_Type => DT_0_1, - Quotient_Type => DT_0_1, - Remainder_Type => DT_0_01); - begin - if TC_Verbose then Report.Comment("Case 21"); 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_1, Rem_0_01); - if Quot_0_1 /= DT_0_1(0.1) or Rem_0_01 /= DT_0_01(0.02) then - Report.Failed("Incorrect values returned, Case 21"); - end if; - end; - - - declare - 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; - 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_1, Rem_0_1); - if Quot_0_1 /= DT_0_1(0.1) or Rem_0_1 /= DT_0_1(0.0) then - Report.Failed("Incorrect values returned, Case 22"); - end if; - end; - - - declare - 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; - 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_01, Rem_0_001); - if Quot_0_01 /= DT_0_01(0.16) or Rem_0_001 /= DT_0_001(0.002) then - Report.Failed("Incorrect values returned, Case 23"); - end if; - end; - - - declare - 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; - 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_01, Rem_0_01); - if Quot_0_01 /= DT_0_01(0.16) or Rem_0_01 /= DT_0_01(0.0) then - Report.Failed("Incorrect values returned, Case 24"); - end if; - end; - - - declare - 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) - then - Report.Failed("Incorrect values returned, Case 25"); - end if; - end; - - - declare - 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; - Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); - Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_0001); - if Quot_0_01 /= DT_0_01(0.0) or Rem_0_0001 /= DT_0_0001(0.1500) then - Report.Failed("Incorrect values returned, Case 26"); - end if; - end; - - - declare - 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; - Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); - Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_001); - if Quot_0_01 /= DT_0_01(0.0) or Rem_0_001 /= DT_0_001(0.150) then - Report.Failed("Incorrect values returned, Case 27"); - end if; - end; - - - declare - 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; - Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); - Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_01); - if Quot_0_01 /= DT_0_01(0.0) or Rem_0_01 /= DT_0_01(0.15) then - Report.Failed("Incorrect values returned, Case 28"); - end if; - end; - - - declare - 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; - Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); - Div(Dd_0_01, Dv_1, Quot_0_001, Rem_0_001); - if Quot_0_001 /= DT_0_001(0.007) or Rem_0_001 /= DT_0_001(0.01) then - Report.Failed("Incorrect values returned, Case 29"); - end if; - end; - - - declare - 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; - Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); - Div(Dd_0_01, Dv_1, Quot_0_001, Rem_0_01); - if Quot_0_001 /= DT_0_001(0.007) or Rem_0_01 /= DT_0_01(0.01) then - Report.Failed("Incorrect values returned, Case 30"); - end if; - end; - - - declare - 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) - then - Report.Failed("Incorrect values returned, Case 31"); - end if; - end; - - - declare - 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) - then - Report.Failed("Incorrect values returned, Case 32"); - end if; - end; - - - declare - 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 - Rem_0_00001 /= DT_0_00001(0.00025) - then - Report.Failed("Incorrect values returned, Case 33"); - end if; - end; - - - declare - 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 - Rem_0_0001 /= DT_0_0001(0.0002) - then - Report.Failed("Incorrect values returned, Case 34"); - end if; - end; - - - declare - 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; - 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_001); - if Quot_0_001 /= DT_0_001(0.062) or Rem_0_001 /= DT_0_001(0.000) - then - Report.Failed("Incorrect values returned, Case 35"); - end if; - end; - - - declare - 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; - 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_01); - if Quot_0_001 /= DT_0_001(0.062) or Rem_0_01 /= DT_0_01(0.00) then - Report.Failed("Incorrect values returned, Case 36"); - end if; - end; - - - declare - 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) - then - Report.Failed("Incorrect values returned, Case 37"); - end if; - end; - - - declare - 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) - then - Report.Failed("Incorrect values returned, Case 38"); - end if; - end; - - - declare - 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; - 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_001); - if Quot_0_01 /= DT_0_01(0.06) or Rem_0_001 /= DT_0_001(0.001) then - Report.Failed("Incorrect values returned, Case 39"); - end if; - end; - - - declare - 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; - 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_01); - if Quot_0_01 /= DT_0_01(0.06) or Rem_0_01 /= DT_0_01(0.0) then - Report.Failed("Incorrect values returned, Case 40"); - end if; - end; - - declare - 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)); - 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 => - Report.Failed("Unexpected exception raised by Divide by Zero," & - "Case 41"); - end; - - exception - when others => Report.Failed("Exception raised in Radix_10_Block"); - end Radix_2_Block; - - - Report.Result; - -end CXF2001; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2002.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2002.a deleted file mode 100644 index 984daa97bca..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf2002.a +++ /dev/null @@ -1,352 +0,0 @@ --- CXF2002.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 multiplying operators for a decimal fixed point type --- return values that are integral multiples of the small of the type. --- Check the case where the operand and result types are the same. --- --- Check that if the mathematical result is between multiples of the --- small of the result type, the result is truncated toward zero. --- Check that if the attribute 'Round is applied to the mathematical --- result, however, the result is rounded to the nearest multiple of --- the small (away from zero if the result is midway between two --- multiples of the small). --- --- TEST DESCRIPTION: --- Two decimal fixed point types are declared, one with a Machine_Radix --- value of 2, and one with a value of 10. For each type, checks are --- performed on the following operations, where the operand and result --- types are the same: --- --- - Multiplication. --- - Multiplication, where the attribute 'Round is applied to the --- result. --- - Division. --- - Division, where the attribute 'Round is applied to the result. --- --- Each operation is performed within a loop, where one operand is --- always the same variable. After the loop completes, the cumulative --- total contained in this variable is compared with the expected --- result. --- --- APPLICABILITY CRITERIA: --- This test is only applicable for a compiler attempting validation --- for the Information Systems Annex. --- --- --- CHANGE HISTORY: --- 27 Mar 96 SAIC Prerelease version for ACVC 2.1. --- ---! - -generic - type Decimal_Fixed is delta <> digits <>; -package CXF2002_0 is - - procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed; - Factor : in Decimal_Fixed); - - procedure Divide_And_Truncate (Balance : in out Decimal_Fixed; - Divisor : in Decimal_Fixed); - - procedure Multiply_And_Round (Balance : in out Decimal_Fixed; - Factor : in Decimal_Fixed); - - procedure Divide_And_Round (Balance : in out Decimal_Fixed; - Divisor : in Decimal_Fixed); - -end CXF2002_0; - - - --==================================================================-- - - -package body CXF2002_0 is - - procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed; - Factor : in Decimal_Fixed) is - Interest : Decimal_Fixed; - begin - Interest := Factor * Balance; -- Fixed-fixed multiplication. - Balance := Balance + Interest; - end Multiply_And_Truncate; - - - procedure Divide_And_Truncate (Balance : in out Decimal_Fixed; - Divisor : in Decimal_Fixed) is - Interest : Decimal_Fixed; - begin - Interest := Balance / Divisor; -- Fixed-fixed division. - Balance := Balance + Interest; - end Divide_And_Truncate; - - - procedure Multiply_And_Round (Balance : in out Decimal_Fixed; - Factor : in Decimal_Fixed) is - Interest : Decimal_Fixed; - begin - -- Fixed-fixed multiplication. - Interest := Decimal_Fixed'Round ( Factor * Balance ); - Balance := Balance + Interest; - end Multiply_And_Round; - - - procedure Divide_And_Round (Balance : in out Decimal_Fixed; - Divisor : in Decimal_Fixed) is - Interest : Decimal_Fixed; - begin - -- Fixed-fixed division. - Interest := Decimal_Fixed'Round ( Balance / Divisor ); - Balance := Balance + Interest; - end Divide_And_Round; - -end CXF2002_0; - - - --==================================================================-- - - -package CXF2002_1 is - - type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 .. - for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99 - - - type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 .. - for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99 - -end CXF2002_1; - - - --==================================================================-- - - -with CXF2002_0; -with CXF2002_1; - -with Report; -procedure CXF2002 is - - Loop_Count : constant := 300; - type Loop_Range is range 1 .. Loop_Count; - -begin - - Report.Test ("CXF2002", "Check decimal multiplication and division, and " & - "'Round, where the operand and result types are " & - "the same"); - - - ---=---=---=---=---=---=---=---=---=---=--- - - - RADIX_2_SUBTESTS: - declare - package Radix_2 is new CXF2002_0 (CXF2002_1.Money_Radix2); - use type CXF2002_1.Money_Radix2; - begin - - RADIX_2_MULTIPLICATION: - declare - Rate : constant CXF2002_1.Money_Radix2 := 0.12; - Period : constant Integer := 12; - Factor : CXF2002_1.Money_Radix2 := Rate / Period; - - Initial : constant CXF2002_1.Money_Radix2 := 100_000.00; - Trunc_Expected : constant CXF2002_1.Money_Radix2 := 1_978_837.50; - Round_Expected : constant CXF2002_1.Money_Radix2 := 1_978_846.75; - - Balance : CXF2002_1.Money_Radix2; - begin - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_2.Multiply_And_Truncate (Balance, Factor); - end loop; - - if Balance /= Trunc_Expected then - Report.Failed ("Wrong result: Radix 2 multiply and truncate"); - end if; - - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_2.Multiply_And_Round (Balance, Factor); - end loop; - - if Balance /= Round_Expected then - Report.Failed ("Wrong result: Radix 2 multiply and round"); - end if; - - ---=---=---=---=---=---=--- - end RADIX_2_MULTIPLICATION; - - - RADIX_2_DIVISION: - declare - Rate : constant CXF2002_1.Money_Radix2 := 0.25; - Period : constant Integer := 12; - Factor : CXF2002_1.Money_Radix2 := Rate / Period; - Divisor : constant CXF2002_1.Money_Radix2 := 1.0 / Factor; - - Initial : constant CXF2002_1.Money_Radix2 := 5_500.36; - Trunc_Expected : constant CXF2002_1.Money_Radix2 := 2_091_332.87; - Round_Expected : constant CXF2002_1.Money_Radix2 := 2_091_436.88; - - Balance : CXF2002_1.Money_Radix2; - begin - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_2.Divide_And_Truncate (Balance, Divisor); - end loop; - - if Balance /= Trunc_Expected then - Report.Failed ("Wrong result: Radix 2 divide and truncate"); - end if; - - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_2.Divide_And_Round (Balance, Divisor); - end loop; - - if Balance /= Round_Expected then - Report.Failed ("Wrong result: Radix 2 divide and round"); - end if; - - ---=---=---=---=---=---=--- - end RADIX_2_DIVISION; - - end RADIX_2_SUBTESTS; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - RADIX_10_SUBTESTS: - declare - package Radix_10 is new CXF2002_0 (CXF2002_1.Money_Radix10); - use type CXF2002_1.Money_Radix10; - begin - - RADIX_10_MULTIPLICATION: - declare - Rate : constant CXF2002_1.Money_Radix10 := 0.37; - Period : constant Integer := 12; - Factor : CXF2002_1.Money_Radix10 := Rate / Period; - - Initial : constant CXF2002_1.Money_Radix10 := 459.33; - Trunc_Expected : constant CXF2002_1.Money_Radix10 := 3_259_305.54; - Round_Expected : constant CXF2002_1.Money_Radix10 := 3_260_544.11; - - Balance : CXF2002_1.Money_Radix10; - begin - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_10.Multiply_And_Truncate (Balance, Factor); - end loop; - - if Balance /= Trunc_Expected then - Report.Failed ("Wrong result: Radix 10 multiply and truncate"); - end if; - - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_10.Multiply_And_Round (Balance, Factor); - end loop; - - if Balance /= Round_Expected then - Report.Failed ("Wrong result: Radix 10 multiply and round"); - end if; - - ---=---=---=---=---=---=--- - end RADIX_10_MULTIPLICATION; - - - RADIX_10_DIVISION: - declare - Rate : constant CXF2002_1.Money_Radix10 := 0.15; - Period : constant Integer := 12; - Factor : CXF2002_1.Money_Radix10 := Rate / Period; - Divisor : constant CXF2002_1.Money_Radix10 := 1.0 / Factor; - - Initial : constant CXF2002_1.Money_Radix10 := 29_842.08; - Trunc_Expected : constant CXF2002_1.Money_Radix10 := 590_519.47; - Round_Expected : constant CXF2002_1.Money_Radix10 := 590_528.98; - - Balance : CXF2002_1.Money_Radix10; - begin - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_10.Divide_And_Truncate (Balance, Divisor); - end loop; - - if Balance /= Trunc_Expected then - Report.Failed ("Wrong result: Radix 10 divide and truncate"); - end if; - - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_10.Divide_And_Round (Balance, Divisor); - end loop; - - if Balance /= Round_Expected then - Report.Failed ("Wrong result: Radix 10 divide and round"); - end if; - - ---=---=---=---=---=---=--- - end RADIX_10_DIVISION; - - end RADIX_10_SUBTESTS; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - Report.Result; - -end CXF2002; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a deleted file mode 100644 index 133dc48e6c2..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a +++ /dev/null @@ -1,363 +0,0 @@ --- CXF2003.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 multiplying operators for a decimal fixed point type --- return values that are integral multiples of the small of the type. --- Check the case where the two operands are of different decimal --- fixed point types. --- --- Check that if the mathematical result is between multiples of the --- small of the result type, the result is truncated toward zero. --- Check that if the attribute 'Round is applied to the mathematical --- result, however, the result is rounded to the nearest multiple of --- the small (away from zero if the result is midway between two --- multiples of the small). --- --- TEST DESCRIPTION: --- Two decimal fixed point types A and B are declared, one with a --- Machine_Radix value of 2, and one with a value of 10. A third decimal --- fixed point type C is declared with digits and delta values different --- from those of A and B. For type A (and B), checks are performed --- on the following operations, where one operand type is C, and the --- other operand type and the result type is A (or B): --- --- - Multiplication. --- - Multiplication, where the attribute 'Round is applied to the --- result. --- - Division. --- - Division, where the attribute 'Round is applied to the result. --- --- Each operation is performed within a loop, where one operand is --- always the same variable. After the loop completes, the cumulative --- total contained in this variable is compared with the expected --- result. --- --- APPLICABILITY CRITERIA: --- This test is only applicable for a compiler attempting validation --- for the Information Systems Annex. --- --- --- CHANGE HISTORY: --- 22 Mar 96 SAIC Prerelease version for ACVC 2.1. --- ---! - -generic - type Decimal_Fixed_1 is delta <> digits <>; - type Decimal_Fixed_2 is delta <> digits <>; -package CXF2003_0 is - - procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed_1; - Factor : in Decimal_Fixed_2); - - procedure Divide_And_Truncate (Balance : in out Decimal_Fixed_1; - Divisor : in Decimal_Fixed_2); - - procedure Multiply_And_Round (Balance : in out Decimal_Fixed_1; - Factor : in Decimal_Fixed_2); - - procedure Divide_And_Round (Balance : in out Decimal_Fixed_1; - Divisor : in Decimal_Fixed_2); - -end CXF2003_0; - - - --==================================================================-- - - -package body CXF2003_0 is - - procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed_1; - Factor : in Decimal_Fixed_2) is - Interest : Decimal_Fixed_1; - begin - Interest := Factor * Balance; -- Fixed-fixed multiplication. - Balance := Balance + Interest; - end Multiply_And_Truncate; - - - procedure Divide_And_Truncate (Balance : in out Decimal_Fixed_1; - Divisor : in Decimal_Fixed_2) is - Interest : Decimal_Fixed_1; - begin - Interest := Balance / Divisor; -- Fixed-fixed division. - Balance := Balance + Interest; - end Divide_And_Truncate; - - - procedure Multiply_And_Round (Balance : in out Decimal_Fixed_1; - Factor : in Decimal_Fixed_2) is - Interest : Decimal_Fixed_1; - begin - -- Fixed-fixed multiplication. - Interest := Decimal_Fixed_1'Round ( Factor * Balance ); - Balance := Balance + Interest; - end Multiply_And_Round; - - - procedure Divide_And_Round (Balance : in out Decimal_Fixed_1; - Divisor : in Decimal_Fixed_2) is - Interest : Decimal_Fixed_1; - begin - -- Fixed-fixed division. - Interest := Decimal_Fixed_1'Round ( Balance / Divisor ); - Balance := Balance + Interest; - end Divide_And_Round; - -end CXF2003_0; - - - --==================================================================-- - - -package CXF2003_1 is - - type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 .. - for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99 - - - type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 .. - for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99 - - - type Interest_Rate is delta 0.00001 digits 9; -- range -9999.99999 .. - -- +9999.99999 - -end CXF2003_1; - - - --==================================================================-- - - -with CXF2003_0; -with CXF2003_1; - -with Report; -procedure CXF2003 is - - Loop_Count : constant := 1825; - type Loop_Range is range 1 .. Loop_Count; - -begin - - Report.Test ("CXF2003", "Check decimal multiplication and division, and " & - "'Round, where the operand types are different"); - - - ---=---=---=---=---=---=---=---=---=---=--- - - - RADIX_2_SUBTESTS: - declare - package Radix_2 is new CXF2003_0 (CXF2003_1.Money_Radix2, - CXF2003_1.Interest_Rate); - use type CXF2003_1.Money_Radix2; - use type CXF2003_1.Interest_Rate; - begin - - RADIX_2_MULTIPLICATION: - declare - Rate : CXF2003_1.Interest_Rate := 0.198; - Period : Integer := 365; - Factor : CXF2003_1.Interest_Rate := Rate / Period; - - Initial : constant CXF2003_1.Money_Radix2 := 1_000.00; - Trunc_Expected : constant CXF2003_1.Money_Radix2 := 2_662.94; - Round_Expected : constant CXF2003_1.Money_Radix2 := 2_678.34; - - Balance : CXF2003_1.Money_Radix2; - begin - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_2.Multiply_And_Truncate (Balance, Factor); - end loop; - - if Balance /= Trunc_Expected then - Report.Failed ("Wrong result: Radix 2 multiply and truncate"); - end if; - - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_2.Multiply_And_Round (Balance, Factor); - end loop; - - if Balance /= Round_Expected then - Report.Failed ("Wrong result: Radix 2 multiply and round"); - end if; - - ---=---=---=---=---=---=--- - end RADIX_2_MULTIPLICATION; - - - RADIX_2_DIVISION: - declare - Rate : CXF2003_1.Interest_Rate := 0.129; - Period : Integer := 365; - Factor : CXF2003_1.Interest_Rate := Rate / Period; - Divisor : CXF2003_1.Interest_Rate := 1.0 / Factor; - - Initial : constant CXF2003_1.Money_Radix2 := 14_626.52; - Trunc_Expected : constant CXF2003_1.Money_Radix2 := 27_688.26; - Round_Expected : constant CXF2003_1.Money_Radix2 := 27_701.12; - - Balance : CXF2003_1.Money_Radix2; - begin - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_2.Divide_And_Truncate (Balance, Divisor); - end loop; - - if Balance /= Trunc_Expected then - Report.Failed ("Wrong result: Radix 2 divide and truncate"); - end if; - - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_2.Divide_And_Round (Balance, Divisor); - end loop; - - if Balance /= Round_Expected then - Report.Failed ("Wrong result: Radix 2 divide and round"); - end if; - - ---=---=---=---=---=---=--- - end RADIX_2_DIVISION; - - end RADIX_2_SUBTESTS; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - RADIX_10_SUBTESTS: - declare - package Radix_10 is new CXF2003_0 (CXF2003_1.Money_Radix10, - CXF2003_1.Interest_Rate); - use type CXF2003_1.Money_Radix10; - use type CXF2003_1.Interest_Rate; - begin - - RADIX_10_MULTIPLICATION: - declare - Rate : CXF2003_1.Interest_Rate := 0.063; - Period : Integer := 365; - Factor : CXF2003_1.Interest_Rate := Rate / Period; - - Initial : constant CXF2003_1.Money_Radix10 := 314_036.10; - Trunc_Expected : constant CXF2003_1.Money_Radix10 := 428_249.48; - Round_Expected : constant CXF2003_1.Money_Radix10 := 428_260.52; - - Balance : CXF2003_1.Money_Radix10; - begin - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_10.Multiply_And_Truncate (Balance, Factor); - end loop; - - if Balance /= Trunc_Expected then - Report.Failed ("Wrong result: Radix 10 multiply and truncate"); - end if; - - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_10.Multiply_And_Round (Balance, Factor); - end loop; - - if Balance /= Round_Expected then - Report.Failed ("Wrong result: Radix 10 multiply and round"); - end if; - - ---=---=---=---=---=---=--- - end RADIX_10_MULTIPLICATION; - - - RADIX_10_DIVISION: - declare - Rate : CXF2003_1.Interest_Rate := 0.273; - Period : Integer := 365; - Factor : CXF2003_1.Interest_Rate := Rate / Period; - Divisor : CXF2003_1.Interest_Rate := 1.0 / Factor; - - Initial : constant CXF2003_1.Money_Radix10 := 25.72; - Trunc_Expected : constant CXF2003_1.Money_Radix10 := 79.05; - Round_Expected : constant CXF2003_1.Money_Radix10 := 97.46; - - Balance : CXF2003_1.Money_Radix10; - begin - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_10.Divide_And_Truncate (Balance, Divisor); - end loop; - - if Balance /= Trunc_Expected then - Report.Failed ("Wrong result: Radix 10 divide and truncate"); - end if; - - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_10.Divide_And_Round (Balance, Divisor); - end loop; - - if Balance /= Round_Expected then - Report.Failed ("Wrong result: Radix 10 divide and round"); - end if; - - ---=---=---=---=---=---=--- - end RADIX_10_DIVISION; - - end RADIX_10_SUBTESTS; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - Report.Result; - -end CXF2003; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a deleted file mode 100644 index 9651384ce7e..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a +++ /dev/null @@ -1,513 +0,0 @@ --- CXF2004.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 multiplying operators for a decimal fixed point type --- return values that are integral multiples of the small of the type. --- Check the case where one operand is of an ordinary fixed point type. --- --- Check that if the mathematical result is between multiples of the --- small of the result type, the result is truncated toward zero. --- Check that if the attribute 'Round is applied to the mathematical --- result, however, the result is rounded to the nearest multiple of --- the small (away from zero if the result is midway between two --- multiples of the small). --- --- TEST DESCRIPTION: --- Two decimal fixed point types A and B are declared, one with a --- Machine_Radix value of 2, and one with a value of 10. An ordinary --- fixed point type C is declared with a delta value different from --- those of A and B (although still a power of 10). For type A (and B), --- checks are performed on the following operations, where one operand --- type is C, and the other operand type and the result type is A (or B): --- --- - Multiplication. --- - Multiplication, where the attribute 'Round is applied to the --- result. --- - Division. --- - Division, where the attribute 'Round is applied to the result. --- --- Each operation is performed within a loop, where one operand is --- always the same variable. After the loop completes, the cumulative --- total contained in this variable is compared with the expected --- result. --- --- APPLICABILITY CRITERIA: --- This test is only applicable for a compiler attempting validation --- for the Information Systems Annex. --- --- --- CHANGE HISTORY: --- 22 Mar 96 SAIC Prerelease version for ACVC 2.1. --- 11 Aug 96 SAIC ACVC 2.1: In RADIX_2_MULTIPLICATION, corrected --- value of Rate. Corrected associated commentary. --- ---! - -generic - type Decimal_Fixed is delta <> digits <>; - type Ordinary_Fixed is delta <>; -package CXF2004_0 is - - procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed; - Factor : in Ordinary_Fixed); - - procedure Divide_And_Truncate (Balance : in out Decimal_Fixed; - Divisor : in Ordinary_Fixed); - - procedure Multiply_And_Round (Balance : in out Decimal_Fixed; - Factor : in Ordinary_Fixed); - - procedure Divide_And_Round (Balance : in out Decimal_Fixed; - Divisor : in Ordinary_Fixed); - -end CXF2004_0; - - - --==================================================================-- - - -package body CXF2004_0 is - - procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed; - Factor : in Ordinary_Fixed) is - Interest : Decimal_Fixed; - begin - Interest := Factor * Balance; -- Fixed-fixed multiplication. - Balance := Balance + Interest; - end Multiply_And_Truncate; - - - procedure Divide_And_Truncate (Balance : in out Decimal_Fixed; - Divisor : in Ordinary_Fixed) is - Interest : Decimal_Fixed; - begin - Interest := Balance / Divisor; -- Fixed-fixed division. - Balance := Balance + Interest; - end Divide_And_Truncate; - - - procedure Multiply_And_Round (Balance : in out Decimal_Fixed; - Factor : in Ordinary_Fixed) is - Interest : Decimal_Fixed; - begin - -- Fixed-fixed multiplication. - Interest := Decimal_Fixed'Round ( Factor * Balance ); - Balance := Balance + Interest; - end Multiply_And_Round; - - - procedure Divide_And_Round (Balance : in out Decimal_Fixed; - Divisor : in Ordinary_Fixed) is - Interest : Decimal_Fixed; - begin - -- Fixed-fixed division. - Interest := Decimal_Fixed'Round ( Balance / Divisor ); - Balance := Balance + Interest; - end Divide_And_Round; - -end CXF2004_0; - - - --==================================================================-- - - -package CXF2004_1 is - - type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 .. - for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99 - - - type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 .. - for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99 - - - type Interest_Rate is delta 0.001 range 0.0 .. 1_000.0; - for Interest_Rate'Small use 0.001; -- Power of 10. - -end CXF2004_1; - - - --==================================================================-- - - -with CXF2004_0; -with CXF2004_1; - -with Report; -procedure CXF2004 is - - Loop_Count : constant := 180; - type Loop_Range is range 1 .. Loop_Count; - - type Rounding_Scheme is ( Rounds, Truncates ); - Machine : Rounding_Scheme; - -begin - - Report.Test ("CXF2004", "Check decimal multiplication and division, and " & - "'Round, where one operand type is ordinary fixed"); - - - ---=---=---=---=---=---=---=---=---=---=--- - - if CXF2004_1.Interest_Rate'Machine_Rounds then -- Determine machine's - Machine := Rounds; -- rounding scheme. - else - Machine := Truncates; - end if; - - ---=---=---=---=---=---=---=---=---=---=--- - - - RADIX_2_SUBTESTS: - declare - package Radix_2 is new CXF2004_0 (CXF2004_1.Money_Radix2, - CXF2004_1.Interest_Rate); - use type CXF2004_1.Money_Radix2; - use type CXF2004_1.Interest_Rate; - begin - - RADIX_2_MULTIPLICATION: - declare - Rate : constant CXF2004_1.Interest_Rate := 0.154; - Period : constant Integer := 12; - Factor : CXF2004_1.Interest_Rate := Rate / Period; - - -- The exact value of Factor is: - -- - -- 0.154/12 = 0.01283333... - -- - -- The adjacent multiples of small are 0.012 and 0.013. Since - -- Factor is of an ordinary fixed point type, it may contain either - -- of these values. However, since "Rate / Period" is a static - -- expression, the value Factor contains is determined by the - -- value of CXF2004_1.Interest_Rate'Machine_Rounds: - -- - -- If Machine_Rounds = FALSE : Factor = 0.012 - -- If Machine_Rounds = TRUE : Factor = 0.013 - - Initial : constant CXF2004_1.Money_Radix2 := 1_000.00; - - Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 8_557.07; - Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 8_560.47; - - Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 10_222.65; - Round_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 10_225.81; - - Balance : CXF2004_1.Money_Radix2; - begin - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_2.Multiply_And_Truncate (Balance, Factor); - end loop; - - case (Machine) is - when Rounds => - if Balance /= Trunc_Expected_MachRnds then - Report.Failed ("Error (R): Radix 2 multiply and truncate"); - end if; - when Truncates => - if Balance /= Trunc_Expected_MachTrnc then - Report.Failed ("Error (T): Radix 2 multiply and truncate"); - end if; - end case; - - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_2.Multiply_And_Round (Balance, Factor); - end loop; - - case (Machine) is - when Rounds => - if Balance /= Round_Expected_MachRnds then - Report.Failed ("Error (R): Radix 2 multiply and round"); - end if; - when Truncates => - if Balance /= Round_Expected_MachTrnc then - Report.Failed ("Error (T): Radix 2 multiply and round"); - end if; - end case; - - ---=---=---=---=---=---=--- - end RADIX_2_MULTIPLICATION; - - - RADIX_2_DIVISION: - declare - Rate : constant CXF2004_1.Interest_Rate := 0.210; - Period : constant Integer := 12; - Factor : constant CXF2004_1.Interest_Rate := Rate / Period; - Divisor : CXF2004_1.Interest_Rate := 1.0 / Factor; - - -- The exact value of Factor is: - -- - -- 0.210/12 = 0.0175 - -- - -- The adjacent multiples of small are 0.017 and 0.018. Since - -- Factor is of an ordinary fixed point type, it may contain either - -- of these values. However, since "Rate / Period" is a static - -- expression, the value Factor contains is determined by the - -- value of CXF2004_1.Interest_Rate'Machine_Rounds: - -- - -- If Machine_Rounds = FALSE : Factor = 0.017 - -- If Machine_Rounds = TRUE : Factor = 0.018 - -- - -- The exact value of Divisor is one of the following values: - -- - -- 1.0/0.017 = 58.82352... (Adjacent smalls 58.823 and 58.824) - -- 1.0/0.018 = 55.55555... (Adjacent smalls 55.555 and 55.556) - -- - -- Again, since "1.0 / Factor" is static, the value Divisor contains - -- is determined by the value of CXF2004_1.Interest_Rate'Rounds: - -- - -- If Machine_Rounds = FALSE : Divisor = 58.823 - -- If Machine_Rounds = TRUE : Divisor = 55.556 - - Initial : constant CXF2004_1.Money_Radix2 := 260.13; - - Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 5_401.46; - Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 5_406.95; - - Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 6_446.56; - Round_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 6_453.78; - - Balance : CXF2004_1.Money_Radix2; - begin - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_2.Divide_And_Truncate (Balance, Divisor); - end loop; - - case (Machine) is - when Rounds => - if Balance /= Trunc_Expected_MachRnds then - Report.Failed ("Error (R): Radix 2 divide and truncate"); - end if; - when Truncates => - if Balance /= Trunc_Expected_MachTrnc then - Report.Failed ("Error (T): Radix 2 divide and truncate"); - end if; - end case; - - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_2.Divide_And_Round (Balance, Divisor); - end loop; - - case (Machine) is - when Rounds => - if Balance /= Round_Expected_MachRnds then - Report.Failed ("Error (R): Radix 2 divide and round"); - end if; - when Truncates => - if Balance /= Round_Expected_MachTrnc then - Report.Failed ("Error (T): Radix 2 divide and round"); - end if; - end case; - - ---=---=---=---=---=---=--- - end RADIX_2_DIVISION; - - end RADIX_2_SUBTESTS; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - RADIX_10_SUBTESTS: - declare - package Radix_10 is new CXF2004_0 (CXF2004_1.Money_Radix10, - CXF2004_1.Interest_Rate); - use type CXF2004_1.Money_Radix10; - use type CXF2004_1.Interest_Rate; - begin - - RADIX_10_MULTIPLICATION: - declare - Rate : constant CXF2004_1.Interest_Rate := 0.095; - Period : constant Integer := 12; - Factor : CXF2004_1.Interest_Rate := Rate / Period; - - -- The exact value of Factor is: - -- - -- 0.095/12 = 0.00791666... - -- - -- The adjacent multiples of small are 0.007 and 0.008. Since - -- Factor is of an ordinary fixed point type, it may contain either - -- of these values. However, since "Rate / Period" is a static - -- expression, the value Factor contains can be determined based - -- on the value of CXF2004_1.Interest_Rate'Machine_Rounds: - -- - -- If Machine_Rounds = FALSE : Factor = 0.007 - -- If Machine_Rounds = TRUE : Factor = 0.008 - - Initial : constant CXF2004_1.Money_Radix10 := 2_125.00; - - Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 7_456.90; - Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 7_458.77; - - Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 8_915.74; - Round_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 8_917.84; - - Balance : CXF2004_1.Money_Radix10; - begin - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_10.Multiply_And_Truncate (Balance, Factor); - end loop; - - case (Machine) is - when Rounds => - if Balance /= Trunc_Expected_MachRnds then - Report.Failed ("Error (R): Radix 10 multiply and truncate"); - end if; - when Truncates => - if Balance /= Trunc_Expected_MachTrnc then - Report.Failed ("Error (T): Radix 10 multiply and truncate"); - end if; - end case; - - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_10.Multiply_And_Round (Balance, Factor); - end loop; - - case (Machine) is - when Rounds => - if Balance /= Round_Expected_MachRnds then - Report.Failed ("Error (R): Radix 10 multiply and round"); - end if; - when Truncates => - if Balance /= Round_Expected_MachTrnc then - Report.Failed ("Error (T): Radix 10 multiply and round"); - end if; - end case; - - ---=---=---=---=---=---=--- - end RADIX_10_MULTIPLICATION; - - - RADIX_10_DIVISION: - declare - Rate : constant CXF2004_1.Interest_Rate := 0.295; - Period : constant Integer := 12; - Factor : constant CXF2004_1.Interest_Rate := Rate / Period; - Divisor : CXF2004_1.Interest_Rate := 1.0 / Factor; - - -- The exact value of Factor is: - -- - -- 0.295/12 = 0.02458333... - -- - -- The adjacent multiples of small are 0.024 and 0.025. Thus, the - -- exact value of Divisor is one of the following: - -- - -- 1.0/0.024 = 41.66666... (Adjacent smalls 41.666 and 41.667) - -- 1.0/0.025 = 40.0 - -- - -- The value of CXF2004_1.Interest_Rate'Machine_Rounds determines - -- what Divisor contains: - -- - -- If Machine_Rounds = FALSE : Divisor = 41.666 - -- If Machine_Rounds = TRUE : Divisor = 40.000 - - Initial : constant CXF2004_1.Money_Radix10 := 72.19; - - Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 5_144.60; - Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 5_157.80; - - Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 6_133.28; - Round_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 6_149.06; - - Balance : CXF2004_1.Money_Radix10; - begin - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_10.Divide_And_Truncate (Balance, Divisor); - end loop; - - case (Machine) is - when Rounds => - if Balance /= Trunc_Expected_MachRnds then - Report.Failed ("Error (R): Radix 10 divide and truncate"); - end if; - when Truncates => - if Balance /= Trunc_Expected_MachTrnc then - Report.Failed ("Error (T): Radix 10 divide and truncate"); - end if; - end case; - - ---=---=---=---=---=---=--- - - Balance := Initial; - - for I in Loop_Range loop - Radix_10.Divide_And_Round (Balance, Divisor); - end loop; - - case (Machine) is - when Rounds => - if Balance /= Round_Expected_MachRnds then - Report.Failed ("Error (R): Radix 10 divide and round"); - end if; - when Truncates => - if Balance /= Round_Expected_MachTrnc then - Report.Failed ("Error (T): Radix 10 divide and round"); - end if; - end case; - - ---=---=---=---=---=---=--- - end RADIX_10_DIVISION; - - end RADIX_10_SUBTESTS; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - Report.Result; - -end CXF2004; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a deleted file mode 100644 index 71cd5bb31b5..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a +++ /dev/null @@ -1,293 +0,0 @@ --- CXF2005.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 multiplying operators for a decimal fixed point type --- return values that are integral multiples of the small of the type. --- Check the case where one operand is of the predefined type Integer. --- --- TEST DESCRIPTION: --- Two decimal fixed point types A and B are declared, one with a --- Machine_Radix value of 2, and one with a value of 10. A variable of --- each type is multiplied repeatedly by a series of different Integer --- values. A cumulative result is kept and compared to an expected --- final result. Similar checks are performed for division. --- --- APPLICABILITY CRITERIA: --- This test is only applicable for a compiler attempting validation --- for the Information Systems Annex. --- --- --- CHANGE HISTORY: --- 28 Mar 96 SAIC Prerelease version for ACVC 2.1. --- ---! - -generic - type Decimal_Fixed is delta <> digits <>; -package CXF2005_0 is - - function Multiply (Operand : Decimal_Fixed; - Interval : Integer) return Decimal_Fixed; - - function Divide (Operand : Decimal_Fixed; - Interval : Integer) return Decimal_Fixed; - -end CXF2005_0; - - - --==================================================================-- - - -package body CXF2005_0 is - - function Multiply (Operand : Decimal_Fixed; - Interval : Integer) return Decimal_Fixed is - begin - return Operand * Interval; -- Fixed-Integer multiplication. - end Multiply; - - - function Divide (Operand : Decimal_Fixed; - Interval : Integer) return Decimal_Fixed is - begin - return Operand / Interval; -- Fixed-Integer division. - end Divide; - -end CXF2005_0; - - - --==================================================================-- - - -package CXF2005_1 is - - ---=---=---=---=---=---=---=---=---=---=--- - - type Interest_Rate is delta 0.001 range 0.0 .. 1_000.0; - for Interest_Rate'Small use 0.001; -- Power of 10. - - ---=---=---=---=---=---=---=---=---=---=--- - - type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 .. - for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99 - - function Factor (Rate : Interest_Rate; - Interval : Integer) return Money_Radix2; - - ---=---=---=---=---=---=---=---=---=---=--- - - type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 .. - for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99 - - function Factor (Rate : Interest_Rate; - Interval : Integer) return Money_Radix10; - - ---=---=---=---=---=---=---=---=---=---=--- - -end CXF2005_1; - - - --==================================================================-- - - -package body CXF2005_1 is - - ---=---=---=---=---=---=---=---=---=---=--- - - function Factor (Rate : Interest_Rate; - Interval : Integer) return Money_Radix2 is - begin - return Money_Radix2( Rate / Interval ); - end Factor; - - ---=---=---=---=---=---=---=---=---=---=--- - - function Factor (Rate : Interest_Rate; - Interval : Integer) return Money_Radix10 is - begin - return Money_Radix10( Rate / Interval ); - end Factor; - - ---=---=---=---=---=---=---=---=---=---=--- - -end CXF2005_1; - - - --==================================================================-- - - -with CXF2005_0; -with CXF2005_1; - -with Report; -procedure CXF2005 is - - Loop_Count : constant := 25_000; - type Loop_Range is range 1 .. Loop_Count; - -begin - - Report.Test ("CXF2005", "Check decimal multiplication and division, " & - "where one operand type is Integer"); - - - ---=---=---=---=---=---=---=---=---=---=--- - - - RADIX_2_SUBTESTS: - declare - package Radix_2 is new CXF2005_0 (CXF2005_1.Money_Radix2); - use type CXF2005_1.Money_Radix2; - begin - - RADIX_2_MULTIPLICATION: - declare - Rate : constant CXF2005_1.Interest_Rate := 0.127; - Period : constant Integer := 12; - - Expected : constant CXF2005_1.Money_Radix2 := 2_624.88; - Balance : CXF2005_1.Money_Radix2 := 1_000.00; - - Operand : CXF2005_1.Money_Radix2; - Increment : CXF2005_1.Money_Radix2; - Interval : Integer; - begin - - for I in Loop_Range loop - Interval := (Integer(I) mod Period) + 1; -- Range from 1 to 12. - Operand := CXF2005_1.Factor (Rate, Period); - Increment := Radix_2.Multiply (Operand, Interval); - Balance := Balance + Increment; - end loop; - - if Balance /= Expected then - Report.Failed ("Error: Radix 2 multiply"); - end if; - - end RADIX_2_MULTIPLICATION; - - - - RADIX_2_DIVISION: - declare - Rate : constant CXF2005_1.Interest_Rate := 0.377; - Period : constant Integer := 12; - - Expected : constant CXF2005_1.Money_Radix2 := 36_215.58; - Balance : CXF2005_1.Money_Radix2 := 456_985.01; - - Operand : CXF2005_1.Money_Radix2; - Increment : CXF2005_1.Money_Radix2; - Interval : Integer; - begin - - for I in Loop_Range loop - Interval := (Integer(I+1000) mod (200*Period)) + 1; -- 1 .. 2400. - Operand := CXF2005_1.Factor (Rate, Period); - Increment := Radix_2.Divide (Balance, Interval); - Balance := Balance - (Operand * Increment); - end loop; - - if Balance /= Expected then - Report.Failed ("Error: Radix 2 divide"); - end if; - - end RADIX_2_DIVISION; - - end RADIX_2_SUBTESTS; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - RADIX_10_SUBTESTS: - declare - package Radix_10 is new CXF2005_0 (CXF2005_1.Money_Radix10); - use type CXF2005_1.Money_Radix10; - begin - - RADIX_10_MULTIPLICATION: - declare - Rate : constant CXF2005_1.Interest_Rate := 0.721; - Period : constant Integer := 12; - - Expected : constant CXF2005_1.Money_Radix10 := 9_875.62; - Balance : CXF2005_1.Money_Radix10 := 126.34; - - Operand : CXF2005_1.Money_Radix10; - Increment : CXF2005_1.Money_Radix10; - Interval : Integer; - begin - - for I in Loop_Range loop - Interval := (Integer(I) mod Period) + 1; -- Range from 1 to 12. - Operand := CXF2005_1.Factor (Rate, Period); - Increment := Radix_10.Multiply (Operand, Interval); - Balance := Balance + Increment; - end loop; - - if Balance /= Expected then - Report.Failed ("Error: Radix 10 multiply"); - end if; - - end RADIX_10_MULTIPLICATION; - - - RADIX_10_DIVISION: - declare - Rate : constant CXF2005_1.Interest_Rate := 0.547; - Period : constant Integer := 12; - - Expected : constant CXF2005_1.Money_Radix10 := 26_116.37; - Balance : CXF2005_1.Money_Radix10 := 770_082.46; - - Operand : CXF2005_1.Money_Radix10; - Increment : CXF2005_1.Money_Radix10; - Interval : Integer; - begin - - for I in Loop_Range loop - Interval := (Integer(I+1000) mod (200*Period)) + 1; -- 1 .. 2400. - Operand := CXF2005_1.Factor (Rate, Period); - Increment := Radix_10.Divide (Balance, Interval); - Balance := Balance - (Operand * Increment); - end loop; - - if Balance /= Expected then - Report.Failed ("Error: Radix 10 divide"); - end if; - - end RADIX_10_DIVISION; - - end RADIX_10_SUBTESTS; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - Report.Result; - -end CXF2005; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a deleted file mode 100644 index 002c59d6c8e..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a +++ /dev/null @@ -1,448 +0,0 @@ --- CXF2A01.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 binary adding operators for a decimal fixed point type --- return values that are integral multiples of the small of the type. --- --- TEST DESCRIPTION: --- The test verifies that decimal addition and subtraction behave as --- expected for types with various digits, delta, and Machine_Radix --- values. Types with the minimum values for Decimal.Max_Digits and --- Decimal.Max_Scale (18) are included. --- --- Two kinds of checks are performed for each type. In the first check, --- the iteration, operation, and operand counts in the foundation and --- the operation tables in this test are given values such that, when the --- operations loop is complete, each operand will have been added to and --- subtracted from the loop's cumulator variable the same number of times, --- albeit in varying order. Thus, the result returned by the operations --- loop should have the same value as that used to initialize the --- cumulator (in this test, zero). --- --- In the second check, the same operation (addition for some types and --- subtraction for others) is performed during each loop iteration, --- resulting in a cumulative total which is checked against an expected --- value. --- --- TEST FILES: --- The following files comprise this test: --- --- FXF2A00.A --- -> CXF2A01.A --- --- APPLICABILITY CRITERIA: --- This test is only applicable for a compiler attempting validation --- for the Information Systems Annex. --- --- --- CHANGE HISTORY: --- 08 Apr 96 SAIC Prerelease version for ACVC 2.1. --- ---! - -package CXF2A01_0 is - - ---=---=---=---=---=---=---=---=---=---=--- - - type Micro is delta 10.0**(-18) digits 18; -- range -0.999999999999999999 .. - for Micro'Machine_Radix use 10; -- +0.999999999999999999 - - function Add (Left, Right : Micro) return Micro; - function Subtract (Left, Right : Micro) return Micro; - - - type Micro_Optr_Ptr is access function (Left, Right : Micro) return Micro; - - Micro_Add : Micro_Optr_Ptr := Add'Access; - Micro_Sub : Micro_Optr_Ptr := Subtract'Access; - - ---=---=---=---=---=---=---=---=---=---=--- - - type Money is delta 0.01 digits 11; -- range -999,999,999.99 .. - for Money'Machine_Radix use 2; -- +999,999,999.99 - - function Add (Left, Right : Money) return Money; - function Subtract (Left, Right : Money) return Money; - - - type Money_Optr_Ptr is access function (Left, Right : Money) return Money; - - Money_Add : Money_Optr_Ptr := Add'Access; - Money_Sub : Money_Optr_Ptr := Subtract'Access; - - ---=---=---=---=---=---=---=---=---=---=--- - - -- Same as Money, but with Radix 10: - - type Cash is delta 0.01 digits 11; -- range -999,999,999.99 .. - for Cash'Machine_Radix use 10; -- +999,999,999.99 - - function Add (Left, Right : Cash) return Cash; - function Subtract (Left, Right : Cash) return Cash; - - - type Cash_Optr_Ptr is access function (Left, Right : Cash) return Cash; - - Cash_Add : Cash_Optr_Ptr := Add'Access; - Cash_Sub : Cash_Optr_Ptr := Subtract'Access; - - ---=---=---=---=---=---=---=---=---=---=--- - - type Broad is delta 10.0**(-9) digits 18; -- range -999,999,999.999999999 .. - for Broad'Machine_Radix use 10; -- +999,999,999.999999999 - - function Add (Left, Right : Broad) return Broad; - function Subtract (Left, Right : Broad) return Broad; - - - type Broad_Optr_Ptr is access function (Left, Right : Broad) return Broad; - - Broad_Add : Broad_Optr_Ptr := Add'Access; - Broad_Sub : Broad_Optr_Ptr := Subtract'Access; - - ---=---=---=---=---=---=---=---=---=---=--- - -end CXF2A01_0; - - - --==================================================================-- - - -package body CXF2A01_0 is - - ---=---=---=---=---=---=---=---=---=---=--- - - function Add (Left, Right : Micro) return Micro is - begin - return (Left + Right); -- Decimal fixed addition. - end Add; - - function Subtract (Left, Right : Micro) return Micro is - begin - return (Left - Right); -- Decimal fixed subtraction. - end Subtract; - - ---=---=---=---=---=---=---=---=---=---=--- - - function Add (Left, Right : Money) return Money is - begin - return (Left + Right); -- Decimal fixed addition. - end Add; - - function Subtract (Left, Right : Money) return Money is - begin - return (Left - Right); -- Decimal fixed subtraction. - end Subtract; - - ---=---=---=---=---=---=---=---=---=---=--- - - function Add (Left, Right : Cash) return Cash is - begin - return (Left + Right); -- Decimal fixed addition. - end Add; - - function Subtract (Left, Right : Cash) return Cash is - begin - return (Left - Right); -- Decimal fixed subtraction. - end Subtract; - - ---=---=---=---=---=---=---=---=---=---=--- - - function Add (Left, Right : Broad) return Broad is - begin - return (Left + Right); -- Decimal fixed addition. - end Add; - - function Subtract (Left, Right : Broad) return Broad is - begin - return (Left - Right); -- Decimal fixed subtraction. - end Subtract; - - ---=---=---=---=---=---=---=---=---=---=--- - -end CXF2A01_0; - - - --==================================================================-- - - -with FXF2A00; -package CXF2A01_0.CXF2A01_1 is - - ---=---=---=---=---=---=---=---=---=---=--- - - type Micro_Ops is array (FXF2A00.Optr_Range) of Micro_Optr_Ptr; - type Micro_Opnds is array (FXF2A00.Opnd_Range) of Micro; - - Micro_Optr_Table_Cancel : Micro_Ops := ( Micro_Add, Micro_Sub, - Micro_Add, Micro_Sub, - Micro_Add, Micro_Sub ); - - Micro_Optr_Table_Cumul : Micro_Ops := ( others => Micro_Add ); - - Micro_Opnd_Table_Cancel : Micro_Opnds := ( 0.001025000235111997, - 0.000000000000000003, - 0.724902903219925400, - 0.000459228020000011, - 0.049832104921096533 ); - - Micro_Opnd_Table_Cumul : Micro_Opnds := ( 0.000002309540000000, - 0.000000278060000000, - 0.000000000000070000, - 0.000010003000000000, - 0.000000023090000000 ); - - function Test_Micro_Ops is new FXF2A00.Operations_Loop - (Decimal_Fixed => Micro, - Operator_Ptr => Micro_Optr_Ptr, - Operator_Table => Micro_Ops, - Operand_Table => Micro_Opnds); - - ---=---=---=---=---=---=---=---=---=---=--- - - type Money_Ops is array (FXF2A00.Optr_Range) of Money_Optr_Ptr; - type Money_Opnds is array (FXF2A00.Opnd_Range) of Money; - - Money_Optr_Table_Cancel : Money_Ops := ( Money_Add, Money_Add, - Money_Sub, Money_Add, - Money_Sub, Money_Sub ); - - Money_Optr_Table_Cumul : Money_Ops := ( others => Money_Sub ); - - Money_Opnd_Table_Cancel : Money_Opnds := ( 127.10, - 5600.44, - 0.05, - 189662.78, - 226900402.99 ); - - Money_Opnd_Table_Cumul : Money_Opnds := ( 17.99, - 500.41, - 92.78, - 0.38, - 2942.99 ); - - function Test_Money_Ops is new FXF2A00.Operations_Loop - (Decimal_Fixed => Money, - Operator_Ptr => Money_Optr_Ptr, - Operator_Table => Money_Ops, - Operand_Table => Money_Opnds); - - ---=---=---=---=---=---=---=---=---=---=--- - - type Cash_Ops is array (FXF2A00.Optr_Range) of Cash_Optr_Ptr; - type Cash_Opnds is array (FXF2A00.Opnd_Range) of Cash; - - Cash_Optr_Table_Cancel : Cash_Ops := ( Cash_Add, Cash_Add, - Cash_Sub, Cash_Add, - Cash_Sub, Cash_Sub ); - - Cash_Optr_Table_Cumul : Cash_Ops := ( others => Cash_Add ); - - Cash_Opnd_Table_Cancel : Cash_Opnds := ( 127.10, - 5600.44, - 0.05, - 189662.78, - 226900402.99 ); - - Cash_Opnd_Table_Cumul : Cash_Opnds := ( 3.33, - 100056.14, - 22.87, - 3901.55, - 111.21 ); - - function Test_Cash_Ops is new FXF2A00.Operations_Loop - (Decimal_Fixed => Cash, - Operator_Ptr => Cash_Optr_Ptr, - Operator_Table => Cash_Ops, - Operand_Table => Cash_Opnds); - - ---=---=---=---=---=---=---=---=---=---=--- - - type Broad_Ops is array (FXF2A00.Optr_Range) of Broad_Optr_Ptr; - type Broad_Opnds is array (FXF2A00.Opnd_Range) of Broad; - - Broad_Optr_Table_Cancel : Broad_Ops := ( Broad_Sub, Broad_Add, - Broad_Add, Broad_Sub, - Broad_Sub, Broad_Add ); - - Broad_Optr_Table_Cumul : Broad_Ops := ( others => Broad_Sub ); - - Broad_Opnd_Table_Cancel : Broad_Opnds := ( 1.000009092, - 732919479.445022293, - 89662.787000006, - 660.101010133, - 1121127.999905594 ); - - Broad_Opnd_Table_Cumul : Broad_Opnds := ( 12.000450223, - 479.430320780, - 0.003492096, - 8.112888400, - 1002.994937800 ); - - function Test_Broad_Ops is new FXF2A00.Operations_Loop - (Decimal_Fixed => Broad, - Operator_Ptr => Broad_Optr_Ptr, - Operator_Table => Broad_Ops, - Operand_Table => Broad_Opnds); - - ---=---=---=---=---=---=---=---=---=---=--- - -end CXF2A01_0.CXF2A01_1; - - - --==================================================================-- - - -with CXF2A01_0.CXF2A01_1; - -with Report; -procedure CXF2A01 is - package Data renames CXF2A01_0.CXF2A01_1; - - use type CXF2A01_0.Micro; - use type CXF2A01_0.Money; - use type CXF2A01_0.Cash; - use type CXF2A01_0.Broad; - - Micro_Cancel_Expected : constant CXF2A01_0.Micro := 0.0; - Money_Cancel_Expected : constant CXF2A01_0.Money := 0.0; - Cash_Cancel_Expected : constant CXF2A01_0.Cash := 0.0; - Broad_Cancel_Expected : constant CXF2A01_0.Broad := 0.0; - - Micro_Cumul_Expected : constant CXF2A01_0.Micro := 0.075682140420000000; - Money_Cumul_Expected : constant CXF2A01_0.Money := -21327300.00; - Cash_Cumul_Expected : constant CXF2A01_0.Cash := 624570600.00; - Broad_Cumul_Expected : constant CXF2A01_0.Broad := -9015252.535794000; - - Micro_Actual : CXF2A01_0.Micro; - Money_Actual : CXF2A01_0.Money; - Cash_Actual : CXF2A01_0.Cash; - Broad_Actual : CXF2A01_0.Broad; -begin - - Report.Test ("CXF2A01", "Check decimal addition and subtraction"); - - - ---=---=---=---=---=---=---=---=---=---=--- - - - Micro_Actual := Data.Test_Micro_Ops (0.0, - Data.Micro_Optr_Table_Cancel, - Data.Micro_Opnd_Table_Cancel); - - if Micro_Actual /= Micro_Cancel_Expected then - Report.Failed ("Wrong cancellation result for type Micro"); - end if; - - ---=---=---=---=---=---=--- - - - Micro_Actual := Data.Test_Micro_Ops (0.0, - Data.Micro_Optr_Table_Cumul, - Data.Micro_Opnd_Table_Cumul); - - if Micro_Actual /= Micro_Cumul_Expected then - Report.Failed ("Wrong cumulation result for type Micro"); - end if; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - Money_Actual := Data.Test_Money_Ops (0.0, - Data.Money_Optr_Table_Cancel, - Data.Money_Opnd_Table_Cancel); - - if Money_Actual /= Money_Cancel_Expected then - Report.Failed ("Wrong cancellation result for type Money"); - end if; - - ---=---=---=---=---=---=--- - - - Money_Actual := Data.Test_Money_Ops (0.0, - Data.Money_Optr_Table_Cumul, - Data.Money_Opnd_Table_Cumul); - - if Money_Actual /= Money_Cumul_Expected then - Report.Failed ("Wrong cumulation result for type Money"); - end if; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - Cash_Actual := Data.Test_Cash_Ops (0.0, - Data.Cash_Optr_Table_Cancel, - Data.Cash_Opnd_Table_Cancel); - - if Cash_Actual /= Cash_Cancel_Expected then - Report.Failed ("Wrong cancellation result for type Cash"); - end if; - - - ---=---=---=---=---=---=--- - - - Cash_Actual := Data.Test_Cash_Ops (0.0, - Data.Cash_Optr_Table_Cumul, - Data.Cash_Opnd_Table_Cumul); - - if Cash_Actual /= Cash_Cumul_Expected then - Report.Failed ("Wrong cumulation result for type Cash"); - end if; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - Broad_Actual := Data.Test_Broad_Ops (0.0, - Data.Broad_Optr_Table_Cancel, - Data.Broad_Opnd_Table_Cancel); - - if Broad_Actual /= Broad_Cancel_Expected then - Report.Failed ("Wrong cancellation result for type Broad"); - end if; - - - ---=---=---=---=---=---=--- - - - Broad_Actual := Data.Test_Broad_Ops (0.0, - Data.Broad_Optr_Table_Cumul, - Data.Broad_Opnd_Table_Cumul); - - if Broad_Actual /= Broad_Cumul_Expected then - Report.Failed ("Wrong cumulation result for type Broad"); - end if; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - Report.Result; - -end CXF2A01; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a deleted file mode 100644 index e9977b0f502..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a +++ /dev/null @@ -1,354 +0,0 @@ --- CXF2A02.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 multiplying operators for a decimal fixed point type --- return values that are integral multiples of the small of the type. --- Check the case where the operand and result types are the same. --- --- Check that if the mathematical result is between multiples of the --- small of the result type, the result is truncated toward zero. --- --- TEST DESCRIPTION: --- The test verifies that decimal multiplication and division behave as --- expected for types with various digits, delta, and Machine_Radix --- values. --- --- The iteration, operation, and operand counts in the foundation, and --- the operations and operand tables in the test, are given values such --- that, when the operations loop is complete, truncation of inexact --- results should cause the result returned by the operations loop to be --- the same as that used to initialize the loop's cumulator variable (in --- this test, one). --- --- TEST FILES: --- This test consists of the following files: --- --- FXF2A00.A --- -> CXF2A02.A --- --- APPLICABILITY CRITERIA: --- This test is only applicable for a compiler attempting validation --- for the Information Systems Annex. --- --- --- CHANGE HISTORY: --- 13 Mar 96 SAIC Prerelease version for ACVC 2.1. --- 04 Aug 96 SAIC Updated prologue. --- ---! - -package CXF2A02_0 is - - ---=---=---=---=---=---=---=---=---=---=--- - - type Micro is delta 10.0**(-5) digits 6; -- range -9.99999 .. - for Micro'Machine_Radix use 2; -- +9.99999 - - function Multiply (Left, Right : Micro) return Micro; - function Divide (Left, Right : Micro) return Micro; - - - type Micro_Optr_Ptr is access function (Left, Right : Micro) return Micro; - - Micro_Mult : Micro_Optr_Ptr := Multiply'Access; - Micro_Div : Micro_Optr_Ptr := Divide'Access; - - ---=---=---=---=---=---=---=---=---=---=--- - - type Basic is delta 0.01 digits 11; -- range -999,999,999.99 .. - for Basic'Machine_Radix use 10; -- +999,999,999.99 - - function Multiply (Left, Right : Basic) return Basic; - function Divide (Left, Right : Basic) return Basic; - - - type Basic_Optr_Ptr is access function (Left, Right : Basic) return Basic; - - Basic_Mult : Basic_Optr_Ptr := Multiply'Access; - Basic_Div : Basic_Optr_Ptr := Divide'Access; - - ---=---=---=---=---=---=---=---=---=---=--- - - type Broad is delta 10.0**(-3) digits 10; -- range -9,999,999.999 .. - for Broad'Machine_Radix use 2; -- +9,999,999.999 - - function Multiply (Left, Right : Broad) return Broad; - function Divide (Left, Right : Broad) return Broad; - - - type Broad_Optr_Ptr is access function (Left, Right : Broad) return Broad; - - Broad_Mult : Broad_Optr_Ptr := Multiply'Access; - Broad_Div : Broad_Optr_Ptr := Divide'Access; - - ---=---=---=---=---=---=---=---=---=---=--- - -end CXF2A02_0; - - - --==================================================================-- - - -package body CXF2A02_0 is - - ---=---=---=---=---=---=---=---=---=---=--- - - function Multiply (Left, Right : Micro) return Micro is - begin - return (Left * Right); -- Decimal fixed multiplication. - end Multiply; - - function Divide (Left, Right : Micro) return Micro is - begin - return (Left / Right); -- Decimal fixed division. - end Divide; - - ---=---=---=---=---=---=---=---=---=---=--- - - function Multiply (Left, Right : Basic) return Basic is - begin - return (Left * Right); -- Decimal fixed multiplication. - end Multiply; - - function Divide (Left, Right : Basic) return Basic is - begin - return (Left / Right); -- Decimal fixed division. - end Divide; - - ---=---=---=---=---=---=---=---=---=---=--- - - function Multiply (Left, Right : Broad) return Broad is - begin - return (Left * Right); -- Decimal fixed multiplication. - end Multiply; - - function Divide (Left, Right : Broad) return Broad is - begin - return (Left / Right); -- Decimal fixed division. - end Divide; - - ---=---=---=---=---=---=---=---=---=---=--- - -end CXF2A02_0; - - - --==================================================================-- - - -with FXF2A00; -package CXF2A02_0.CXF2A02_1 is - - ---=---=---=---=---=---=---=---=---=---=--- - - type Micro_Ops is array (FXF2A00.Optr_Range) of Micro_Optr_Ptr; - type Micro_Opnds is array (FXF2A00.Opnd_Range) of Micro; - - Micro_Mult_Operator_Table : Micro_Ops := ( Micro_Mult, Micro_Mult, - Micro_Mult, Micro_Mult, - Micro_Mult, Micro_Mult ); - - Micro_Div_Operator_Table : Micro_Ops := ( Micro_Div, Micro_Div, - Micro_Div, Micro_Div, - Micro_Div, Micro_Div ); - - Micro_Mult_Operand_Table : Micro_Opnds := ( 2.35119, - 0.05892, - 9.58122, - 0.80613, - 0.93462 ); - - Micro_Div_Operand_Table : Micro_Opnds := ( 0.58739, - 4.90012, - 0.08765, - 0.71577, - 5.53768 ); - - function Test_Micro_Ops is new FXF2A00.Operations_Loop - (Decimal_Fixed => Micro, - Operator_Ptr => Micro_Optr_Ptr, - Operator_Table => Micro_Ops, - Operand_Table => Micro_Opnds); - - ---=---=---=---=---=---=---=---=---=---=--- - - type Basic_Ops is array (FXF2A00.Optr_Range) of Basic_Optr_Ptr; - type Basic_Opnds is array (FXF2A00.Opnd_Range) of Basic; - - Basic_Mult_Operator_Table : Basic_Ops := ( Basic_Mult, Basic_Mult, - Basic_Mult, Basic_Mult, - Basic_Mult, Basic_Mult ); - - Basic_Div_Operator_Table : Basic_Ops := ( Basic_Div, Basic_Div, - Basic_Div, Basic_Div, - Basic_Div, Basic_Div ); - - Basic_Mult_Operand_Table : Basic_Opnds := ( 127.10, - 0.02, - 0.87, - 45.67, - 0.01 ); - - Basic_Div_Operand_Table : Basic_Opnds := ( 0.03, - 0.08, - 23.57, - 0.11, - 159.11 ); - - function Test_Basic_Ops is new FXF2A00.Operations_Loop - (Decimal_Fixed => Basic, - Operator_Ptr => Basic_Optr_Ptr, - Operator_Table => Basic_Ops, - Operand_Table => Basic_Opnds); - - ---=---=---=---=---=---=---=---=---=---=--- - - type Broad_Ops is array (FXF2A00.Optr_Range) of Broad_Optr_Ptr; - type Broad_Opnds is array (FXF2A00.Opnd_Range) of Broad; - - Broad_Mult_Operator_Table : Broad_Ops := ( Broad_Mult, Broad_Mult, - Broad_Mult, Broad_Mult, - Broad_Mult, Broad_Mult ); - - Broad_Div_Operator_Table : Broad_Ops := ( Broad_Div, Broad_Div, - Broad_Div, Broad_Div, - Broad_Div, Broad_Div ); - - Broad_Mult_Operand_Table : Broad_Opnds := ( 589.720, - 0.106, - 21.018, - 0.002, - 0.381 ); - - Broad_Div_Operand_Table : Broad_Opnds := ( 0.008, - 0.793, - 9.092, - 214.300, - 0.080 ); - - function Test_Broad_Ops is new FXF2A00.Operations_Loop - (Decimal_Fixed => Broad, - Operator_Ptr => Broad_Optr_Ptr, - Operator_Table => Broad_Ops, - Operand_Table => Broad_Opnds); - - ---=---=---=---=---=---=---=---=---=---=--- - -end CXF2A02_0.CXF2A02_1; - - - --==================================================================-- - - -with CXF2A02_0.CXF2A02_1; - -with Report; -procedure CXF2A02 is - package Data renames CXF2A02_0.CXF2A02_1; - - use type CXF2A02_0.Micro; - use type CXF2A02_0.Basic; - use type CXF2A02_0.Broad; - - Micro_Expected : constant CXF2A02_0.Micro := 1.0; - Basic_Expected : constant CXF2A02_0.Basic := 1.0; - Broad_Expected : constant CXF2A02_0.Broad := 1.0; - - Micro_Actual : CXF2A02_0.Micro; - Basic_Actual : CXF2A02_0.Basic; - Broad_Actual : CXF2A02_0.Broad; -begin - - Report.Test ("CXF2A02", "Check decimal multiplication and division, " & - "where the operand and result types are the same"); - - ---=---=---=---=---=---=---=---=---=---=--- - - Micro_Actual := 0.0; - Micro_Actual := Data.Test_Micro_Ops (1.0, - Data.Micro_Mult_Operator_Table, - Data.Micro_Mult_Operand_Table); - - if Micro_Actual /= Micro_Expected then - Report.Failed ("Wrong result for type Micro multiplication"); - end if; - - - Micro_Actual := 0.0; - Micro_Actual := Data.Test_Micro_Ops (1.0, - Data.Micro_Div_Operator_Table, - Data.Micro_Div_Operand_Table); - - if Micro_Actual /= Micro_Expected then - Report.Failed ("Wrong result for type Micro division"); - end if; - - ---=---=---=---=---=---=---=---=---=---=--- - - Basic_Actual := 0.0; - Basic_Actual := Data.Test_Basic_Ops (1.0, - Data.Basic_Mult_Operator_Table, - Data.Basic_Mult_Operand_Table); - - if Basic_Actual /= Basic_Expected then - Report.Failed ("Wrong result for type Basic multiplication"); - end if; - - - Basic_Actual := 0.0; - Basic_Actual := Data.Test_Basic_Ops (1.0, - Data.Basic_Div_Operator_Table, - Data.Basic_Div_Operand_Table); - - if Basic_Actual /= Basic_Expected then - Report.Failed ("Wrong result for type Basic division"); - end if; - - ---=---=---=---=---=---=---=---=---=---=--- - - Broad_Actual := 0.0; - Broad_Actual := Data.Test_Broad_Ops (1.0, - Data.Broad_Mult_Operator_Table, - Data.Broad_Mult_Operand_Table); - - if Broad_Actual /= Broad_Expected then - Report.Failed ("Wrong result for type Broad multiplication"); - end if; - - - Broad_Actual := 0.0; - Broad_Actual := Data.Test_Broad_Ops (1.0, - Data.Broad_Div_Operator_Table, - Data.Broad_Div_Operand_Table); - - if Broad_Actual /= Broad_Expected then - Report.Failed ("Wrong result for type Broad division"); - end if; - - ---=---=---=---=---=---=---=---=---=---=--- - - Report.Result; - -end CXF2A02; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a deleted file mode 100644 index 1b9abca153f..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a +++ /dev/null @@ -1,192 +0,0 @@ --- CXF3001.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 edited output string value returned by Function Image --- is correct. --- --- TEST DESCRIPTION: --- This test is structured using tables of data, consisting of --- numerical values, picture strings, and expected image --- result strings. --- --- Each picture string is checked for validity, and an invalid picture --- string will cause immediate test failure on its first pass through --- the evaluation loop. Inside the evaluation loop, each decimal data --- item is combined with each of the picture strings as parameters to a --- call to Image, and the result of each call is compared to an --- expected edited output result string. --- --- --- CHANGE HISTORY: --- 24 Feb 95 SAIC Initial prerelease version. --- 23 Jun 95 SAIC Corrected call to functions Valid and To_Picture. --- 22 Aug 95 SAIC Test name changed to CXF3001 (from CXF3301) to --- conform to naming conventions. --- 24 Feb 97 CTA.PWB Corrected picture strings and expected results. ---! - -with Ada.Text_IO.Editing; -with Report; - -procedure CXF3001 is -begin - - Report.Test ("CXF3001", "Check that the string value returned by " & - "Function Image is correct"); - - Test_Block: - declare - - use Ada.Text_IO; - - Number_Of_Decimal_Items : constant := 5; - Number_Of_Picture_Strings : constant := 4; - Number_Of_Expected_Results : constant := Number_Of_Decimal_Items * - Number_Of_Picture_Strings; - - type String_Pointer_Type is access String; - - -- Define a decimal data type, and instantiate the Decimal_Output - -- generic package for the data type. - - type Decimal_Data_Type is delta 0.01 digits 16; - package Ed_Out is new Editing.Decimal_Output (Decimal_Data_Type); - - -- Define types for the arrays of data that will hold the decimal data - -- values, picture strings, and expected edited output results. - - type Decimal_Data_Array_Type is - array (Integer range <>) of Decimal_Data_Type; - - type Picture_String_Array_Type is - array (Integer range <>) of String_Pointer_Type; - - type Edited_Output_Results_Array_Type is - array (Integer range <>) of String_Pointer_Type; - - -- Define the data arrays for this test. - - Decimal_Data : - Decimal_Data_Array_Type(1..Number_Of_Decimal_Items) := - ( 1 => 5678.90, - 2 => -6789.01, - 3 => 0.00, - 4 => 0.20, - 5 => 3.45 - ); - - Picture_Strings : - Picture_String_Array_Type(1..Number_Of_Picture_Strings) := - ( 1 => new String'("-$$_$$9.99"), - 2 => new String'("-$$_$$$.$$"), - 3 => new String'("-ZZZZ.ZZ"), - 4 => new String'("-$$$_999.99") - ); - - Edited_Output : - Edited_Output_Results_Array_Type(1..Number_Of_Expected_Results) := - ( 1 => new String'(" $5,678.90"), - 2 => new String'(" $5,678.90"), - 3 => new String'(" 5678.90"), - 4 => new String'(" $5,678.90"), - - 5 => new String'("-$6,789.01"), - 6 => new String'("-$6,789.01"), - 7 => new String'("-6789.01"), - 8 => new String'("- $6,789.01"), - - 9 => new String'(" $0.00"), - 10 => new String'(" "), - 11 => new String'(" "), - 12 => new String'(" $ 000.00"), - - 13 => new String'(" $0.20"), - 14 => new String'(" $.20"), - 15 => new String'(" .20"), - 16 => new String'(" $ 000.20"), - - 17 => new String'(" $3.45"), - 18 => new String'(" $3.45"), - 19 => new String'(" 3.45"), - 20 => new String'(" $ 003.45") - ); - - TC_Picture : Editing.Picture; - TC_Loop_Count : Natural := 0; - - begin - - -- Compare string result of Image with expected edited output string. - - Evaluate_Edited_Output: - for i in 1..Number_Of_Decimal_Items loop - for j in 1..Number_Of_Picture_Strings loop - - TC_Loop_Count := TC_Loop_Count + 1; - - -- Check on the validity of the picture strings prior to - -- processing. - - if Editing.Valid(Picture_Strings(j).all) then - - -- Create the picture object from the picture string. - TC_Picture := Editing.To_Picture(Picture_Strings(j).all); - - -- Compare actual edited output result of Function Image with - -- the expected result. - - if Ed_Out.Image(Decimal_Data(i), TC_Picture) /= - Edited_Output(TC_Loop_Count).all - then - Report.Failed("Incorrect result from Function Image, " & - "when used with decimal data item # " & - Integer'Image(i) & - " and picture string # " & - Integer'Image(j)); - end if; - - else - Report.Failed("Picture String # " & Integer'Image(j) & - "reported as being invalid"); - -- Immediate test failure if a string is invalid. - exit Evaluate_Edited_Output; - end if; - - end loop; - end loop Evaluate_Edited_Output; - - exception - when Editing.Picture_Error => - Report.Failed ("Picture_Error raised in Test_Block"); - when Layout_Error => - Report.Failed ("Layout_Error raised in Test_Block"); - when others => - Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXF3001; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a deleted file mode 100644 index 8444244ef5c..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a +++ /dev/null @@ -1,231 +0,0 @@ --- CXF3002.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 functionality contained in package --- Ada.Wide_Text_IO.Editing is available and produces correct results. --- --- TEST DESCRIPTION: --- This test is designed to validate the procedures and functions that --- are found in package Ada.Wide_Text_IO.Editing, the "wide" --- complementary package to Ada.Text_IO.Editing. The test is similar --- to CXF3301, which tested a large portion of the Ada.Text_IO.Editing --- package. Additional testing has been added here to cover the balance --- of the Wide_Text_IO.Editing child package. - --- This test is structured using tables of data, consisting of --- numerical values, picture strings, and expected image --- result strings. --- --- Each picture string is checked for validity, and an invalid picture --- string will cause immediate test failure on its first pass through --- the evaluation loop. Inside the evaluation loop, each decimal data --- item is combined with each of the picture strings as parameters to a --- call to Image, and the result of each call is compared to an --- expected edited output result string. --- --- Note: Each of the functions Valid, To_Picture, and Pic_String has --- String (rather than Wide_String) as its parameter or result --- subtype, since a picture String is not localizable. --- --- --- CHANGE HISTORY: --- 22 Jun 95 SAIC Initial prerelease version. --- 22 Aug 95 SAIC Test name changed to CXF3002 (from CXF3401) to --- conform with naming conventions. --- 24 Feb 97 PWB.CTA Corrected picture strings and expected values. ---! - -with Ada.Wide_Text_IO.Editing; -with Report; - -procedure CXF3002 is -begin - - Report.Test ("CXF3002", "Check that the functionality contained " & - "in package Ada.Wide_Text_IO.Editing is " & - "available and produces correct results"); - - Test_Block: - declare - - use Ada.Wide_Text_IO; - - Number_Of_Decimal_Items : constant := 5; - Number_Of_Picture_Strings : constant := 4; - Number_Of_Expected_Results : constant := Number_Of_Decimal_Items * - Number_Of_Picture_Strings; - - Def_Cur : constant Wide_String := "$"; - Def_Fill : constant Wide_Character := '*'; - Def_Sep : constant Wide_Character := Editing.Default_Separator; - Def_Radix : constant Wide_Character := Editing.Default_Radix_Mark; - - type String_Pointer_Type is access String; - type Wide_String_Pointer_Type is access Wide_String; - - -- Define a decimal data type, and instantiate the Decimal_Output - -- generic package for the data type. - - type Decimal_Data_Type is delta 0.01 digits 16; - - package Wide_Ed_Out is - new Editing.Decimal_Output(Num => Decimal_Data_Type, - Default_Currency => Def_Cur, - Default_Fill => Def_Fill, - Default_Separator => Def_Sep, - Default_Radix_Mark => Def_Radix); - - -- Define types for the arrays of data that will hold the decimal data - -- values, picture strings, and expected edited output results. - - type Decimal_Data_Array_Type is - array (Integer range <>) of Decimal_Data_Type; - - type Picture_String_Array_Type is - array (Integer range <>) of String_Pointer_Type; - - type Edited_Output_Results_Array_Type is - array (Integer range <>) of Wide_String_Pointer_Type; - - -- Define the data arrays for this test. - - Decimal_Data : - Decimal_Data_Array_Type(1..Number_Of_Decimal_Items) := - ( 1 => 5678.90, - 2 => -6789.01, - 3 => 0.00, - 4 => 0.20, - 5 => 3.45 - ); - - Picture_Strings : - Picture_String_Array_Type(1..Number_Of_Picture_Strings) := - ( 1 => new String'("-$$_$$9.99"), - 2 => new String'("-$$_$$$.$$"), - 3 => new String'("-ZZZZ.ZZ"), - 4 => new String'("-$$$_999.99") - ); - - - Edited_Output : - Edited_Output_Results_Array_Type(1..Number_Of_Expected_Results) := - ( 1 => new Wide_String'(" $5,678.90"), - 2 => new Wide_String'(" $5,678.90"), - 3 => new Wide_String'(" 5678.90"), - 4 => new Wide_String'(" $5,678.90"), - - 5 => new Wide_String'("-$6,789.01"), - 6 => new Wide_String'("-$6,789.01"), - 7 => new Wide_String'("-6789.01"), - 8 => new Wide_String'("- $6,789.01"), - - 9 => new Wide_String'(" $0.00"), - 10 => new Wide_String'(" "), - 11 => new Wide_String'(" "), - 12 => new Wide_String'(" $ 000.00"), - - 13 => new Wide_String'(" $0.20"), - 14 => new Wide_String'(" $.20"), - 15 => new Wide_String'(" .20"), - 16 => new Wide_String'(" $ 000.20"), - - 17 => new Wide_String'(" $3.45"), - 18 => new Wide_String'(" $3.45"), - 19 => new Wide_String'(" 3.45"), - 20 => new Wide_String'(" $ 003.45") - ); - - TC_Picture : Editing.Picture; - TC_Loop_Count : Natural := 0; - - begin - - -- Compare string result of Image with expected edited output wide - -- string. - - Evaluate_Edited_Output: - for i in 1..Number_Of_Decimal_Items loop - for j in 1..Number_Of_Picture_Strings loop - - TC_Loop_Count := TC_Loop_Count + 1; - - -- Check on the validity of the picture strings prior to - -- processing. - - if Editing.Valid(Picture_Strings(j).all) then - - -- Create the picture object from the picture string. - TC_Picture := Editing.To_Picture(Picture_Strings(j).all); - - -- Check results of function Decimal_Output.Valid. - if not Wide_Ed_Out.Valid(Decimal_Data(i), TC_Picture) then - Report.Failed("Incorrect result from function Valid " & - "when examining the picture string that " & - "was produced from string " & - Integer'Image(j) & " in conjunction with " & - "decimal data item # " & Integer'Image(i)); - end if; - - -- Check results of function Editing.Pic_String. - if Editing.Pic_String(TC_Picture) /= Picture_Strings(j).all then - Report.Failed("Incorrect result from To_Picture/" & - "Pic_String conversion for picture " & - "string # " & Integer'Image(j)); - end if; - - -- Compare actual edited output result of Function Image with - -- the expected result. - - if Wide_Ed_Out.Image(Decimal_Data(i), TC_Picture) /= - Edited_Output(TC_Loop_Count).all - then - Report.Failed("Incorrect result from Function Image, " & - "when used with decimal data item # " & - Integer'Image(i) & - " and picture string # " & - Integer'Image(j)); - end if; - - else - Report.Failed("Picture String # " & Integer'Image(j) & - "reported as being invalid"); - end if; - - end loop; - end loop Evaluate_Edited_Output; - - exception - when Editing.Picture_Error => - Report.Failed ("Picture_Error raised in Test_Block"); - when Layout_Error => - Report.Failed ("Layout_Error raised in Test_Block"); - when others => - Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXF3002; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a deleted file mode 100644 index 7cfce618e7c..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a +++ /dev/null @@ -1,292 +0,0 @@ --- CXF3003.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 statically identifiable picture strings can be used to --- produce correctly formatted edited output. --- --- TEST DESCRIPTION: --- This test defines several picture strings that are statically --- identifiable, (i.e., Pic : Picture := To_Picture("..."); ). --- These picture strings are used in conjunction with decimal data --- as parameters in calls to functions Valid and Image. These --- functions are created by an instantiation of the generic package --- Ada.Text_IO.Editing.Decimal_Output. --- --- --- CHANGE HISTORY: --- 04 Apr 96 SAIC Initial release for 2.1. --- 13 Feb 97 PWB.CTA corrected incorrect picture strings. ---! - -with Report; -with Ada.Text_IO.Editing; -with Ada.Exceptions; - -procedure CXF3003 is -begin - - Report.Test ("CXF3003", "Check that statically identifiable " & - "picture strings can be used to produce " & - "correctly formatted edited output"); - - Test_Block: - declare - - use Ada.Exceptions; - use Ada.Text_IO.Editing; - - Def_Cur : constant String := "$"; - Def_Fill : constant Character := '*'; - Def_Sep : constant Character := Default_Separator; - Def_Radix : constant Character := - Ada.Text_IO.Editing.Default_Radix_Mark; - - type Str_Ptr is access String; - type Edited_Output_Array_Type is array (Integer range <>) of Str_Ptr; - - -- Define a decimal data type, and instantiate the Decimal_Output - -- generic package for the data type. - - type Decimal_Data_Type is delta 0.01 digits 16; - - package Image_IO is - new Decimal_Output(Num => Decimal_Data_Type, - Default_Currency => Def_Cur, - Default_Fill => '*', - Default_Separator => Default_Separator, - Default_Radix_Mark => Def_Radix); - - - type Decimal_Data_Array_Type is - array (Integer range <>) of Decimal_Data_Type; - - Decimal_Data : Decimal_Data_Array_Type(1..5) := - (1 => 1357.99, - 2 => -9029.01, - 3 => 0.00, - 4 => 0.20, - 5 => 3.45); - - -- Statically identifiable picture strings. - - Picture_1 : Picture := To_Picture("-$$_$$9.99"); - Picture_2 : Picture := To_Picture("-$$_$$$.$$"); - Picture_3 : Picture := To_Picture("-ZZZZ.ZZ"); - Picture_5 : Picture := To_Picture("-$$$_999.99"); - Picture_6 : Picture := To_Picture("-###**_***_**9.99"); - Picture_7 : Picture := To_Picture("-$**_***_**9.99"); - Picture_8 : Picture := To_Picture("-$$$$$$.$$"); - Picture_9 : Picture := To_Picture("-$$$$$$.$$"); - Picture_10 : Picture := To_Picture("+BBBZZ_ZZZ_ZZZ.ZZ"); - Picture_11 : Picture := To_Picture("--_---_---_--9"); - Picture_12 : Picture := To_Picture("-$_$$$_$$$_$$9.99"); - Picture_14 : Picture := To_Picture("$_$$9.99"); - Picture_15 : Picture := To_Picture("$$9.99"); - - - Picture_1_Output : Edited_Output_Array_Type(1..5) := - ( 1 => new String'(" $1,357.99"), - 2 => new String'("-$9,029.01"), - 3 => new String'(" $0.00"), - 4 => new String'(" $0.20"), - 5 => new String'(" $3.45")); - - Picture_2_Output : Edited_Output_Array_Type(1..5) := - (1 => new String'(" $1,357.99"), - 2 => new String'("-$9,029.01"), - 3 => new String'(" "), - 4 => new String'(" $.20"), - 5 => new String'(" $3.45")); - - Picture_3_Output : Edited_Output_Array_Type(1..5) := - (1 => new String'(" 1357.99"), - 2 => new String'("-9029.01"), - 3 => new String'(" "), - 4 => new String'(" .20"), - 5 => new String'(" 3.45")); - - Picture_5_Output : Edited_Output_Array_Type(1..5) := - (1 => new String'(" $1,357.99"), - 2 => new String'("- $9,029.01"), - 3 => new String'(" $ 000.00"), - 4 => new String'(" $ 000.20"), - 5 => new String'(" $ 003.45")); - - begin - - -- Check the results of function Valid, using the first five decimal - -- data items and picture strings. - - if not Image_IO.Valid(Decimal_Data(1), Picture_1) then - Report.Failed("Picture string 1 not valid"); - elsif not Image_IO.Valid(Decimal_Data(2), Picture_2) then - Report.Failed("Picture string 2 not valid"); - elsif not Image_IO.Valid(Decimal_Data(3), Picture_3) then - Report.Failed("Picture string 3 not valid"); - elsif not Image_IO.Valid(Decimal_Data(5), Picture_5) then - Report.Failed("Picture string 5 not valid"); - end if; - - - -- Check the results of function Image, using the picture strings - -- constructed above, with a variety of named vs. positional - -- parameter notation and defaulted parameters. - - for i in 1..5 loop - if Image_IO.Image(Item => Decimal_Data(i), Pic => Picture_1) /= - Picture_1_Output(i).all - then - Report.Failed("Incorrect result from function Image with " & - "decimal data item #" & Integer'Image(i) & ", " & - "combined with Picture_1 picture string." & - "Expected: " & Picture_1_Output(i).all & ", " & - "Found: " & - Image_IO.Image(Decimal_Data(i),Picture_1)); - end if; - - if Image_IO.Image(Decimal_Data(i), Pic => Picture_2) /= - Picture_2_Output(i).all - then - Report.Failed("Incorrect result from function Image with " & - "decimal data item #" & Integer'Image(i) & ", " & - "combined with Picture_2 picture string." & - "Expected: " & Picture_2_Output(i).all & ", " & - "Found: " & - Image_IO.Image(Decimal_Data(i),Picture_2)); - end if; - - if Image_IO.Image(Decimal_Data(i), Picture_3) /= - Picture_3_Output(i).all - then - Report.Failed("Incorrect result from function Image with " & - "decimal data item #" & Integer'Image(i) & ", " & - "combined with Picture_3 picture string." & - "Expected: " & Picture_3_Output(i).all & ", " & - "Found: " & - Image_IO.Image(Decimal_Data(i),Picture_3)); - end if; - - if Image_IO.Image(Decimal_Data(i), Picture_5) /= - Picture_5_Output(i).all - then - Report.Failed("Incorrect result from function Image with " & - "decimal data item #" & Integer'Image(i) & ", " & - "combined with Picture_5 picture string." & - "Expected: " & Picture_5_Output(i).all & ", " & - "Found: " & - Image_IO.Image(Decimal_Data(i),Picture_5)); - end if; - end loop; - - - if Image_IO.Image(Item => 123456.78, - Pic => Picture_6, - Currency => "$", - Fill => Def_Fill, - Separator => Def_Sep, - Radix_Mark => Def_Radix) /= " $***123,456.78" - then - Report.Failed("Incorrect result from Fn. Image using Picture_6"); - end if; - - if Image_IO.Image(123456.78, - Pic => Picture_7, - Currency => Def_Cur, - Fill => '*', - Separator => Def_Sep, - Radix_Mark => Def_Radix) /= " $***123,456.78" - then - Report.Failed("Incorrect result from Fn. Image using Picture_7"); - end if; - - if Image_IO.Image(0.0, - Picture_8, - Currency => "$", - Fill => '*', - Separator => Def_Sep, - Radix_Mark => Def_Radix) /= " " - then - Report.Failed("Incorrect result from Fn. Image using Picture_8"); - end if; - - if Image_IO.Image(0.20, - Picture_9, - Def_Cur, - Fill => Def_Fill, - Separator => Default_Separator, - Radix_Mark => Default_Radix_Mark) /= " $.20" - then - Report.Failed("Incorrect result from Fn. Image using Picture_9"); - end if; - - if Image_IO.Image(123456.00, - Picture_10, - "$", - '*', - Separator => Def_Sep, - Radix_Mark => Def_Radix) /= "+ 123,456.00" - then - Report.Failed("Incorrect result from Fn. Image using Picture_10"); - end if; - - if Image_IO.Image(-123456.78, - Picture_11, - Default_Currency, - Default_Fill, - Default_Separator, - Radix_Mark => Def_Radix) /= " -123,457" - then - Report.Failed("Incorrect result from Fn. Image using Picture_11"); - end if; - - if Image_IO.Image(123456.78, Picture_12, "$", '*', ',', '.') /= - " $123,456.78" - then - Report.Failed("Incorrect result from Fn. Image using Picture_12"); - end if; - - if Image_IO.Image(1.23, - Picture_14, - Currency => Def_Cur, - Fill => Def_Fill) /= " $1.23" - then - Report.Failed("Incorrect result from Fn. Image using Picture_14"); - end if; - - if Image_IO.Image(12.34, Pic => Picture_15) /= "$12.34" - then - Report.Failed("Incorrect result from Fn. Image using Picture_15"); - end if; - - exception - when The_Error : others => - Report.Failed("The following exception was raised in the " & - "Test_Block: " & Exception_Name(The_Error)); - end Test_Block; - - Report.Result; - -end CXF3003; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a deleted file mode 100644 index 146047bc824..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a +++ /dev/null @@ -1,257 +0,0 @@ --- CXF3004.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 statically identifiable picture strings can be used --- in conjunction with function Image to produce output strings --- appropriate to foreign currency representations. --- --- Check that statically identifiable picture strings will cause --- function Image to raise Layout_Error under the appropriate --- conditions. --- --- TEST DESCRIPTION: --- This test defines several picture strings that are statically --- identifiable, (i.e., Pic : Picture := To_Picture("..."); ). --- These picture strings are used in conjunction with decimal data --- as parameters in calls to function Image. --- --- --- CHANGE HISTORY: --- 11 Apr 96 SAIC Initial release for 2.1. --- ---! - -with Report; -with Ada.Text_IO.Editing; -with Ada.Exceptions; - -procedure CXF3004 is -begin - - Report.Test ("CXF3004", "Check that statically identifiable " & - "picture strings will cause function Image " & - "to raise Layout_Error under appropriate " & - "conditions"); - - Test_Block: - declare - - use Ada.Exceptions; - use Ada.Text_IO.Editing; - - FF_Currency : constant String := "FF"; - DM_Currency : constant String := "DM"; - FF_Separator : constant Character := '.'; - DM_Separator : constant Character := ','; - FF_Radix : constant Character := ','; - DM_Radix : constant Character := '.'; - Blank_Fill : constant Character := ' '; - Star_Fill : constant Character := '*'; - - - -- Define a decimal data type, and instantiate the Decimal_Output - -- generic package for the data type. - - type Decimal_Data_Type is delta 0.01 digits 16; - - package Image_IO is - new Decimal_Output(Num => Decimal_Data_Type, - Default_Currency => "$", - Default_Fill => Star_Fill, - Default_Separator => Default_Separator, - Default_Radix_Mark => DM_Radix); - - - - -- The following decimal data items are used with picture strings - -- in evaluating use of foreign currency symbols. - - Dec_Data_1 : Decimal_Data_Type := 123456.78; - Dec_Data_2 : Decimal_Data_Type := 32.10; - Dec_Data_3 : Decimal_Data_Type := -1234.57; - Dec_Data_4 : Decimal_Data_Type := 123456.78; - Dec_Data_5 : Decimal_Data_Type := 12.34; - Dec_Data_6 : Decimal_Data_Type := 12.34; - Dec_Data_7 : Decimal_Data_Type := 12345.67; - - - -- Statically identifiable picture strings. - -- These strings are used in conjunction with non-default values - -- for Currency string, Radix mark, and Separator in calls to - -- function Image. - - Picture_1 : Picture := To_Picture("-###**_***_**9.99"); -- FF - Picture_2 : Picture := To_Picture("###z_ZZ9.99"); -- FF - Picture_3 : Picture := To_Picture("<<<<_<<<.<<###>"); -- DM - Picture_4 : Picture := To_Picture("-$_$$$_$$$_$$9.99"); -- DM - Picture_5 : Picture := To_Picture("$Zz9.99"); -- DM - Picture_6 : Picture := To_Picture("$$$9.99"); -- DM - Picture_7 : Picture := To_Picture("###_###_##9.99"); -- CHF - - - -- The following ten edited output strings correspond to the ten - -- foreign currency picture strings. - - Output_1 : constant String := " FF***123.456,78"; - Output_2 : constant String := " FF 32,10"; - Output_3 : constant String := " (1,234.57DM )"; - Output_4 : constant String := " DM123,456.78"; - Output_5 : constant String := "DM 12.34"; - Output_6 : constant String := " DM12.34"; - Output_7 : constant String := " CHF12,345.67"; - - - begin - - -- Check the results of function Image, using the picture strings - -- constructed above, in creating foreign currency edited output - -- strings. - - if Image_IO.Image(Item => Dec_Data_1, - Pic => Picture_1, - Currency => FF_Currency, - Fill => Star_Fill, - Separator => FF_Separator, - Radix_Mark => FF_Radix) /= Output_1 - then - Report.Failed("Incorrect result from Fn. Image using Picture_1"); - end if; - - if Image_IO.Image(Item => Dec_Data_2, - Pic => Picture_2, - Currency => FF_Currency, - Fill => Blank_Fill, - Separator => FF_Separator, - Radix_Mark => FF_Radix) /= Output_2 - then - Report.Failed("Incorrect result from Fn. Image using Picture_2"); - end if; - - if Image_IO.Image(Item => Dec_Data_3, - Pic => Picture_3, - Currency => DM_Currency, - Fill => Blank_Fill, - Separator => DM_Separator, - Radix_Mark => DM_Radix) /= Output_3 - then - Report.Failed("Incorrect result from Fn. Image using Picture_3"); - end if; - - if Image_IO.Image(Item => Dec_Data_4, - Pic => Picture_4, - Currency => DM_Currency, - Fill => Blank_Fill, - Separator => DM_Separator, - Radix_Mark => DM_Radix) /= Output_4 - then - Report.Failed("Incorrect result from Fn. Image using Picture_4"); - end if; - - if Image_IO.Image(Item => Dec_Data_5, - Pic => Picture_5, - Currency => DM_Currency, - Fill => Blank_Fill, - Separator => DM_Separator, - Radix_Mark => DM_Radix) /= Output_5 - then - Report.Failed("Incorrect result from Fn. Image using Picture_5"); - end if; - - if Image_IO.Image(Item => Dec_Data_6, - Pic => Picture_6, - Currency => DM_Currency, - Fill => Blank_Fill, - Separator => DM_Separator, - Radix_Mark => DM_Radix) /= Output_6 - then - Report.Failed("Incorrect result from Fn. Image using Picture_6"); - end if; - - if Image_IO.Image(Item => Dec_Data_7, - Pic => Picture_7, - Currency => "CHF", - Fill => Blank_Fill, - Separator => ',', - Radix_Mark => '.') /= Output_7 - then - Report.Failed("Incorrect result from Fn. Image using Picture_7"); - end if; - - - -- The following calls of Function Image, using the specific - -- decimal values and picture strings provided, will cause - -- a Layout_Error to be raised. - -- Note: The data and the picture strings used in the following - -- evaluations are not themselves erroneous, but when used in - -- combination will cause Layout_Error to be raised. - - Exception_Block_1 : - declare - Erroneous_Data_1 : Decimal_Data_Type := 12.34; - Erroneous_Picture_1 : Picture := To_Picture("9.99"); - N : constant Natural := Image_IO.Length(Erroneous_Picture_1); - TC_String : String(1..N); - begin - TC_String := Image_IO.Image(Erroneous_Data_1, Erroneous_Picture_1); - Report.Failed("Layout_Error not raised by combination of " & - "Erroneous_Picture_1 and Erroneous_Data_1"); - Report.Comment("Should never be printed: " & TC_String); - exception - when Ada.Text_IO.Layout_Error => null; -- OK, expected exception. - when The_Error : others => - Report.Failed - ("The following exception was incorrectly raised in " & - "Exception_Block_1: " & Exception_Name(The_Error)); - end Exception_Block_1; - - Exception_Block_2 : - declare - Erroneous_Data_2 : Decimal_Data_Type := -12.34; - Erroneous_Picture_2 : Picture := To_Picture("99.99"); - N : constant Natural := Image_IO.Length(Erroneous_Picture_2); - TC_String : String(1..N); - begin - TC_String := Image_IO.Image(Erroneous_Data_2, Erroneous_Picture_2); - Report.Failed("Layout_Error not raised by combination of " & - "Erroneous_Picture_2 and Erroneous_Data_2"); - Report.Comment("Should never be printed: " & TC_String); - exception - when Ada.Text_IO.Layout_Error => null; -- OK, expected exception. - when The_Error : others => - Report.Failed - ("The following exception was incorrectly raised in " & - "Exception_Block_2: " & Exception_Name(The_Error)); - end Exception_Block_2; - - exception - when The_Error : others => - Report.Failed("The following exception was raised in the " & - "Test_Block: " & Exception_Name(The_Error)); - end Test_Block; - - Report.Result; - -end CXF3004; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a deleted file mode 100644 index 202a6996e32..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a +++ /dev/null @@ -1,167 +0,0 @@ --- CXF3A01.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 function Ada.Text_IO.Editing.Valid returns False if --- a) Pic_String is not a well-formed Picture string, or --- b) the length of Pic_String exceeds Max_Picture_Length, or --- c) Blank_When_Zero is True and Pic_String contains '*'; --- Check that Valid otherwise returns True. --- --- TEST DESCRIPTION: --- This test validates the results of function Editing.Valid under a --- variety of conditions. Both valid and invalid picture strings are --- provided as input parameters to the function. The use of the --- Blank_When_Zero parameter is evaluated with strings that contain the --- zero suppression character '*'. --- --- TEST FILES: --- The following files comprise this test: --- --- FXF3A00.A (foundation code) --- => CXF3A01.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with FXF3A00; -with Ada.Text_IO.Editing; -with Report; - -procedure CXF3A01 is -begin - - Report.Test ("CXF3A01", "Check that the Valid function from package " & - "Ada.Text_IO.Editing returns False for strings " & - "that fail to comply with the composition " & - "constraints defined for picture strings. " & - "Check that the Valid function returns True " & - "for strings that conform to the composition " & - "constraints defined for picture strings"); - - Test_Block: - declare - use FXF3A00; - use Ada.Text_IO; - begin - - -- Use a series of picture strings that conform to the composition - -- constraints to validate the Ada.Text_IO.Editing.Valid function. - -- The result for each of these calls should be True. - -- In all the following cases, the default value of the Blank_When_Zero - -- parameter is used. - - for i in 1..FXF3A00.Number_Of_Valid_Strings loop - - if not Editing.Valid(Pic_String => FXF3A00.Valid_Strings(i).all) - then - Report.Failed("Incorrect result from Function Valid using " & - "Valid_String = " & FXF3A00.Valid_Strings(i).all); - end if; - - end loop; - - - for i in 1..FXF3A00.Number_Of_Foreign_Strings loop - - if not Editing.Valid(Pic_String => FXF3A00.Foreign_Strings(i).all) - then - Report.Failed("Incorrect result from Function Valid using " & - "Foreign_String = " & - FXF3A00.Foreign_Strings(i).all); - end if; - - end loop; - - - -- Use a series of picture strings that violate one or more of the - -- composition constraints to validate the Ada.Text_IO.Editing.Valid - -- function. The result for each of these calls should be False. - -- In all the following cases, the default value of the Blank_When_Zero - -- parameter is used. - - for i in 1..FXF3A00.Number_Of_Invalid_Strings loop - - if Editing.Valid(Pic_String => FXF3A00.Invalid_Strings(i).all) - then - Report.Failed("Incorrect result from Function Valid using " & - "Invalid_String = " & - FXF3A00.Invalid_Strings(i).all); - end if; - - end loop; - - - -- In all the following cases, the default value of the Blank_When_Zero - -- parameter is overridden with a True actual parameter value. Using - -- valid picture strings that contain the '*' zero suppression character - -- when this parameter value is True must result in a False result - -- from function Valid. Valid picture strings that do not contain the - -- '*' character should return a function result of True with True - -- provided as the actual parameter to Blank_When_Zero. - - -- Check entries 1, 2, 25, 36 from the Valid_Strings array, all of - -- which contain the '*' zero suppression character. - - if Editing.Valid(Valid_Strings(1).all, Blank_When_Zero => True) or - Editing.Valid(Valid_Strings(2).all, Blank_When_Zero => True) or - Editing.Valid(Valid_Strings(25).all, Blank_When_Zero => True) or - Editing.Valid(Valid_Strings(36).all, Blank_When_Zero => True) - then - Report.Failed - ("Incorrect result from Function Valid when setting " & - "the value of the Blank_When_Zero parameter to True, " & - "and using picture strings with the '*' character"); - end if; - - - -- Check entries from the Valid_Strings array, none of - -- which contain the '*' zero suppression character. - - for i in 3..24 loop - - if not Editing.Valid(Pic_String => Valid_Strings(i).all, - Blank_When_Zero => True) - then - Report.Failed("Incorrect result from Function Valid when " & - "setting the value of the Blank_When_Zero " & - "parameter to True, and using picture strings " & - "without the '*' character, Valid_String = " & - FXF3A00.Valid_Strings(i).all); - end if; - - end loop; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXF3A01; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a deleted file mode 100644 index 4231b56aa46..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a +++ /dev/null @@ -1,267 +0,0 @@ --- CXF3A02.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 function Ada.Text_IO.Editing.To_Picture raises --- Picture_Error if the picture string provided as input parameter does --- not conform to the composition constraints defined for picture --- strings. --- Check that when Pic_String is applied to To_Picture, the result --- is equivalent to the actual string parameter of To_Picture; --- Check that when Blank_When_Zero is applied to To_Picture, the result --- is the same value as the Blank_When_Zero parameter of To_Picture. --- --- TEST DESCRIPTION: --- This test validates that function Editing.To_Picture returns a --- Picture result when provided a valid picture string, and raises a --- Picture_Error exception when provided an invalid picture string --- input parameter. In addition, the Picture result of To_Picture is --- converted back to a picture string value using function Pic_String, --- and the result of function Blank_When_Zero is validated based on the --- value of parameter Blank_When_Zero used in the formation of the Picture --- by function To_Picture. --- --- TEST FILES: --- The following files comprise this test: --- --- FXF3A00.A (foundation code) --- => CXF3A02.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 11 Mar 97 PWB.CTA Corrected invalid picture string and uppercase --- problem. ---! - -with FXF3A00; -with Ada.Text_IO.Editing; -with Ada.Strings.Maps; -with Ada.Strings.Fixed; -with Report; - -procedure CXF3A02 is - - Lower_Alpha : constant String := "abcdefghijklmnopqrstuvwxyz"; - Upper_Alpha : constant String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; - function UpperCase ( Source : String ) return String is - begin - return - Ada.Strings.Fixed.Translate - ( Source => Source, - Mapping => Ada.Strings.Maps.To_Mapping - ( From => Lower_Alpha, - To => Upper_Alpha ) ); - end UpperCase; - -begin - - Report.Test ("CXF3A02", "Check that the function " & - "Ada.Text_IO.Editing.To_Picture raises " & - "Picture_Error if the picture string provided " & - "as input parameter does not conform to the " & - "composition constraints defined for picture " & - "strings"); - - Test_Block: - declare - - use Ada.Text_IO; - use FXF3A00; - - TC_Picture : Editing.Picture; - TC_Blank_When_Zero : Boolean; - - begin - - - -- Validate that function To_Picture does not raise Picture_Error when - -- provided a valid picture string as an input parameter. - - for i in 1..FXF3A00.Number_Of_Valid_Strings loop - begin - TC_Picture := - Editing.To_Picture(Pic_String => Valid_Strings(i).all, - Blank_When_Zero => False ); - exception - when Editing.Picture_Error => - Report.Failed - ("Picture_Error raised by function To_Picture " & - "with a valid picture string as input parameter, " & - "Valid_String = " & FXF3A00.Valid_Strings(i).all); - when others => - Report.Failed("Unexpected exception raised - 1, " & - "Valid_String = " & FXF3A00.Valid_Strings(i).all); - end; - end loop; - - - - -- Validate that function To_Picture raises Picture_Error when an - -- invalid picture string is provided as an input parameter. - -- Default value used for parameter Blank_When_Zero. - - for i in 1..FXF3A00.Number_Of_Invalid_Strings loop - begin - TC_Picture := - Editing.To_Picture(Pic_String => FXF3A00.Invalid_Strings(i).all); - Report.Failed - ("Picture_Error not raised by function To_Picture " & - "with an invalid picture string as input parameter, " & - "Invalid_String = " & FXF3A00.Invalid_Strings(i).all); - exception - when Editing.Picture_Error => null; -- OK, expected exception. - when others => - Report.Failed("Unexpected exception raised, " & - "Invalid_String = " & - FXF3A00.Invalid_Strings(i).all); - end; - end loop; - - - - -- Validate that To_Picture and Pic_String/Blank_When_Zero provide - -- "inverse" results. - - -- Use the default value of the Blank_When_Zero parameter (False) for - -- these evaluations (some valid strings have the '*' zero suppression - -- character, which would result in an invalid string if used with a - -- True value for the Blank_When_Zero parameter). - - for i in 1..FXF3A00.Number_Of_Valid_Strings loop - begin - - -- Format a picture string using function To_Picture. - - TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all); - - -- Reconvert the Picture result from To_Picture to a string value - -- using function Pic_String, and compare to the original string. - - if Editing.Pic_String(Pic => TC_Picture) /= - Uppercase (FXF3A00.Valid_Strings(i).all) - then - Report.Failed - ("Inverse result incorrect from Editing.Pic_String, " & - "Valid_String = " & FXF3A00.Valid_Strings(i).all); - end if; - - -- Ensure that function Blank_When_Zero returns the correct value - -- of the Blank_When_Zero parameter used in forming the Picture - -- (default parameter value False used in call to To_Picture - -- above). - - if Editing.Blank_When_Zero(Pic => TC_Picture) then - Report.Failed - ("Inverse result incorrect from Editing.Blank_When_Zero, " & - "Valid_String = " & FXF3A00.Valid_Strings(i).all); - end if; - - exception - when others => - Report.Failed("Unexpected exception raised - 2, " & - "Valid_String = " & FXF3A00.Valid_Strings(i).all); - end; - end loop; - - - -- Specifically check that any lower case letters in the original - -- picture string have been converted to upper case form following - -- the To_Picture/Pic_String conversion (as shown in previous loop). - - declare - The_Picture : Editing.Picture; - The_Picture_String : constant String := "+bBbZz_zZz_Zz9.99"; - The_Expected_Result : constant String := "+BBBZZ_ZZZ_ZZ9.99"; - begin - -- Convert Picture String to Picture. - The_Picture := Editing.To_Picture(Pic_String => The_Picture_String); - - declare - -- Reconvert the Picture to a Picture String. - The_Result : constant String := Editing.Pic_String(The_Picture); - begin - if The_Result /= The_Expected_Result then - Report.Failed("Conversion to Picture/Reconversion to String " & - "did not produce expected result when Picture " & - "String had lower case letters"); - end if; - end; - end; - - - -- Use a value of True for the Blank_When_Zero parameter for the - -- following evaluations (picture strings that do not have the '*' zero - -- suppression character, which would result in an invalid string when - -- used here with a True value for the Blank_When_Zero parameter). - - for i in 3..24 loop - begin - - -- Format a picture string using function To_Picture. - - TC_Picture := - Editing.To_Picture(Pic_String => Valid_Strings(i).all, - Blank_When_Zero => True); - - -- Reconvert the Picture result from To_Picture to a string value - -- using function Pic_String, and compare to the original string. - - if Editing.Pic_String(Pic => TC_Picture) /= - UpperCase (FXF3A00.Valid_Strings(i).all) - then - Report.Failed - ("Inverse result incorrect from Editing.Pic_String, used " & - "on Picture formed with parameter Blank_When_Zero = True, " & - "Valid_String = " & FXF3A00.Valid_Strings(i).all); - end if; - - -- Ensure that function Blank_When_Zero returns the correct value - -- of the Blank_When_Zero parameter used in forming the Picture - -- (default parameter value False overridden in call to - -- To_Picture above). - - if not Editing.Blank_When_Zero(Pic => TC_Picture) then - Report.Failed - ("Inverse result incorrect from Editing.Blank_When_Zero, " & - "used on a Picture formed with parameter Blank_When_Zero " & - "= True, Valid_String = " & FXF3A00.Valid_Strings(i).all); - end if; - - exception - when others => - Report.Failed("Unexpected exception raised - 3, " & - "Valid_String = " & FXF3A00.Valid_Strings(i).all); - end; - end loop; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXF3A02; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a deleted file mode 100644 index 86709601464..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a +++ /dev/null @@ -1,429 +0,0 @@ --- CXF3A03.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 function Length in the generic package Decimal_Output --- returns the number of characters in the edited output string --- produced by function Image, for a particular decimal type, --- currency string, and radix mark. --- Check that function Valid in the generic package Decimal_Output --- returns correct results based on the particular decimal value, --- and the Picture and Currency string parameters. --- --- TEST DESCRIPTION: --- This test uses two instantiations of package Decimal_Output, one --- for decimal data with delta 0.01, the other for decimal data with --- delta 1.0. The functions Length and Valid found in this generic --- package are evaluated for each instantiation. --- Function Length is examined with picture and currency string input --- parameters of different sizes. --- Function Valid is examined with a decimal type data item, picture --- object, and currency string, for cases that are both valid and --- invalid (Layout_Error would result from the particular items as --- input parameters to function Image). --- --- TEST FILES: --- The following files comprise this test: --- --- FXF3A00.A (foundation code) --- => CXF3A03.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with FXF3A00; -with Ada.Text_IO.Editing; -with Report; - -procedure CXF3A03 is -begin - - Report.Test ("CXF3A03", "Check that function Length returns the " & - "number of characters in the edited output " & - "string produced by function Image, for a " & - "particular decimal type, currency string, " & - "and radix mark. Check that function Valid " & - "returns correct results based on the " & - "particular decimal value, and the Picture " & - "and Currency string parameters"); - - Test_Block: - declare - - use Ada.Text_IO; - use FXF3A00; - - type Instantiation_Type is (NDP, TwoDP); - - -- Defaults used for all other generic parameters in these - -- instantiations. - package Pack_NDP is new Editing.Decimal_Output (Decimal_Type_NDP); - package Pack_2DP is new Editing.Decimal_Output (Decimal_Type_2DP); - - TC_Lower_Bound, - TC_Higher_Bound : Integer := 0; - - TC_Picture : Editing.Picture; - TC_US_String : constant String := "$"; - TC_FF_String : constant String := "FF"; - TC_DM_String : constant String := "DM"; - TC_CHF_String : constant String := "CHF"; - - - function Dollar_Sign_Present (Str : String) return Boolean is - begin - for i in 1..Str'Length loop - if Str(i) = '$' then - return True; - end if; - end loop; - return False; - end Dollar_Sign_Present; - - function V_Present (Str : String) return Boolean is - begin - for i in 1..Str'Length loop - if Str(i) = 'V' or Str(i) = 'v' then - return True; - end if; - end loop; - return False; - end V_Present; - - - function Accurate_Length (Pict_Str : String; - Inst : Instantiation_Type; - Currency_String : String) - return Boolean is - - TC_Length : Natural := 0; - TC_Currency_Length_Adjustment : Natural := 0; - TC_Radix_Adjustment : Natural := 0; - begin - - -- Create the picture object from the picture string. - TC_Picture := Editing.To_Picture(Pict_Str); - - -- Calculate the currency length adjustment. - if Dollar_Sign_Present (Editing.Pic_String(TC_Picture)) then - TC_Currency_Length_Adjustment := Currency_String'Length - 1; - end if; - - -- Calculate the Radix adjustment. - if V_Present (Editing.Pic_String(TC_Picture)) then - TC_Radix_Adjustment := 1; - end if; - - -- Calculate the length, using the version of Length that comes - -- from the appropriate instantiation of Decimal_Output, based - -- on the decimal type used in the instantiation. - if Inst = NDP then - TC_Length := Pack_NDP.Length(TC_Picture, - Currency_String); - else - TC_Length := Pack_2DP.Length(TC_Picture, - Currency_String); - end if; - - return TC_Length = Editing.Pic_String(TC_Picture)'Length + - TC_Currency_Length_Adjustment - - TC_Radix_Adjustment; - end Accurate_Length; - - - begin - - Length_Block: - begin - - -- The first 10 picture strings in the Valid_Strings array correspond - -- to data values of a decimal type with delta 0.01. - -- Note: The appropriate instantiation of the Decimal_Output package - -- (and therefore function Length) is used by function - -- Accurate_Length to calculate length. - - for i in 1..10 loop - if not Accurate_Length (FXF3A00.Valid_Strings(i).all, - TwoDP, - TC_US_String) - then - Report.Failed("Incorrect result from function Length, " & - "when used with a decimal type with delta .01 " & - "and with the currency string " & TC_US_String & - " in evaluating picture string " & - FXF3A00.Valid_Strings(i).all ); - end if; - end loop; - - - -- Picture strings 17-20 in the Valid_Strings array correspond - -- to data values of a decimal type with delta 1.0. Again, the - -- instantiation of Decimal_Output used is based on this particular - -- decimal type. - - for i in 17..20 loop - if not Accurate_Length (FXF3A00.Valid_Strings(i).all, - NDP, - TC_US_String) - then - Report.Failed("Incorrect result from function Length, " & - "when used with a decimal type with delta 1.0 " & - "and with the currency string " & TC_US_String & - " in evaluating picture string " & - FXF3A00.Valid_Strings(i).all ); - end if; - end loop; - - - -- The first 4 picture strings in the Foreign_Strings array - -- correspond to data values of a decimal type with delta 0.01, - -- and to the currency string "FF" (two characters). - - for i in 1..FXF3A00.Number_of_FF_Strings loop - if not Accurate_Length (FXF3A00.Foreign_Strings(i).all, - TwoDP, - TC_FF_String) - then - Report.Failed("Incorrect result from function Length, " & - "when used with a decimal type with delta .01 " & - "and with the currency string " & TC_FF_String & - " in evaluating picture string " & - FXF3A00.Foreign_Strings(i).all ); - end if; - end loop; - - - -- Picture strings 5-9 in the Foreign_Strings array correspond - -- to data values of a decimal type with delta 0.01, and to the - -- currency string "DM" (two characters). - - TC_Lower_Bound := FXF3A00.Number_of_FF_Strings + 1; - TC_Higher_Bound := FXF3A00.Number_of_FF_Strings + - FXF3A00.Number_of_DM_Strings; - - for i in TC_Lower_Bound..TC_Higher_Bound loop - if not Accurate_Length (FXF3A00.Foreign_Strings(i).all, - TwoDP, - TC_DM_String) - then - Report.Failed("Incorrect result from function Length, " & - "when used with a decimal type with delta .01 " & - "and with the currency string " & TC_DM_String & - " in evaluating picture string " & - FXF3A00.Foreign_Strings(i).all ); - end if; - end loop; - - - -- Picture string #10 in the Foreign_Strings array corresponds - -- to a data value of a decimal type with delta 0.01, and to the - -- currency string "CHF" (three characters). - - if not Accurate_Length (FXF3A00.Foreign_Strings(10).all, - TwoDP, - TC_CHF_String) - then - Report.Failed("Incorrect result from function Length, " & - "when used with a decimal type with delta .01 " & - "and with the currency string " & - TC_CHF_String); - end if; - - exception - when others => - Report.Failed("Unexpected exception raised in Length_Block"); - end Length_Block; - - - Valid_Block: - declare - - -- This offset value is used to align picture string and decimal - -- data values from package FXF3A00 for proper correspondence for - -- the evaluations below. - - TC_Offset : constant Natural := 10; - - begin - - -- The following four For Loops examine cases where the - -- decimal data/picture string/currency combinations used will - -- generate valid Edited Output strings. These combinations, when - -- provided to the Function Valid (from instantiations of - -- Decimal_Output), should result in a return result of True. - -- The particular instantiated version of Valid used in these loops - -- is that for decimal data with delta 0.01. - - -- The first 4 picture strings in the Foreign_Strings array - -- correspond to data values of a decimal type with delta 0.01, - -- and to the currency string "FF" (two characters). - - for i in 1..FXF3A00.Number_of_FF_Strings loop - -- Create the picture object from the picture string. - TC_Picture := Editing.To_Picture(FXF3A00.Foreign_Strings(i).all); - - if not Pack_2DP.Valid (FXF3A00.Data_With_2DP(TC_Offset + i), - TC_Picture, - TC_FF_String) - then - Report.Failed("Incorrect result from function Valid, " & - "when used with a decimal type with delta .01 " & - "and with the currency string " & TC_FF_String & - " in evaluating picture string " & - FXF3A00.Foreign_Strings(i).all ); - end if; - end loop; - - - -- Picture strings 5-9 in the Foreign_Strings array correspond - -- to data values of a decimal type with delta 0.01, and to the - -- currency string "DM" (two characters). - - TC_Lower_Bound := FXF3A00.Number_of_FF_Strings + 1; - TC_Higher_Bound := FXF3A00.Number_of_FF_Strings + - FXF3A00.Number_of_DM_Strings; - - for i in TC_Lower_Bound..TC_Higher_Bound loop - -- Create the picture object from the picture string. - TC_Picture := Editing.To_Picture(FXF3A00.Foreign_Strings(i).all); - - if not Pack_2DP.Valid (FXF3A00.Data_With_2DP(TC_Offset + i), - TC_Picture, - TC_DM_String) - then - Report.Failed("Incorrect result from function Valid, " & - "when used with a decimal type with delta .01 " & - "and with the currency string " & TC_DM_String & - " in evaluating picture string " & - FXF3A00.Foreign_Strings(i).all ); - end if; - end loop; - - - -- Picture string #10 in the Foreign_Strings array corresponds - -- to a data value of a decimal type with delta 0.01, and to the - -- currency string "CHF" (three characters). - - -- Create the picture object from the picture string. - TC_Picture := Editing.To_Picture(FXF3A00.Foreign_Strings(10).all); - - if not Pack_2DP.Valid (FXF3A00.Data_With_2DP(TC_Offset + 10), - TC_Picture, - TC_CHF_String) - then - Report.Failed("Incorrect result from function Valid, " & - "when used with a decimal type with delta .01 " & - "and with the currency string " & - TC_CHF_String); - end if; - - - -- The following For Loop examines cases where the - -- decimal data/picture string/currency combinations used will - -- generate valid Edited Output strings. - -- The particular instantiated version of Valid used in this loop - -- is that for decimal data with delta 1.0; the others above have - -- been for decimal data with delta 0.01. - -- Note: TC_Offset is used here to align picture strings from the - -- FXF3A00.Valid_Strings table with the appropriate decimal - -- data in the FXF3A00.Data_With_NDP table. - - for i in 1..FXF3A00.Number_Of_NDP_Items loop - -- Create the picture object from the picture string. - TC_Picture := - Editing.To_Picture(FXF3A00.Valid_Strings(TC_Offset + i).all); - - if not Pack_NDP.Valid (FXF3A00.Data_With_NDP(i), - TC_Picture, - TC_US_String) - then - Report.Failed("Incorrect result from function Valid, " & - "when used with a decimal type with delta .01 " & - "and with the currency string " & TC_US_String & - " in evaluating picture string " & - FXF3A00.Valid_Strings(i).all ); - end if; - end loop; - - - -- The following three evaluations of picture strings, used in - -- conjunction with the specific decimal values provided, will cause - -- Editing.Image to raise Layout_Error (to be examined in other - -- tests). Function Valid should return a False result for these - -- combinations. - -- The first two evaluations use the instantiation of Decimal_Output - -- with a decimal type with delta 0.01, while the last evaluation - -- uses the instantiation with decimal type with delta 1.0. - - for i in 1..FXF3A00.Number_of_Erroneous_Conditions loop - - -- Create the picture object from the picture string. - TC_Picture := - Editing.To_Picture(FXF3A00.Erroneous_Strings(i).all); - - if i < 3 then -- Choose the appropriate instantiation. - if Pack_2DP.Valid(Item => FXF3A00.Erroneous_Data(i), - Pic => TC_Picture, - Currency => TC_US_String) - then - Report.Failed("Incorrect result from function Valid, " & - "when used with a decimal type with delta " & - "0.01 and with the currency string " & - TC_US_String & - " in evaluating picture string " & - FXF3A00.Valid_Strings(i).all ); - end if; - else - if Pack_NDP.Valid(Item => FXF3A00.Decimal_Type_NDP( - FXF3A00.Erroneous_Data(i)), - Pic => TC_Picture, - Currency => TC_US_String) - then - Report.Failed("Incorrect result from function Valid, " & - "when used with a decimal type with delta " & - "1.0 and with the currency string " & - TC_US_String & - " in evaluating picture string " & - FXF3A00.Valid_Strings(i).all ); - end if; - end if; - end loop; - - exception - when others => - Report.Failed("Unexpected exception raised in Valid_Block"); - end Valid_Block; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXF3A03; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a deleted file mode 100644 index 9eee39bb694..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a +++ /dev/null @@ -1,293 +0,0 @@ --- CXF3A04.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 edited output string value returned by Function Image --- is correct. --- --- TEST DESCRIPTION: --- This test is structured using tables of data, consisting of --- numerical values, picture strings, and expected image --- result strings. These data tables are found in package FXF3A00. --- --- The results of the Image function are examined under a number of --- circumstances. The generic package Decimal_Output is instantiated --- twice, for decimal data with delta 0.01 and delta 1.0. Each version --- of Image is called with both default parameters and user-provided --- parameters. The results of each call to Image are compared to an --- expected edited output result string. --- --- In addition, three calls to Image are designed to raise Layout_Error, --- due to the combination of decimal value and picture string provided --- as input parameters. If Layout_Error is not raised, or an alternate --- exception is raised instead, test failure results. --- --- TEST FILES: --- The following files comprise this test: --- --- FXF3A00.A (foundation code) --- => CXF3A04.A --- --- --- CHANGE HISTORY: --- 22 JAN 95 SAIC Initial prerelease version. --- 11 MAR 97 PWB.CTA Corrected incorrect index expression ---! - -with FXF3A00; -with Ada.Text_IO.Editing; -with Report; - -procedure CXF3A04 is -begin - - Report.Test ("CXF3A04", "Check that the string value returned by " & - "Function Image is correct, based on the " & - "numerical data and picture formatting " & - "parameters provided to the function"); - - Test_Block: - declare - - use Ada.Text_IO; - - -- Instantiate the Decimal_Output generic package for the two data - -- types, using the default values for the Default_Currency, - -- Default_Fill, Default_Separator, and Default_Radix_Mark - -- parameters. - - package Pack_NDP is - new Editing.Decimal_Output (FXF3A00.Decimal_Type_NDP); - - package Pack_2DP is - new Editing.Decimal_Output (FXF3A00.Decimal_Type_2DP); - - TC_Currency : constant String := "$"; - TC_Fill : constant Character := '*'; - TC_Separator : constant Character := ','; - TC_Radix_Mark : constant Character := '.'; - - TC_Picture : Editing.Picture; - - - begin - - Two_Decimal_Place_Data: - -- Use a decimal fixed point type with delta 0.01 (two decimal places) - -- and valid picture strings. Evaluate the result of function Image - -- with the expected edited output result string. - declare - - TC_Loop_End : constant := -- 10 - FXF3A00.Number_Of_2DP_Items - FXF3A00.Number_Of_Foreign_Strings; - - begin - -- The first 10 picture strings in the Valid_Strings array - -- correspond to data values of a decimal type with delta 0.01. - - -- Compare string result of Image with expected edited output - -- string. Evaluate data using both default parameters of Image - -- and user-provided parameter values. - for i in 1..TC_Loop_End loop - - -- Create the picture object from the picture string. - TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all); - - -- Use the default parameters for this loop evaluation of Image. - if Pack_2DP.Image(FXF3A00.Data_With_2DP(i), TC_Picture) /= - FXF3A00.Edited_Output(i).all - then - Report.Failed("Incorrect result from Function Image, " & - "when used with a decimal type with delta " & - "0.01, picture string " & - FXF3A00.Valid_Strings(i).all & - ", and the default parameters of Image"); - end if; - - -- Use user-provided parameters for this loop evaluation of Image. - - if Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i), - Pic => TC_Picture, - Currency => TC_Currency, - Fill => TC_Fill, - Separator => TC_Separator, - Radix_Mark => TC_Radix_Mark) /= - FXF3A00.Edited_Output(i).all - then - Report.Failed("Incorrect result from Function Image, " & - "when used with a decimal type with delta " & - "0.01, picture string " & - FXF3A00.Valid_Strings(i).all & - ", and user-provided parameters"); - end if; - - end loop; - - exception - when others => - Report.Failed("Exception raised in Two_Decimal_Place_Data block"); - end Two_Decimal_Place_Data; - - - - No_Decimal_Place_Data: - -- Use a decimal fixed point type with delta 1.00 (no decimal places) - -- and valid picture strings. Evaluate the result of function Image - -- with the expected result string. - declare - - use Editing, FXF3A00; - - TC_Offset : constant := 10; - TC_Loop_Start : constant := TC_Offset + 1; -- 11 - TC_Loop_End : constant := TC_Loop_Start + - Number_Of_NDP_Items - 1; -- 22 - - begin - -- The following evaluations correspond to data values of a - -- decimal type with delta 1.0. - - -- Compare string result of Image with expected edited output - -- string. Evaluate data using both default parameters of Image - -- and user-provided parameter values. - -- Note: TC_Offset is used to align corresponding data the various - -- data tables in foundation package FXF3A00. - - for i in TC_Loop_Start..TC_Loop_End loop - - -- Create the picture object from the picture string. - TC_Picture := To_Picture(Valid_Strings(i).all); - - -- Use the default parameters for this loop evaluation of Image. - if not (Pack_NDP.Image(Data_With_NDP(i-TC_Offset), TC_Picture) = - Edited_Output(TC_Offset+i).all) - then - Report.Failed("Incorrect result from Function Image, " & - "when used with a decimal type with delta " & - "1.0, picture string " & - Valid_Strings(i).all & - ", and the default parameters of Image"); - end if; - - -- Use user-provided parameters for this loop evaluation of Image. - if Pack_NDP.Image(Item => Data_With_NDP(i - TC_Offset), - Pic => TC_Picture, - Currency => TC_Currency, - Fill => TC_Fill, - Separator => TC_Separator, - Radix_Mark => TC_Radix_Mark) /= - Edited_Output(TC_Offset+i).all - then - Report.Failed("Incorrect result from Function Image, " & - "when used with a decimal type with delta " & - "1.0, picture string " & - Valid_Strings(i).all & - ", and user-provided parameters"); - end if; - - end loop; - - exception - when others => - Report.Failed("Exception raised in No_Decimal_Place_Data block"); - end No_Decimal_Place_Data; - - - - Exception_Block: - -- The following three calls of Function Image, using the specific - -- decimal values and picture strings provided, will cause - -- a Layout_Error to be raised. - -- The first two evaluations use the instantiation of Decimal_Output - -- with a decimal type with delta 0.01, while the last evaluation - -- uses the instantiation with decimal type with delta 1.0. - - -- Note: The data and the picture strings used in the following - -- evaluations are not themselves erroneous, but when used in - -- combination will cause Layout_Error to be raised. - - begin - - for i in 1..FXF3A00.Number_Of_Erroneous_Conditions loop -- 1..3 - begin - -- Create the picture object from the picture string. - TC_Picture := - Editing.To_Picture(FXF3A00.Erroneous_Strings(i).all); - - -- Layout_Error must be raised by the following calls to - -- Function Image. - - if i < 3 then -- Choose the appropriate instantiation. - declare - N : constant Natural := Pack_2DP.Length(TC_Picture); - TC_String : String(1..N); - begin - TC_String := Pack_2DP.Image(FXF3A00.Erroneous_Data(i), - TC_Picture); - end; - else - declare - use FXF3A00; - N : constant Natural := Pack_NDP.Length(TC_Picture, - TC_Currency); - TC_String : String(1..N); - begin - TC_String := - Pack_NDP.Image(Item => Decimal_Type_NDP( - Erroneous_Data(i)), - Pic => TC_Picture, - Currency => TC_Currency, - Fill => TC_Fill, - Separator => TC_Separator, - Radix_Mark => TC_Radix_Mark); - end; - end if; - - Report.Failed("Layout_Error not raised by combination " & - "# " & Integer'Image(i) & " " & - "of decimal data and picture string"); - - exception - when Layout_Error => null; -- Expected exception. - when others => - Report.Failed("Incorrect exception raised by combination " & - "# " & Integer'Image(i) & " " & - "of decimal data and picture string"); - end; - end loop; - - exception - when others => - Report.Failed("Unexpected exception raised in Exception_Block"); - end Exception_Block; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXF3A04; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a deleted file mode 100644 index 3fb39332a50..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a +++ /dev/null @@ -1,266 +0,0 @@ --- CXF3A05.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 Function Image produces correct results when provided --- non-default parameters for Currency, Fill, Separator, and --- Radix_Mark at either the time of package Decimal_Output instantiation, --- or in a call to Image. Check non-default parameters that are --- appropriate for foreign currency representations. --- --- TEST DESCRIPTION: --- This test is structured using tables of data, consisting of --- numerical values, picture strings, and expected image --- result strings. These data tables are found in package FXF3A00. --- --- The results of the Image function, resulting from several different --- instantiations of Decimal_Output, are compared with expected --- edited output string results. The primary focus of this test is to --- examine the effect of non-default parameters, provided during the --- instantiation of package Decimal_Output, or provided as part of a --- call to Function Image (that resulted from an instantiation of --- Decimal_Output that used default parameters). The non-default --- parameters provided correspond to foreign currency representations. --- --- For each picture string/decimal data combination examined, two --- evaluations of Image are performed. These correspond to the two --- methods of providing the appropriate non-default parameters described --- above. Both forms of Function Image should produce the same expected --- edited output string. --- --- TEST FILES: --- The following files comprise this test: --- --- FXF3A00.A (foundation code) --- => CXF3A05.A --- --- --- CHANGE HISTORY: --- 26 JAN 95 SAIC Initial prerelease version. --- 17 FEB 97 PWB.CTA Correct array indices for Foreign_Strings array --- references. ---! - -with FXF3A00; -with Ada.Text_IO.Editing; -with Report; - -procedure CXF3A05 is -begin - - Report.Test ("CXF3A05", "Check that Function Image produces " & - "correct results when provided non-default " & - "parameters for Currency, Fill, Separator, " & - "and Radix_Mark, appropriate to foreign " & - "currency representations"); - - Test_Block: - declare - - use Ada.Text_IO; - - -- Instantiate the Decimal_Output generic package for the several - -- combinations of Default_Currency, Default_Fill, Default_Separator, - -- and Default_Radix_Mark. - - package Pack_Def is -- Uses default parameter values. - new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP); - - package Pack_FF is - new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP, - Default_Currency => "FF", - Default_Fill => '*', - Default_Separator => '.', - Default_Radix_Mark => ','); - - package Pack_DM is - new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP, - Default_Currency => "DM", - Default_Fill => '*', - Default_Separator => ',', - Default_Radix_Mark => '.'); - - package Pack_CHF is - new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP, - Default_Currency => "CHF", - Default_Fill => '*', - Default_Separator => ',', - Default_Radix_Mark => '.'); - - - TC_Picture : Editing.Picture; - TC_Start_Loop : constant := 11; - TC_End_Loop : constant := TC_Start_Loop + -- 20 - FXF3A00.Number_Of_Foreign_Strings - 1; - - begin - - -- In the case of each particular type of foreign string examined, - -- two versions of Function Image are examined. First, a version of - -- the function that originated from an instantiation of Decimal_Output - -- with non-default parameters is checked. This version of Image is - -- called making use of default parameters in the actual function call. - -- In addition, a version of Function Image is checked that resulted - -- from an instantiation of Decimal_Output using default parameters, - -- but which uses non-default parameters in the function call. - - for i in TC_Start_Loop..TC_End_Loop loop - - -- Create the picture object from the picture string. - - TC_Picture := Editing.To_Picture - (FXF3A00.Foreign_Strings(i - TC_Start_Loop + 1).all); - - -- Based on the ordering of the specific foreign picture strings - -- in the FXF3A00.Foreign_Strings table, the following conditional - -- is used to determine which type of currency is being examined - -- as the loop executes. - - if i < TC_Start_Loop + FXF3A00.Number_Of_FF_Strings then -- (11-14) - -- Process the FF picture strings. - - -- Check the result of Function Image from an instantiation - -- of Decimal_Output that provided non-default actual - -- parameters at the time of package instantiation, and uses - -- default parameters in the call of Image. - - if Pack_FF.Image(Item => FXF3A00.Data_With_2DP(i), - Pic => TC_Picture) /= - FXF3A00.Edited_Output(i).all - then - Report.Failed("Incorrect output from Function Image " & - "from package instantiated with FF " & - "related parameters, using picture string " & - FXF3A00.Foreign_Strings - (i - TC_Start_Loop + 1).all); - end if; - - -- Check the result of Function Image that originated from - -- an instantiation of Decimal_Output where default parameters - -- were used at the time of package Instantiation, but where - -- non-default parameters are provided in the call of Image. - - if Pack_Def.Image(Item => FXF3A00.Data_With_2DP(i), - Pic => TC_Picture, - Currency => "FF", - Fill => '*', - Separator => '.', - Radix_Mark => ',') /= - FXF3A00.Edited_Output(i).all - then - Report.Failed("Incorrect output from Function Image " & - "from package instantiated with default " & - "parameters, using picture string " & - FXF3A00.Foreign_Strings - (i - TC_Start_Loop + 1).all & - ", and FF related parameters in call to Image"); - end if; - - - elsif i < TC_Start_Loop + -- (15-19) - FXF3A00.Number_Of_FF_Strings + - FXF3A00.Number_Of_DM_Strings then - -- Process the DM picture strings. - - -- Non-default instantiation parameters, default function call - -- parameters. - - if Pack_DM.Image(Item => FXF3A00.Data_With_2DP(i), - Pic => TC_Picture) /= - FXF3A00.Edited_Output(i).all - then - Report.Failed("Incorrect output from Function Image " & - "from package instantiated with DM " & - "related parameters, using picture string " & - FXF3A00.Foreign_Strings - (i - TC_Start_Loop + 1).all); - end if; - - -- Default instantiation parameters, non-default function call - -- parameters. - - if Pack_Def.Image(Item => FXF3A00.Data_With_2DP(i), - Pic => TC_Picture, - Currency => "DM", - Fill => '*', - Separator => ',', - Radix_Mark => '.') /= - FXF3A00.Edited_Output(i).all - then - Report.Failed("Incorrect output from Function Image " & - "from package instantiated with default " & - "parameters, using picture string " & - FXF3A00.Foreign_Strings - (i - TC_Start_Loop + 1).all & - ", and DM related parameters in call to Image"); - end if; - - - else -- (i=20) - -- Process the CHF string. - - -- Non-default instantiation parameters, default function call - -- parameters. - - if Pack_CHF.Image(FXF3A00.Data_With_2DP(i), TC_Picture) /= - FXF3A00.Edited_Output(i).all - then - Report.Failed("Incorrect output from Function Image " & - "from package instantiated with CHF " & - "related parameters, using picture string " & - FXF3A00.Foreign_Strings - (i - TC_Start_Loop + 1).all); - end if; - - -- Default instantiation parameters, non-default function call - -- parameters. - - if Pack_Def.Image(FXF3A00.Data_With_2DP(i), - TC_Picture, - "CHF", - '*', - ',', - '.') /= - FXF3A00.Edited_Output(i).all - then - Report.Failed("Incorrect output from Function Image " & - "from package instantiated with default " & - "parameters, using picture string " & - FXF3A00.Foreign_Strings - (i - TC_Start_Loop + 1).all & - ", and CHF related parameters in call to Image"); - end if; - - end if; - - end loop; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXF3A05; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a deleted file mode 100644 index 7b769ba96bf..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a +++ /dev/null @@ -1,302 +0,0 @@ --- CXF3A06.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 Ada.Text_IO.Editing.Put and Ada.Text_IO.Put have the same --- effect. --- --- TEST DESCRIPTION: --- This test is structured using tables of data, consisting of --- numerical values, picture strings, and expected image --- result strings. These data tables are found in package FXF3A00. --- --- The testing approach used in this test is that of writing edited --- output data to a text file, using two different approaches. First, --- Ada.Text_IO.Put is used, with a call to an instantiated version of --- Function Image supplied as the actual for parameter Item. The --- second approach is to use a version of Function Put from an --- instantiation of Ada.Text_IO.Editing.Decimal_Output, with the --- appropriate parameters for decimal data, picture, and format --- specific parameters. A call to New_Line follows each Put, so that --- each entry is placed on a separate line in the text file. --- --- Edited output for decimal data with two decimal places is in the --- first loop, and once the data has been written to the file, the --- text file is closed, then opened in In_File mode. The edited --- output data is read from the file, and data on successive lines --- is compared with the expected edited output result. The edited --- output data produced by both of the Put procedures should be --- identical. --- --- This process is repeated for decimal data with no decimal places. --- The file is reopened in Append_File mode, and the edited output --- data is added to the file in the same manner as described above. --- The file is closed, and reopened to verify the data written. --- The data written above (with two decimal places) is skipped, then --- the data to be verified is extracted as above and verified against --- the expected edited output string values. --- --- APPLICABILITY CRITERIA: --- This test is applicable only to implementations that support --- external text files. --- --- TEST FILES: --- The following files comprise this test: --- --- FXF3A00.A (foundation code) --- => CXF3A06.A --- --- --- CHANGE HISTORY: --- 26 JAN 95 SAIC Initial prerelease version. --- 26 FEB 97 PWB.CTA Made input buffers sufficiently long --- and removed code depending on shorter buffers ---! - -with FXF3A00; -with Ada.Text_IO.Editing; -with Report; - -procedure CXF3A06 is - use Ada; -begin - - Report.Test ("CXF3A06", "Check that Ada.Text_IO.Editing.Put and " & - "Ada.Text_IO.Put have the same effect"); - - Test_for_Text_IO_Support: - declare - Text_File : Ada.Text_IO.File_Type; - Text_Filename : constant String := Report.Legal_File_Name(1); - begin - - -- Use_Error will be raised if Text_IO operations or external files - -- are not supported. - - Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename); - - Test_Block: - declare - use Ada.Text_IO; - - -- Instantiate the Decimal_Output generic package for two - -- different decimal data types. - - package Pack_2DP is -- Uses decimal type with delta 0.01. - new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP); - - package Pack_NDP is -- Uses decimal type with delta 1.0. - new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_NDP, - Default_Currency => "$", - Default_Fill => '*', - Default_Separator => ',', - Default_Radix_Mark => '.'); - - TC_Picture : Editing.Picture; - TC_Start_Loop : constant := 1; - TC_End_Loop_1 : constant := FXF3A00.Number_Of_2DP_Items - -- 20-10 - FXF3A00.Number_Of_Foreign_Strings; - TC_End_Loop_2 : constant := FXF3A00.Number_Of_NDP_Items; -- 12 - TC_Offset : constant := FXF3A00.Number_Of_2DP_Items; -- 20 - - TC_String_1, TC_String_2 : String(1..255) := (others => ' '); - TC_Last_1, TC_Last_2 : Natural := 0; - - begin - - -- Use the two versions of Put, for data with two decimal points, - -- to write edited output strings to the text file. Use a separate - -- line for each string entry. - - for i in TC_Start_Loop..TC_End_Loop_1 loop -- 1..10 - - -- Create the picture object from the picture string. - - TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all); - - -- Use the Text_IO version of Put to place an edited output - -- string into a text file. Use default parameters in the call - -- to Image for Currency, Fill, Separator, and Radix_Mark. - - Text_IO.Put(Text_File, - Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i), - Pic => TC_Picture)); - Text_IO.New_Line(Text_File); - - -- Use the version of Put from the instantiation of - -- Decimal_Output to place an edited output string on a separate - -- line of the Text_File. Use default parameters for Currency, - -- Fill, Separator, and Radix_Mark. - - Pack_2DP.Put(File => Text_File, - Item => FXF3A00.Data_With_2DP(i), - Pic => TC_Picture); - Text_IO.New_Line(Text_File); - - end loop; - - Text_IO.Close(Text_File); - - -- Reopen the text file in In_File mode, and verify the edited - -- output found on consecutive lines of the file. - - Text_IO.Open(Text_File, Text_IO.In_File, Text_Filename); - - for i in TC_Start_Loop..TC_End_Loop_1 loop - -- Read successive lines in the text file. - Text_IO.Get_Line(Text_File, TC_String_1, TC_Last_1); - Text_IO.Get_Line(Text_File, TC_String_2, TC_Last_2); - - -- Compare the two strings for equality with the expected edited - -- output result. Failure results if strings don't match, or if - -- a reading error occurred from the attempted Get_Line resulting - -- from an improperly formed edited output string. - - if TC_String_1(1..TC_Last_1) /= FXF3A00.Edited_Output(i).all or - TC_String_2(1..TC_Last_2) /= FXF3A00.Edited_Output(i).all - then - Report.Failed("Failed comparison of two edited output " & - "strings from data with two decimal points " & - ", loop number = " & Integer'Image(i)); - end if; - end loop; - - Text_IO.Close(Text_File); - - -- Reopen the text file in Append_File mode. - -- Use the two versions of Put, for data with no decimal points, - -- to write edited output strings to the text file. Use a separate - -- line for each string entry. - - Text_IO.Open(Text_File, Text_IO.Append_File, Text_Filename); - - for i in TC_Start_Loop..TC_End_Loop_2 loop -- 1..12 - - -- Create the picture object from the picture string specific to - -- data with no decimal points. Use appropriate offset into the - -- Valid_Strings array to account for the string data used above. - - TC_Picture := - Editing.To_Picture(FXF3A00.Valid_Strings(i+TC_End_Loop_1).all); - - -- Use the Text_IO version of Put to place an edited output - -- string into a text file. Use non-default parameters in the - -- call to Image for Currency, Fill, Separator, and Radix_Mark. - - Text_IO.Put(Text_File, - Pack_NDP.Image(Item => FXF3A00.Data_With_NDP(i), - Pic => TC_Picture, - Currency => "$", - Fill => '*', - Separator => ',', - Radix_Mark => '.')); - Text_IO.New_Line(Text_File); - - -- Use the version of Put from the instantiation of - -- Decimal_Output to place an edited output string on a separate - -- line of the Text_File. Use non-default parameters for - -- Currency, Fill, Separator, and Radix_Mark. - - Pack_NDP.Put(File => Text_File, - Item => FXF3A00.Data_With_NDP(i), - Pic => TC_Picture, - Currency => "$", - Fill => '*', - Separator => ',', - Radix_Mark => '.'); - Text_IO.New_Line(Text_File); - - end loop; - - Text_IO.Close(Text_File); - - -- Reopen the text file in In_File mode, and verify the edited - -- output found on consecutive lines of the file. - - Text_IO.Open(Text_File, Text_IO.In_File, Text_Filename); - - -- Read past data that has been verified above, skipping two lines - -- of the data file for each loop. - - for i in TC_Start_Loop..TC_End_Loop_1 loop -- 1..10 - Text_IO.Skip_Line(Text_File, 2); - end loop; - - -- Verify the last data set that was written to the file. - - for i in TC_Start_Loop..TC_End_Loop_2 loop -- 1..12 - Text_IO.Get_Line(Text_File, TC_String_1, TC_Last_1); - Text_IO.Get_Line(Text_File, TC_String_2, TC_Last_2); - - -- Compare the two strings for equality with the expected edited - -- output result. Failure results if strings don't match, or if - -- a reading error occurred from the attempted Get_Line resulting - -- from an improperly formed edited output string. - - if TC_String_1(1..TC_Last_1) /= - FXF3A00.Edited_Output(i+TC_Offset).all or - TC_String_2(1..TC_Last_2) /= - FXF3A00.Edited_Output(i+TC_Offset).all - then - Report.Failed("Failed comparison of two edited output " & - "strings from data with no decimal points " & - ", loop number = " & - Integer'Image(i)); - end if; - - end loop; - - exception - when others => Report.Failed("Exception raised in Test_Block"); - end Test_Block; - - -- Delete the external file. - if Text_IO.Is_Open (Text_File) then - Text_IO.Delete (Text_File); - else - Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); - Text_IO.Delete (Text_File); - end if; - - exception - - -- Since Use_Error can be raised if, for the specified mode, - -- the environment does not support Text_IO operations, the - -- following handlers are included: - - when Text_IO.Use_Error => - Report.Not_Applicable ("Use_Error raised on Text_IO Create"); - - when Text_IO.Name_Error => - Report.Not_Applicable ("Name_Error raised on Text_IO Create"); - - when others => - Report.Failed ("Unexpected exception raised in Create block"); - - end Test_for_Text_IO_Support; - - Report.Result; - -end CXF3A06; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a deleted file mode 100644 index 7cb2c360c97..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a +++ /dev/null @@ -1,337 +0,0 @@ --- CXF3A07.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 Ada.Text_IO.Editing.Put and Ada.Strings.Fixed.Move --- have the same effect in putting edited output results into string --- variables. --- --- TEST DESCRIPTION: --- This test is structured using tables of data, consisting of --- numerical values, picture strings, and expected image --- result strings. These data tables are found in package FXF3A00. --- --- The operation of the two above subprograms are examined twice, first --- with the output of an edited output string to a receiving string --- object of equal size, the other to a receiving string object of --- larger size, where justification and padding are considered. --- The procedure Editing.Put will place an edited output string into --- a larger receiving string with right justification and blank fill. --- Procedure Move has parameter control of justification and fill, and --- in this test will mirror Put by specifying right justification and --- blank fill. --- --- In the cases where the edited output string is of shorter length --- than the receiving string object, a blank-filled constant string --- will be catenated to the front of the expected edited output string --- for comparison with the receiving string object, enabling direct --- string comparison for result verification. --- --- TEST FILES: --- The following files comprise this test: --- --- FXF3A00.A (foundation code) --- => CXF3A07.A --- --- --- CHANGE HISTORY: --- 30 JAN 95 SAIC Initial prerelease version. --- 11 MAR 97 PWB.CTA Fixed string lengths ---! - -with FXF3A00; -with Ada.Text_IO.Editing; -with Ada.Strings.Fixed; -with Report; - -procedure CXF3A07 is -begin - - Report.Test ("CXF3A07", "Check that Ada.Text_IO.Editing.Put and " & - "Ada.Strings.Fixed.Move have the same " & - "effect in putting edited output results " & - "into string variables"); - Test_Block: - declare - - use Ada.Text_IO; - - -- Instantiate the Decimal_Output generic package for two - -- different decimal data types. - - package Pack_2DP is -- Uses decimal type with delta 0.01. - new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP); - - package Pack_NDP is -- Uses decimal type with delta 1.0. - new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_NDP, - Default_Currency => "$", - Default_Fill => '*', - Default_Separator => ',', - Default_Radix_Mark => '.'); - - TC_Picture : Editing.Picture; - TC_Start_Loop : Integer := 0; - TC_End_Loop : Integer := 0; - TC_Offset : Integer := 0; - TC_Length : Natural := 0; - - TC_Put_String_20, -- Longer than the longest edited - TC_Move_String_20 : String(1..20); -- output string. - - TC_Put_String_17, -- Exact length of longest edited - TC_Move_String_17 : String(1..17); -- output string in 2DP-US data set. - - TC_Put_String_8, -- Exact length of longest edited - TC_Move_String_8 : String(1..8); -- output string in NDP-US data set. - - - begin - - -- Examine cases where the output string is longer than the length - -- of the edited output result. Use the instantiation of - -- Decimal_Output specific to data with two decimal places. - - TC_Start_Loop := 1; - TC_End_Loop := FXF3A00.Number_of_2DP_Items - -- 10 - FXF3A00.Number_Of_Foreign_Strings; - - for i in TC_Start_Loop..TC_End_Loop loop -- 1..10 - - -- Create the picture object from the picture string. - - TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all, - Blank_When_Zero => False); - - -- Determine the actual length of the edited output string - -- that is expected from Put and Image. - - TC_Length := Pack_2DP.Length(Pic => TC_Picture, - Currency => "$"); - - -- Determine the difference in length between the receiving string - -- object and the expected length of the edited output string. - -- Define a blank filled string constant with length equal to this - -- length difference. - - declare - TC_Length_Diff : Integer := TC_Put_String_20'Length - - TC_Length; - TC_Buffer_String : constant String(1..TC_Length_Diff) := - (others => ' '); - begin - - -- Fill the two receiving string objects with edited output, - -- using the two different methods (Put and Move). - - Pack_2DP.Put(To => TC_Put_String_20, - Item => FXF3A00.Data_With_2DP(i), - Pic => TC_Picture, - Currency => "$", - Fill => '*', - Separator => ',', - Radix_Mark => '.'); - - - Ada.Strings.Fixed.Move - (Source => Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i), - Pic => TC_Picture, - Currency => "$", - Fill => '*', - Separator => ',', - Radix_Mark => '.'), - Target => TC_Move_String_20, - Drop => Ada.Strings.Error, - Justify => Ada.Strings.Right, - Pad => Ada.Strings.Space); - - -- Each receiving string object is now filled with the edited - -- output result, right justified. - -- Compare these two string objects with the expected edited - -- output value, which is appended to the blank filled string - -- whose length is the difference between the expected edited - -- output length and the length of the receiving strings. - - if TC_Buffer_String & FXF3A00.Edited_Output(i).all /= - TC_Put_String_20 or - TC_Buffer_String & FXF3A00.Edited_Output(i).all /= - TC_Move_String_20 - then - Report.Failed("Failed case where the output string is " & - "longer than the length of the edited " & - "output result, loop #" & Integer'Image(i)); - end if; - - exception - when Layout_Error => - Report.Failed("Layout_Error raised when the output string " & - "is longer than the length of the edited " & - "output result, loop #" & Integer'Image(i)); - when others => - Report.Failed("Exception raised when the output string is " & - "longer than the length of the edited " & - "output result, loop #" & Integer'Image(i)); - end; - end loop; - - - -- Repeat the above loop, but only evaluate three cases - those where - -- the length of the expected edited output string is the exact length - -- of the receiving strings (no justification will be required within - -- the string. This series of evaluations again uses decimal data - -- with two decimal places. - - for i in TC_Start_Loop..TC_End_Loop loop -- 1..10 - - case i is - when 1 | 5 | 7 => - - -- Create the picture object from the picture string. - TC_Picture := - Editing.To_Picture(FXF3A00.Valid_Strings(i).all); - - -- Fill the two receiving string objects with edited output, - -- using the two different methods (Put and Move). - -- Use default parameters in the various calls where possible. - - Pack_2DP.Put(To => TC_Put_String_17, - Item => FXF3A00.Data_With_2DP(i), - Pic => TC_Picture); - - - Ada.Strings.Fixed.Move - (Source => Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i), - Pic => TC_Picture), - Target => TC_Move_String_17); - - -- Each receiving string object is now filled with the edited - -- output result. Compare these two string objects with the - -- expected edited output value. - - if FXF3A00.Edited_Output(i).all /= TC_Put_String_17 or - FXF3A00.Edited_Output(i).all /= TC_Move_String_17 - then - Report.Failed("Failed case where the output string is " & - "the exact length of the edited output " & - "result, loop #" & Integer'Image(i)); - end if; - - when others => null; - end case; - end loop; - - - -- Evaluate a mix of cases, where the expected edited output string - -- length is either exactly as long or shorter than the receiving - -- output string parameter. This series of evaluations uses decimal - -- data with no decimal places. - - TC_Start_Loop := TC_End_Loop + 1; -- 11 - TC_End_Loop := TC_Start_Loop + -- 22 - FXF3A00.Number_of_NDP_Items - 1; - TC_Offset := FXF3A00.Number_of_Foreign_Strings; -- 10 - -- This offset is required due to the arrangement of data within the - -- tables found in FXF3A00. - - for i in TC_Start_Loop..TC_End_Loop loop -- 11..22 - - -- Create the picture object from the picture string. - - TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all); - - -- Determine the actual length of the edited output string - -- that is expected from Put and Image. - - TC_Length := Pack_NDP.Length(TC_Picture); - - -- Fill the two receiving string objects with edited output, - -- using the two different methods (Put and Move). - - Pack_NDP.Put(TC_Put_String_8, - FXF3A00.Data_With_NDP(i-TC_Offset), - TC_Picture); - - Ada.Strings.Fixed.Move - (Pack_NDP.Image(FXF3A00.Data_With_NDP(i-TC_Offset), TC_Picture), - TC_Move_String_8, - Ada.Strings.Error, - Ada.Strings.Right, - Ada.Strings.Space); - - -- Determine if there is a difference in length between the - -- receiving string object and the expected length of the edited - -- output string. If so, then define a blank filled string constant - -- with length equal to this length difference. - - if TC_Length < TC_Put_String_8'Length then - declare - TC_Length_Diff : Integer := TC_Put_String_8'Length - - TC_Length; - TC_Buffer_String : constant String(1..TC_Length_Diff) := - (others => ' '); - begin - - -- Each receiving string object is now filled with the edited - -- output result, right justified. - -- Compare these two string objects with the expected edited - -- output value, which is appended to the blank filled string - -- whose length is the difference between the expected edited - -- output length and the length of the receiving strings. - - if TC_Buffer_String & FXF3A00.Edited_Output(i+TC_Offset).all /= - TC_Put_String_8 or - TC_Buffer_String & FXF3A00.Edited_Output(i+TC_Offset).all /= - TC_Move_String_8 - then - Report.Failed("Failed case where the output string is " & - "longer than the length of the edited " & - "output result, loop #" & Integer'Image(i) & - ", using data with no decimal places"); - end if; - end; - else - - -- Compare these two string objects with the expected edited - -- output value, which is appended to the blank filled string - -- whose length is the difference between the expected edited - -- output length and the length of the receiving strings. - - if FXF3A00.Edited_Output(i+TC_Offset).all /= TC_Put_String_8 or - FXF3A00.Edited_Output(i+TC_Offset).all /= TC_Move_String_8 - then - Report.Failed("Failed case where the output string is " & - "the same length as the edited output " & - "result, loop #" & Integer'Image(i) & - ", using data with no decimal places"); - end if; - end if; - end loop; - - exception - when others => Report.Failed("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXF3A07; diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a deleted file mode 100644 index 871ab5600a9..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a +++ /dev/null @@ -1,289 +0,0 @@ --- CXF3A08.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 version of Ada.Text_IO.Editing.Put with an out --- String parameter propagates Layout_Error if the edited output string --- result of Put exceeds the length of the out String parameter. --- --- TEST DESCRIPTION: --- This test is structured using tables of data, consisting of --- numerical values, picture strings, and expected image --- result strings. These data tables are found in package FXF3A00. --- --- This test examines the case of the out string parameter to Procedure --- Put being insufficiently long to hold the entire edited output --- string result of the procedure. In this case, Layout_Error is to be --- raised. Test failure results if Layout_Error is not raised, or if an --- exception other than Layout_Error is raised. --- --- A number of data combinations are examined, using instantiations --- of Package Decimal_Output with different decimal data types and --- both default and non-default parameters as generic actual parameters. --- In addition, calls to Procedure Put are performed using default --- parameters, non-default parameters, and non-default parameters that --- override the generic actual parameters provided at the time of --- instantiation of Decimal_Output. --- --- TEST FILES: --- The following files comprise this test: --- --- FXF3A00.A (foundation code) --- => CXF3A08.A --- --- --- CHANGE HISTORY: --- 31 JAN 95 SAIC Initial prerelease version. --- ---! - -with FXF3A00; -with Ada.Text_IO.Editing; -with Report; - -procedure CXF3A08 is -begin - - Report.Test ("CXF3A08", "Check that the version of " & - "Ada.Text_IO.Editing.Put with an out " & - "String parameter propagates Layout_Error " & - "if the output string exceeds the length " & - "of the out String parameter"); - - Test_Block: - declare - - use Ada.Text_IO; - - -- Instantiate the Decimal_Output generic package for two - -- different decimal data types. - -- Uses decimal type with delta 0.01 and - package Pack_2DP is -- non-default generic actual parameters. - new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_2DP, - Default_Currency => "$", - Default_Fill => '*', - Default_Separator => ',', - Default_Radix_Mark => '.'); - - package Pack_NDP is -- Uses decimal type with delta 1.0. - new Editing.Decimal_Output(FXF3A00.Decimal_Type_NDP); - - TC_Picture : Editing.Picture; - TC_Start_Loop : Integer := 0; - TC_End_Loop : Integer := 0; - TC_Offset : Integer := 0; - - TC_Short_String : String(1..4); -- Shorter than the shortest edited - -- output string result. - - begin - - -- Examine cases where the out string parameter is shorter than - -- the length of the edited output result. Use the instantiation of - -- Decimal_Output specific to data with two decimal places. - - TC_Start_Loop := 1; - TC_End_Loop := FXF3A00.Number_of_2DP_Items - -- 10 - FXF3A00.Number_Of_Foreign_Strings; - - for i in TC_Start_Loop..TC_End_Loop loop -- 1..10 - - -- Create the picture object from the picture string. - - TC_Picture := - Editing.To_Picture(Pic_String => FXF3A00.Valid_Strings(i).all, - Blank_When_Zero => False); - - -- The out parameter string provided in the call to Put is - -- shorter than the edited output result of the procedure. - -- This will result in a Layout_Error being raised and handled. - -- Test failure results from no exception being raised, or from - -- the wrong exception being raised. - - begin - - -- Use the instantiation of Decimal_Output specific to decimal - -- data with two decimal places, as well as non-default - -- parameters and named parameter association. - - Pack_2DP.Put(To => TC_Short_String, - Item => FXF3A00.Data_With_2DP(i), - Pic => TC_Picture, - Currency => "$", - Fill => '*', - Separator => ',', - Radix_Mark => '.'); - - -- Test failure if exception not raised. - - Report.Failed - ("Layout_Error not raised, decimal data with two decimal " & - "places, loop #" & Integer'Image(i)); - - exception - when Layout_Error => null; -- OK, expected exception. - when others => - Report.Failed - ("Incorrect exception raised, Layout_Error expected, " & - "decimal data with two decimal places, loop #" & - Integer'Image(i)); - end; - end loop; - - - -- Perform similar evaluations as above, but use the instantiation - -- of Decimal_Output specific to decimal data with no decimal places. - - TC_Start_Loop := TC_End_Loop + 1; -- 11 - TC_End_Loop := TC_Start_Loop + -- 22 - FXF3A00.Number_of_NDP_Items - 1; - TC_Offset := FXF3A00.Number_of_Foreign_Strings; -- 10 - -- This offset is required due to the arrangement of data within the - -- tables found in FXF3A00. - - for i in TC_Start_Loop..TC_End_Loop loop -- 11..22 - - -- Create the picture object from the picture string. - - TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all); - - begin - - -- Use the instantiation of Decimal_Output specific to decimal - -- data with no decimal places, as well as default parameters - -- and positional parameter association. - - Pack_NDP.Put(TC_Short_String, - FXF3A00.Data_With_NDP(i-TC_Offset), - TC_Picture); - - -- Test failure if exception not raised. - - Report.Failed - ("Layout_Error not raised, decimal data with no decimal " & - "places, loop #" & Integer'Image(i)); - - exception - when Layout_Error => null; -- OK, expected exception. - when others => - Report.Failed - ("Incorrect exception raised, Layout_Error expected, " & - "decimal data with no decimal places, loop #" & - Integer'Image(i)); - end; - - end loop; - - - -- Check that Layout_Error is raised by Put resulting from an - -- instantiation of Decimal_Output specific to foreign currency - -- representations. - -- Note: Both of the following evaluation sets use decimal data with - -- two decimal places. - - declare - - package Pack_FF is - new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_2DP, - Default_Currency => "FF", - Default_Fill => '*', - Default_Separator => '.', - Default_Radix_Mark => ','); - - begin - - TC_Offset := FXF3A00.Number_Of_2DP_Items - -- 10 - FXF3A00.Number_Of_Foreign_Strings; - - for i in 1..FXF3A00.Number_Of_FF_Strings loop -- 1..4 - begin - - -- Create the picture object from the picture string. - TC_Picture := - Editing.To_Picture(FXF3A00.Foreign_Strings(i).all); - - Pack_FF.Put(To => TC_Short_String, - Item => FXF3A00.Data_With_2DP(i+TC_Offset), - Pic => TC_Picture); - - Report.Failed("Layout_Error was not raised by Put from " & - "an instantiation of Decimal_Output using " & - "non-default parameters specific to FF " & - "currency, loop #" & Integer'Image(i)); - - exception - when Layout_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by Put from " & - "an instantiation of Decimal_Output using " & - "non-default parameters specific to FF " & - "currency, loop #" & Integer'Image(i)); - end; - end loop; - - - -- These evaluations use a version of Put resulting from a - -- non-default instantiation of Decimal_Output, but which has - -- specific foreign currency parameters provided in the call that - -- override the generic actual parameters provided at instantiation. - - TC_Offset := TC_Offset + FXF3A00.Number_Of_FF_Strings; -- 14 - - for i in 1..FXF3A00.Number_Of_DM_Strings loop -- 1..5 - begin - TC_Picture := - Editing.To_Picture(FXF3A00.Foreign_Strings - (i+FXF3A00.Number_Of_FF_Strings).all); - - Pack_2DP.Put(To => TC_Short_String, - Item => FXF3A00.Data_With_2DP(i+TC_Offset), - Pic => TC_Picture, - Currency => "DM", - Fill => '*', - Separator => ',', - Radix_Mark => '.'); - - Report.Failed("Layout_Error was not raised by Put using " & - "non-default parameters specific to DM " & - "currency, loop #" & Integer'Image(i)); - - exception - when Layout_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by Put using " & - "non-default parameters specific to DM " & - "currency, loop #" & Integer'Image(i)); - end; - end loop; - - end; - - exception - when others => Report.Failed("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXF3A08; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a deleted file mode 100644 index 01a0f061e51..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a +++ /dev/null @@ -1,276 +0,0 @@ --- CXG1001.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 subprograms defined in the package --- Ada.Numerics.Generic_Complex_Types provide correct results. --- Specifically, check the functions Re, Im (both versions), procedures --- Set_Re, Set_Im (both versions), functions Compose_From_Cartesian (all --- versions), Compose_From_Polar, Modulus, Argument, and "abs". --- --- TEST DESCRIPTION: --- The generic package Generic_Complex_Types --- is instantiated with a real type (new Float), and the results --- produced by the specified subprograms are verified. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 15 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1. --- Modified subtest for Compose_From_Polar. --- 29 Sep 96 SAIC Incorporated reviewer comments. --- ---! - -with Ada.Numerics.Generic_Complex_Types; -with Report; - -procedure CXG1001 is - -begin - - Report.Test ("CXG1001", "Check that the subprograms defined in " & - "the package Ada.Numerics.Generic_Complex_Types " & - "provide correct results"); - - Test_Block: - declare - - type Real_Type is new Float; - - package Complex_Pack is new - Ada.Numerics.Generic_Complex_Types(Real_Type); - - use type Complex_Pack.Complex; - - -- Declare a zero valued complex number. - Complex_Zero : constant Complex_Pack.Complex := (0.0, 0.0); - - TC_Complex : Complex_Pack.Complex := Complex_Zero; - TC_Imaginary : Complex_Pack.Imaginary; - - begin - - -- Check that the procedures Set_Re and Set_Im (both versions) provide - -- correct results. - - declare - TC_Complex_Real_Field : Complex_Pack.Complex := (5.0, 0.0); - TC_Complex_Both_Fields : Complex_Pack.Complex := (5.0, 7.0); - begin - - Complex_Pack.Set_Re(X => TC_Complex, Re => 5.0); - - if TC_Complex /= TC_Complex_Real_Field then - Report.Failed("Incorrect results from Procedure Set_Re"); - end if; - - Complex_Pack.Set_Im(X => TC_Complex, Im => 7.0); - - if TC_Complex.Re /= 5.0 or - TC_Complex.Im /= 7.0 or - TC_Complex /= TC_Complex_Both_Fields - then - Report.Failed("Incorrect results from Procedure Set_Im " & - "with Complex argument"); - end if; - - Complex_Pack.Set_Im(X => TC_Imaginary, Im => 3.0); - - - if Complex_Pack.Im(TC_Imaginary) /= 3.0 then - Report.Failed("Incorrect results returned following the use " & - "of Procedure Set_Im with Imaginary argument"); - end if; - - end; - - - -- Check that the functions Re and Im (both versions) provide - -- correct results. - - declare - TC_Complex_1 : Complex_Pack.Complex := (1.0, 0.0); - TC_Complex_2 : Complex_Pack.Complex := (0.0, 2.0); - TC_Complex_3 : Complex_Pack.Complex := (4.0, 3.0); - begin - - -- Function Re. - - if Complex_Pack.Re(X => TC_Complex_1) /= 1.0 or - Complex_Pack.Re(X => TC_Complex_2) /= 0.0 or - Complex_Pack.Re(X => TC_Complex_3) /= 4.0 - then - Report.Failed("Incorrect results from Function Re"); - end if; - - -- Function Im; version with Complex argument. - - if Complex_Pack.Im(X => TC_Complex_1) /= 0.0 or - Complex_Pack.Im(X => TC_Complex_2) /= 2.0 or - Complex_Pack.Im(X => TC_Complex_3) /= 3.0 - then - Report.Failed("Incorrect results from Function Im " & - "with Complex argument"); - end if; - - - -- Function Im; version with Imaginary argument. - - if Complex_Pack.Im(Complex_Pack.i) /= 1.0 or - Complex_Pack.Im(Complex_Pack.j) /= 1.0 - then - Report.Failed("Incorrect results from use of Function Im " & - "when used with an Imaginary argument"); - end if; - - end; - - - -- Verify the results of the three versions of Function - -- Compose_From_Cartesian - - declare - - Zero : constant Real_Type := 0.0; - Six : constant Real_Type := 6.0; - - TC_Complex_1 : Complex_Pack.Complex := (3.0, 8.0); - TC_Complex_2 : Complex_Pack.Complex := (Six, Zero); - TC_Complex_3 : Complex_Pack.Complex := (Zero, 1.0); - - begin - - TC_Complex := Complex_Pack.Compose_From_Cartesian(3.0, 8.0); - - if TC_Complex /= TC_Complex_1 then - Report.Failed("Incorrect results from Function " & - "Compose_From_Cartesian - 1"); - end if; - - -- If only one component is given, the other component is - -- implicitly zero (Both components are set by the following two - -- function calls). - - TC_Complex := Complex_Pack.Compose_From_Cartesian(Re => 6.0); - - if TC_Complex /= TC_Complex_2 then - Report.Failed("Incorrect results from Function " & - "Compose_From_Cartesian - 2"); - end if; - - TC_Complex := - Complex_Pack.Compose_From_Cartesian(Im => Complex_Pack.i); - - if TC_Complex /= TC_Complex_3 then - Report.Failed("Incorrect results from Function " & - "Compose_From_Cartesian - 3"); - end if; - - end; - - - -- Verify the results of Function Compose_From_Polar, Modulus, "abs", - -- and Argument. - - declare - - use Complex_Pack; - - TC_Modulus, - TC_Argument : Real_Type := 0.0; - - - Angle_0 : constant Real_Type := 0.0; - Angle_90 : constant Real_Type := 90.0; - Angle_180 : constant Real_Type := 180.0; - Angle_270 : constant Real_Type := 270.0; - Angle_360 : constant Real_Type := 360.0; - - begin - - -- Verify the result of Function Compose_From_Polar. - -- When the value of the parameter Modulus is zero, the - -- Compose_From_Polar function yields a result of zero. - - if Compose_From_Polar(0.0, 30.0, 360.0) /= Complex_Zero - then - Report.Failed("Incorrect result from Function " & - "Compose_From_Polar - 1"); - end if; - - -- When the value of the parameter Argument is equal to a multiple - -- of the quarter cycle, the result of the Compose_From_Polar - -- function with specified cycle lies on one of the axes. - - if Compose_From_Polar( 5.0, Angle_0, Angle_360) /= (5.0, 0.0) or - Compose_From_Polar( 5.0, Angle_90, Angle_360) /= (0.0, 5.0) or - Compose_From_Polar(-5.0, Angle_180, Angle_360) /= (5.0, 0.0) or - Compose_From_Polar(-5.0, Angle_270, Angle_360) /= (0.0, 5.0) or - Compose_From_Polar(-5.0, Angle_90, Angle_360) /= (0.0, -5.0) or - Compose_From_Polar( 5.0, Angle_270, Angle_360) /= (0.0, -5.0) - then - Report.Failed("Incorrect result from Function " & - "Compose_From_Polar - 2"); - end if; - - -- When the parameter to Function Argument represents a point on - -- the non-negative real axis, the function yields a zero result. - - if Argument(Complex_Zero, Angle_360) /= 0.0 then - Report.Failed("Incorrect result from Function Argument"); - end if; - - -- Function Modulus - - if Modulus(Complex_Zero) /= 0.0 or - Modulus(Compose_From_Polar( 5.0, Angle_90, Angle_360)) /= 5.0 or - Modulus(Compose_From_Polar(-5.0, Angle_180, Angle_360)) /= 5.0 - then - Report.Failed("Incorrect results from Function Modulus"); - end if; - - -- Function "abs", a rename of Function Modulus. - - if "abs"(Complex_Zero) /= 0.0 or - "abs"(Compose_From_Polar( 5.0, Angle_90, Angle_360)) /= 5.0 or - "abs"(Compose_From_Polar(-5.0, Angle_180, Angle_360)) /= 5.0 - then - Report.Failed("Incorrect results from Function abs"); - end if; - - end; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXG1001; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a deleted file mode 100644 index 39f5f00dbc3..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a +++ /dev/null @@ -1,198 +0,0 @@ --- CXG1002.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 subprograms defined in the package --- Ada.Numerics.Generic_Complex_Types provide the prescribed results. --- Specifically, check the various versions of functions "+" and "-". --- --- TEST DESCRIPTION: --- This test checks that the subprograms "+" and "-" defined in the --- Generic_Complex_Types package provide the results prescribed for the --- evaluation of these complex arithmetic operations. The functions --- Re and Im are used to extract the appropriate component of the --- complex result, in order that the prescribed result component can be --- verified. --- The generic package is instantiated with a real type (new Float), --- and the results produced by the specified subprograms are verified. --- --- SPECIAL REQUIREMENTS: --- This test can be run in either "relaxed" or "strict" mode. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with Ada.Numerics.Generic_Complex_Types; -with Report; - -procedure CXG1002 is - -begin - - Report.Test ("CXG1002", "Check that the subprograms defined in " & - "the package Ada.Numerics.Generic_Complex_Types " & - "provide the prescribed results"); - - Test_Block: - declare - - type Real_Type is new Float; - - package Complex_Pack is new - Ada.Numerics.Generic_Complex_Types(Real_Type); - use Complex_Pack; - - -- Declare a zero valued complex number using the record - -- aggregate approach. - - Complex_Zero : constant Complex_Pack.Complex := (0.0, 0.0); - - TC_Complex, - TC_Complex_Right, - TC_Complex_Left : Complex_Pack.Complex := Complex_Zero; - - TC_Real : Real_Type := 0.0; - - TC_Imaginary : Complex_Pack.Imaginary; - - begin - - - -- Check that the imaginary component of the result of a binary addition - -- operator that yields a result of complex type is exact when either - -- of its operands is of pure-real type. - - TC_Complex := Compose_From_Cartesian(2.0, 3.0); - TC_Real := 3.0; - - if Im("+"(Left => TC_Complex, Right => TC_Real)) /= 3.0 or - Im("+"(TC_Complex, 6.0)) /= 3.0 or - Im(TC_Complex + TC_Real) /= 3.0 or - Im(TC_Complex + 5.0) /= 3.0 or - Im((7.0, 2.0) + 1.0) /= 2.0 or - Im((7.0, 5.0) + (-2.0)) /= 5.0 or - Im((-7.0, -2.0) + 1.0) /= -2.0 or - Im((-7.0, -3.0) + (-3.0)) /= -3.0 - then - Report.Failed("Incorrect results from Function ""+"" with " & - "one Complex and one Real argument - 1"); - end if; - - if Im("+"(Left => TC_Real, Right => TC_Complex)) /= 3.0 or - Im("+"(4.0, TC_Complex)) /= 3.0 or - Im(TC_Real + TC_Complex) /= 3.0 or - Im(9.0 + TC_Complex) /= 3.0 or - Im(1.0 + (7.0, -9.0)) /= -9.0 or - Im((-2.0) + (7.0, 2.0)) /= 2.0 or - Im(1.0 + (-7.0, -5.0)) /= -5.0 or - Im((-3.0) + (-7.0, 16.0)) /= 16.0 - then - Report.Failed("Incorrect results from Function ""+"" with " & - "one Complex and one Real argument - 2"); - end if; - - - -- Check that the imaginary component of the result of a binary - -- subtraction operator that yields a result of complex type is exact - -- when its right operand is of pure-real type. - - TC_Complex := (8.0, -4.0); - TC_Real := 2.0; - - if Im("-"(Left => TC_Complex, Right => TC_Real)) /= -4.0 or - Im("-"(TC_Complex, 5.0)) /= -4.0 or - Im(TC_Complex - TC_Real) /= -4.0 or - Im(TC_Complex - 4.0) /= -4.0 or - Im((6.0, 5.0) - 1.0) /= 5.0 or - Im((6.0, 13.0) - 7.0) /= 13.0 or - Im((-5.0, 3.0) - (2.0)) /= 3.0 or - Im((-5.0, -6.0) - (-3.0)) /= -6.0 - then - Report.Failed("Incorrect results from Function ""-"" with " & - "one Complex and one Real argument"); - end if; - - - -- Check that the real component of the result of a binary addition - -- operator that yields a result of complex type is exact when either - -- of its operands is of pure-imaginary type. - - TC_Complex := (5.0, 0.0); - - if Re("+"(Left => TC_Complex, Right => i)) /= 5.0 or - Re("+"(Complex_Pack.j, TC_Complex)) /= 5.0 or - Re((-8.0, 5.0) + ( 2.0*i)) /= -8.0 or - Re((2.0, 5.0) + (-2.0*i)) /= 2.0 or - Re((-20.0, -5.0) + ( 3.0*i)) /= -20.0 or - Re((6.0, -5.0) + (-3.0*i)) /= 6.0 - then - Report.Failed("Incorrect results from Function ""+"" with " & - "one Complex and one Imaginary argument"); - end if; - - - -- Check that the real component of the result of a binary - -- subtraction operator that yields a result of complex type is exact - -- when its right operand is of pure-imaginary type. - - TC_Complex := TC_Complex + i; -- Should produce (5.0, 1.0) - - if Re("-"(TC_Complex, i)) /= 5.0 or - Re((-4.0, 4.0) - ( 2.0*i)) /= -4.0 or - Re((9.0, 4.0) - ( 5.0*i)) /= 9.0 or - Re((16.0, -5.0) - ( 3.0*i)) /= 16.0 or - Re((-3.0, -5.0) - (-4.0*i)) /= -3.0 - then - Report.Failed("Incorrect results from Function ""-"" with " & - "one Complex and one Imaginary argument"); - end if; - - - -- Check that the result of a binary addition operation is exact when - -- one of its operands is of real type and the other is of - -- pure-imaginary type; the operator is analogous to the - -- Compose_From_Cartesian function; it performs no arithmetic. - - TC_Complex := Complex_Pack."+"(5.0, Complex_Pack.i); - - if TC_Complex /= (5.0, 1.0) or - (4.0 + i) /= (4.0, 1.0) or - "+"(Left => j, Right => 3.0) /= (3.0, 1.0) - then - Report.Failed("Incorrect results from Function ""+"" with " & - "one Real and one Imaginary argument"); - end if; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXG1002; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a deleted file mode 100644 index c3885136b86..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a +++ /dev/null @@ -1,478 +0,0 @@ --- CXG1003.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 subprograms defined in the package Text_IO.Complex_IO --- provide correct results. --- --- TEST DESCRIPTION: --- The generic package Ada.Numerics.Generic_Complex_Types is instantiated --- with a real type (new Float). The resulting new package is used as --- the generic actual to package Complex_IO. --- Two different versions of Put and Get are examined in this test, --- those that input/output complex data values from/to Text_IO files, --- and those that input/output complex data values from/to strings. --- Two procedures are defined to perform the file data manipulations; --- one to place complex data into the file, and one to retrieve the data --- from the file and verify its correctness. --- Complex data is also put into string variables using the Procedure --- Put for strings, and this data is then retrieved and reconverted into --- complex values using the Get procedure. --- --- --- APPLICABILITY CRITERIA: --- This test is only applicable to implementations that: --- support Annex G, --- support Text_IO and external files --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 29 Dec 94 SAIC Modified Width parameter in Get function calls. --- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1. --- 29 Sep 96 SAIC Incorporated reviewer comments. --- ---! - -with Ada.Text_IO.Complex_IO; -with Ada.Numerics.Generic_Complex_Types; -with Report; - -procedure CXG1003 is -begin - - Report.Test ("CXG1003", "Check that the subprograms defined in " & - "the package Text_IO.Complex_IO " & - "provide correct results"); - - Test_for_Text_IO_Support: - declare - use Ada; - - Data_File : Ada.Text_IO.File_Type; - Data_Filename : constant String := Report.Legal_File_Name; - - begin - - -- An application creates a text file in mode Out_File, with the - -- intention of entering complex data into the file as appropriate. - -- In the event that the particular environment where the application - -- is running does not support Text_IO, Use_Error or Name_Error will be - -- raised on calls to Text_IO operations. Either of these exceptions - -- will be handled to produce a Not_Applicable result. - - Text_IO.Create (File => Data_File, - Mode => Ada.Text_IO.Out_File, - Name => Data_Filename); - - Test_Block: - declare - - TC_Verbose : Boolean := False; - - type Real_Type is new Float; - - package Complex_Pack is new - Ada.Numerics.Generic_Complex_Types(Real_Type); - - package C_IO is new Ada.Text_IO.Complex_IO(Complex_Pack); - - use Ada.Text_IO, C_IO; - use type Complex_Pack.Complex; - - Number_Of_Complex_Items : constant := 6; - Number_Of_Error_Items : constant := 2; - - TC_Complex : Complex_Pack.Complex; - TC_Last_Character_Read : Positive; - - Complex_Array : array (1..Number_Of_Complex_Items) - of Complex_Pack.Complex := ( (3.0, 9.0), - (4.0, 7.0), - (5.0, 6.0), - (6.0, 3.0), - (2.0, 5.0), - (3.0, 7.0) ); - - - procedure Load_Data_File (The_File : in out Text_IO.File_Type) is - use Ada.Text_IO; - begin - -- This procedure does not create, open, or close the data file; - -- The_File file object must be Open at this point. - -- This procedure is designed to load complex data into a data - -- file twice, first using Text_IO, then Complex_IO. In this - -- first case, the complex data values are entered as strings, - -- assuming a variety of legal formats, as provided in the - -- reference manual. - - Put_Line(The_File, "(3.0, 9.0)"); - Put_Line(The_File, "+4. +7."); -- Relaxed real literal format. - Put_Line(The_File, "(5.0 6.)"); - Put_Line(The_File, "6., 3.0"); - Put_Line(The_File, " ( 2.0 , 5.0 ) "); - Put_Line(The_File, "("); -- Complex data separated over - Put_Line(The_File, "3.0"); -- several (5) lines. - Put_Line(The_File, " , "); - Put_Line(The_File, "7.0 "); - Put_Line(The_File, ")"); - - if TC_Verbose then - Report.Comment("Complex values entered into data file using " & - "Text_IO, Procedure Load_Data_File"); - end if; - - -- Use the Complex_IO procedure Put to enter Complex data items - -- into the data file. - -- Note: Data is being entered into the file for the *second* time - -- at this point. (Using Complex_IO here, Text_IO above) - - for i in 1..Number_Of_Complex_Items loop - C_IO.Put(File => The_File, - Item => Complex_Array(i), - Fore => 1, - Aft => 1, - Exp => 0); - end loop; - - if TC_Verbose then - Report.Comment("Complex values entered into data file using " & - "Complex_IO, Procedure Load_Data_File"); - end if; - - Put_Line(The_File, "(5A,3)"); -- data to raise Data_Error. - Put_Line(The_File, "(3.0,,8.0)"); -- data to raise Data_Error. - - end Load_Data_File; - - - - procedure Process_Data_File (The_File : in out Text_IO.File_Type) is - TC_Complex : Complex_Pack.Complex := (0.0, 0.0); - TC_Width : Integer := 0; - begin - -- This procedure does not create, open, or close the data file; - -- The_File file object must be Open at this point. - -- Use procedure Get (for Files) to extract the complex data from - -- the Text_IO file. This data was placed into the file using - -- Text_IO. - - - for i in 1..Number_Of_Complex_Items loop - - C_IO.Get(The_File, TC_Complex, TC_Width); - - if TC_Complex /= Complex_Array(i) then - Report.Failed("Incorrect complex data read from file " & - "when using Text_IO procedure Get, " & - "data item #" & Integer'Image(i)); - end if; - end loop; - - if TC_Verbose then - Report.Comment("First set of complex values extracted " & - "from data file using Complex_IO, " & - "Procedure Process_Data_File"); - end if; - - -- Use procedure Get (for Files) to extract the complex data from - -- the Text_IO file. This data was placed into the file using - -- procedure Complex_IO.Put. - -- Note: Data is being extracted from the file for the *second* - -- time at this point (Using Complex_IO here, Text_IO above) - - for i in 1..Number_Of_Complex_Items loop - - C_IO.Get(The_File, TC_Complex, TC_Width); - - if TC_Complex /= Complex_Array(i) then - Report.Failed("Incorrect complex data read from file " & - "when using Complex_IO procedure Get, " & - "data item #" & Integer'Image(i)); - end if; - end loop; - - if TC_Verbose then - Report.Comment("Second set of complex values extracted " & - "from data file using Complex_IO, " & - "Procedure Process_Data_File"); - end if; - - -- The final items in the Data_File are complex values with - -- incorrect syntax, which should raise Data_Error on an attempt - -- to read them from the file. - TC_Width := 10; - for i in 1..Number_Of_Error_Items loop - begin - C_IO.Get(The_File, TC_Complex, TC_Width); - Report.Failed - ("Exception Data_Error not raised when Complex_IO.Get " & - "was used to read complex data with incorrect " & - "syntax from the Data_File, data item #" & - Integer'Image(i)); - exception - when Ada.Text_IO.Data_Error => -- OK, expected exception. - Text_IO.Skip_Line(The_File); - when others => - Report.Failed - ("Unexpected exception raised when Complex_IO.Get " & - "was used to read complex data with incorrect " & - "syntax from the Data_File, data item #" & - Integer'Image(i)); - end; - end loop; - - if TC_Verbose then - Report.Comment("Erroneous set of complex values extracted " & - "from data file using Complex_IO, " & - "Procedure Process_Data_File"); - end if; - - - exception - when others => - Report.Failed - ("Unexpected exception raised in Process_Data_File"); - end Process_Data_File; - - - - begin -- Test_Block. - - -- Place complex values into data file. - - Load_Data_File(Data_File); - Text_IO.Close(Data_File); - - if TC_Verbose then - Report.Comment("Data file loaded with Complex values"); - end if; - - -- Read complex values from data file. - - Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename); - Process_Data_File(Data_File); - - if TC_Verbose then - Report.Comment("Complex values extracted from data file"); - end if; - - - - -- Verify versions of Procedures Put and Get for Strings. - - declare - TC_String_Array : array (1..Number_Of_Complex_Items) - of String(1..15) := (others =>(others => ' ')); - begin - - -- Place complex values into strings using the Procedure Put. - - for i in 1..Number_Of_Complex_Items loop - C_IO.Put(To => TC_String_Array(i), - Item => Complex_Array(i), - Aft => 1, - Exp => 0); - end loop; - - if TC_Verbose then - Report.Comment("Complex values placed into string array"); - end if; - - -- Check the format of the strings containing a complex number. - -- The resulting strings are of 15 character length, with the - -- real component left justified within the string, followed by - -- a comma, and with the imaginary component and closing - -- parenthesis right justified in the string, with blank fill - -- for the balance of the string. - - if TC_String_Array(1) /= "(3.0, 9.0)" or - TC_String_Array(2) /= "(4.0, 7.0)" or - TC_String_Array(3) /= "(5.0, 6.0)" or - TC_String_Array(4) /= "(6.0, 3.0)" or - TC_String_Array(5) /= "(2.0, 5.0)" or - TC_String_Array(6) /= "(3.0, 7.0)" - then - Report.Failed("Incorrect format for complex values that " & - "have been placed into string variables " & - "using the Complex_IO.Put procedure for " & - "strings"); - end if; - - if TC_Verbose then - Report.Comment("String format of Complex values verified"); - end if; - - -- Get complex values from strings using the Procedure Get. - -- Compare with expected complex values. - - for i in 1..Number_Of_Complex_Items loop - - C_IO.Get(From => TC_String_Array(i), - Item => TC_Complex, - Last => TC_Last_Character_Read); - - if TC_Complex /= Complex_Array(i) then - Report.Failed("Incorrect complex data value obtained " & - "from String following use of Procedures " & - "Put and Get from Strings, Complex_Array " & - "item #" & Integer'Image(i)); - end if; - end loop; - - if TC_Verbose then - Report.Comment("Complex values removed from String array"); - end if; - - -- Verify that Layout_Error is raised if the given string is - -- too short to hold the formatted output. - Layout_Error_On_Put: - declare - Much_Too_Short : String(1..2); - Complex_Value : Complex_Pack.Complex := (5.0, 0.0); - begin - C_IO.Put(Much_Too_Short, Complex_Value); - Report.Failed("Layout_Error not raised by Procedure Put " & - "when the given string was too short to " & - "hold the formatted output"); - exception - when Layout_Error => null; -- OK, expected exception. - when others => - Report.Failed - ("Unexpected exception raised by Procedure Put when " & - "the given string was too short to hold the " & - "formatted output"); - end Layout_Error_On_Put; - - if TC_Verbose then - Report.Comment("Layout Errors verified"); - end if; - - exception - when others => - Report.Failed("Unexpected exception raised during the " & - "evaluation of Put and Get for Strings"); - end; - - - -- Place complex values into strings using a variety of legal - -- complex data formats. - declare - - type String_Ptr is access String; - - TC_Complex_String_Array : - array (1..Number_Of_Complex_Items) of String_Ptr := - (new String'( "(3.0, 9.0 )" ), - new String'( "+4.0 +7.0" ), - new String'( "(5.0 6.0)" ), - new String'( "6.0, 3.0" ), - new String'( " ( 2.0 , 5.0 ) " ), - new String'( "(3.0 7.0)" )); - - -- The following array contains Positive values that correspond - -- to the last character that will be read by Procedure Get when - -- given each of the above strings as input. - - TC_Last_Char_Array : array (1..Number_Of_Complex_Items) - of Positive := (12,10,9,8,20,22); - - begin - - -- Get complex values from strings using the Procedure Get. - -- Compare with expected complex values. - - for i in 1..Number_Of_Complex_Items loop - - C_IO.Get(TC_Complex_String_Array(i).all, - TC_Complex, - TC_Last_Character_Read); - - if TC_Complex /= Complex_Array(i) then - Report.Failed - ("Incorrect complex data value obtained from " & - "Procedure Get with complex data input of: " & - TC_Complex_String_Array(i).all); - end if; - - if TC_Last_Character_Read /= TC_Last_Char_Array(i) then - Report.Failed - ("Incorrect value returned as the last character of " & - "the input string processed by Procedure Get, " & - "string value : " & TC_Complex_String_Array(i).all & - " expected last character value read : " & - Positive'Image(TC_Last_Char_Array(i)) & - " last character value read : " & - Positive'Image(TC_Last_Character_Read)); - end if; - - end loop; - - if TC_Verbose then - Report.Comment("Complex values removed from strings and " & - "verified against expected values"); - end if; - - exception - when others => - Report.Failed("Unexpected exception raised during the " & - "evaluation of Get for Strings"); - end; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - -- Delete the external file. - if Ada.Text_IO.Is_Open(Data_File) then - Ada.Text_IO.Delete(Data_File); - else - Ada.Text_IO.Open(Data_File, - Ada.Text_IO.In_File, - Data_Filename); - Ada.Text_IO.Delete(Data_File); - end if; - - exception - - -- Since Use_Error can be raised if, for the specified mode, - -- the environment does not support Text_IO operations, the - -- following handlers are included: - - when Ada.Text_IO.Use_Error => - Report.Not_Applicable ("Use_Error raised on Text_IO Create"); - - when Ada.Text_IO.Name_Error => - Report.Not_Applicable ("Name_Error raised on Text_IO Create"); - - when others => - Report.Failed ("Unexpected exception raised on text file Create"); - - end Test_for_Text_IO_Support; - - Report.Result; - -end CXG1003; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a deleted file mode 100644 index f026eae70db..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a +++ /dev/null @@ -1,360 +0,0 @@ --- CXG1004.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 specified exceptions are raised by the subprograms --- defined in package Ada.Numerics.Generic_Complex_Elementary_Functions --- given the prescribed input parameter values. --- --- TEST DESCRIPTION: --- This test checks that specific subprograms defined in the --- package Ada.Numerics.Generic_Complex_Elementary_Functions raise the --- exceptions Argument_Error and Constraint_Error when their input --- parameter value are those specified as causing each exception. --- In the case of Constraint_Error, the exception will be raised in --- each test case, provided that the value of the attribute --- 'Machine_Overflows (for the actual type of package --- Generic_Complex_Type) is True. --- --- APPLICABILITY CRITERIA: --- This test only applies to implementations supporting the --- numerics annex. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1. --- 29 Sep 96 SAIC Incorporated reviewer comments. --- 02 Jun 98 EDS Replace "_i" with "_One". ---! - -with Ada.Numerics.Generic_Complex_Types; -with Ada.Numerics.Generic_Complex_Elementary_Functions; -with Report; - -procedure CXG1004 is -begin - - Report.Test ("CXG1004", "Check that the specified exceptions are " & - "raised by the subprograms defined in package " & - "Ada.Numerics.Generic_Complex_Elementary_" & - "Functions given the prescribed input " & - "parameter values"); - - Test_Block: - declare - - type Real_Type is new Float; - - TC_Overflows : Boolean := Real_Type'Machine_Overflows; - - package Complex_Pack is - new Ada.Numerics.Generic_Complex_Types(Real_Type); - - package CEF is - new Ada.Numerics.Generic_Complex_Elementary_Functions(Complex_Pack); - - use Ada.Numerics, Complex_Pack, CEF; - - Complex_Zero : constant Complex := Compose_From_Cartesian(0.0, 0.0); - Plus_One : constant Complex := Compose_From_Cartesian(1.0, 0.0); - Minus_One : constant Complex := Compose_From_Cartesian(-1.0, 0.0); - Plus_i : constant Complex := Compose_From_Cartesian(i); - Minus_i : constant Complex := Compose_From_Cartesian(-i); - - Complex_Negative_Real : constant Complex := - Compose_From_Cartesian(-4.0, 2.0); - Complex_Negative_Imaginary : constant Complex := - Compose_From_Cartesian(3.0, -5.0); - - TC_Complex : Complex; - - - -- This procedure is used in "Exception Raising" calls below in an - -- attempt to avoid elimination of the subtest through optimization. - - procedure No_Optimize (The_Complex_Number : Complex) is - begin - Report.Comment("No Optimize: Should never be printed " & - Integer'Image(Integer(The_Complex_Number.Im))); - end No_Optimize; - - - begin - - -- Check that the exception Numerics.Argument_Error is raised by the - -- exponentiation operator when the value of the left operand is zero, - -- and the real component of the exponent (or the exponent itself) is - -- zero. - - begin - TC_Complex := "**"(Left => Complex_Zero, Right => Complex_Zero); - Report.Failed("Argument_Error not raised by exponentiation " & - "operator, left operand = complex zero, right " & - "operand = complex zero"); - No_Optimize(TC_Complex); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by exponentiation " & - "operator, left operand = complex zero, right " & - "operand = complex zero"); - end; - - begin - TC_Complex := Complex_Zero**0.0; - Report.Failed("Argument_Error not raised by exponentiation " & - "operator, left operand = complex zero, right " & - "operand = real zero"); - No_Optimize(TC_Complex); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by exponentiation " & - "operator, left operand = complex zero, right " & - "operand = real zero"); - end; - - - begin - TC_Complex := "**"(Left => 0.0, Right => Complex_Zero); - Report.Failed("Argument_Error not raised by exponentiation " & - "operator, left operand = real zero, right " & - "operand = complex zero"); - No_Optimize(TC_Complex); - exception - when Argument_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised by exponentiation " & - "operator, left operand = real zero, right " & - "operand = complex zero"); - end; - - - -- Check that the exception Constraint_Error is raised under the - -- specified circumstances, provided that - -- Complex_Types.Real'Machine_Overflows is True. - - if TC_Overflows then - - -- Raised by Log, when the value of the parameter X is zero. - begin - TC_Complex := Log (X => Complex_Zero); - Report.Failed("Constraint_Error not raised when Function " & - "Log given parameter value of complex zero"); - No_Optimize(TC_Complex); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised when Function " & - "Log given parameter value of complex zero"); - end; - - -- Raised by Cot, when the value of the parameter X is zero. - begin - TC_Complex := Cot (X => Complex_Zero); - Report.Failed("Constraint_Error not raised when Function " & - "Cot given parameter value of complex zero"); - No_Optimize(TC_Complex); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised when Function " & - "Cot given parameter value of complex zero"); - end; - - -- Raised by Coth, when the value of the parameter X is zero. - begin - TC_Complex := Coth (Complex_Zero); - Report.Failed("Constraint_Error not raised when Function " & - "Coth given parameter value of complex zero"); - No_Optimize(TC_Complex); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised when Function " & - "Coth given parameter value of complex zero"); - end; - - -- Raised by the exponentiation operator, when the value of the - -- left operand is zero and the real component of the exponent - -- is negative. - begin - TC_Complex := Complex_Zero**Complex_Negative_Real; - Report.Failed("Constraint_Error not raised when the " & - "exponentiation operator left operand is " & - "complex zero, and the real component of " & - "the exponent is negative"); - No_Optimize(TC_Complex); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised when the " & - "exponentiation operator left operand is " & - "complex zero, and the real component of " & - "the exponent is negative"); - end; - - -- Raised by the exponentiation operator, when the value of the - -- left operand is zero and the exponent itself (when it is of - -- type real) is negative. - declare - Negative_Exponent : constant Real_Type := -4.0; - begin - TC_Complex := Complex_Zero**Negative_Exponent; - Report.Failed("Constraint_Error not raised when the " & - "exponentiation operator left operand is " & - "complex zero, and the real exponent is " & - "negative"); - No_Optimize(TC_Complex); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised when the " & - "exponentiation operator left operand is " & - "complex zero, and the real exponent is " & - "negative"); - end; - - -- Raised by Arctan, when the value of the parameter is +i. - begin - TC_Complex := Arctan (Plus_i); - Report.Failed("Constraint_Error not raised when Function " & - "Arctan is given parameter value +i"); - No_Optimize(TC_Complex); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised when Function " & - "Arctan is given parameter value +i"); - end; - - -- Raised by Arctan, when the value of the parameter is -i. - begin - TC_Complex := Arctan (Minus_i); - Report.Failed("Constraint_Error not raised when Function " & - "Arctan is given parameter value -i"); - No_Optimize(TC_Complex); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised when Function " & - "Arctan is given parameter value -i"); - end; - - -- Raised by Arccot, when the value of the parameter is +i. - begin - TC_Complex := Arccot (Plus_i); - Report.Failed("Constraint_Error not raised when Function " & - "Arccot is given parameter value +i"); - No_Optimize(TC_Complex); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised when Function " & - "Arccot is given parameter value +i"); - end; - - -- Raised by Arccot, when the value of the parameter is -i. - begin - TC_Complex := Arccot (Minus_i); - Report.Failed("Constraint_Error not raised when Function " & - "Arccot is given parameter value -i"); - No_Optimize(TC_Complex); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised when Function " & - "Arccot is given parameter value -i"); - end; - - -- Raised by Arctanh, when the value of the parameter is +1. - begin - TC_Complex := Arctanh (Plus_One); - Report.Failed("Constraint_Error not raised when Function " & - "Arctanh is given parameter value +1"); - No_Optimize(TC_Complex); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised when Function " & - "Arctanh is given parameter value +1"); - end; - - -- Raised by Arctanh, when the value of the parameter is -1. - begin - TC_Complex := Arctanh (Minus_One); - Report.Failed("Constraint_Error not raised when Function " & - "Arctanh is given parameter value -1"); - No_Optimize(TC_Complex); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised when Function " & - "Arctanh is given parameter value -1"); - end; - - -- Raised by Arccoth, when the value of the parameter is +1. - begin - TC_Complex := Arccoth (Plus_One); - Report.Failed("Constraint_Error not raised when Function " & - "Arccoth is given parameter value +1"); - No_Optimize(TC_Complex); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised when Function " & - "Arccoth is given parameter value +1"); - end; - - -- Raised by Arccoth, when the value of the parameter is -1. - begin - TC_Complex := Arccoth (Minus_One); - Report.Failed("Constraint_Error not raised when Function " & - "Arccoth is given parameter value -1"); - No_Optimize(TC_Complex); - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed("Incorrect exception raised when Function " & - "Arccoth is given parameter value -1"); - end; - - else - Report.Comment - ("Attribute Complex_Pack.Real'Machine_Overflows is False; " & - "evaluation of the complex elementary functions under " & - "specified circumstances was not performed"); - end if; - - - exception - when others => - Report.Failed ("Unexpected exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXG1004; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a deleted file mode 100644 index 6faad4e1357..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a +++ /dev/null @@ -1,393 +0,0 @@ --- CXG1005.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 subprograms defined in the package --- Ada.Numerics.Generic_Complex_Elementary_Functions provide correct --- results. --- --- TEST DESCRIPTION: --- This test checks that specific subprograms defined in the generic --- package Generic_Complex_Elementary_Functions are available, and that --- they provide prescribed results given specific input values. --- The generic package Ada.Numerics.Generic_Complex_Types is instantiated --- with a real type (new Float). The resulting new package is used as --- the generic actual to package Complex_IO. --- --- SPECIAL REQUIREMENTS: --- Implementations for which Float'Signed_Zeros is True must provide --- a body for ImpDef.Annex_G.Negative_Zero which returns a negative --- zero. --- --- APPLICABILITY CRITERIA --- This test only applies to implementations that support the --- numerics annex. --- --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1. --- 21 Feb 96 SAIC Incorporated new structure for package Impdef. --- 29 Sep 96 SAIC Incorporated reviewer comments. --- ---! - -with Ada.Numerics.Generic_Complex_Types; -with Ada.Numerics.Generic_Complex_Elementary_Functions; -with ImpDef.Annex_G; -with Report; - -procedure CXG1005 is -begin - - Report.Test ("CXG1005", "Check that the subprograms defined in " & - "the package Generic_Complex_Elementary_" & - "Functions provide correct results"); - - Test_Block: - declare - - type Real_Type is new Float; - - TC_Signed_Zeros : Boolean := Real_Type'Signed_Zeros; - - package Complex_Pack is new - Ada.Numerics.Generic_Complex_Types(Real_Type); - - package CEF is - new Ada.Numerics.Generic_Complex_Elementary_Functions(Complex_Pack); - - use Ada.Numerics, Complex_Pack, CEF; - - Complex_Zero : constant Complex := Compose_From_Cartesian( 0.0, 0.0); - Plus_One : constant Complex := Compose_From_Cartesian( 1.0, 0.0); - Minus_One : constant Complex := Compose_From_Cartesian(-1.0, 0.0); - Plus_i : constant Complex := Compose_From_Cartesian(i); - Minus_i : constant Complex := Compose_From_Cartesian(-i); - - Complex_Positive_Real : constant Complex := - Compose_From_Cartesian(4.0, 2.0); - Complex_Positive_Imaginary : constant Complex := - Compose_From_Cartesian(3.0, 5.0); - Complex_Negative_Real : constant Complex := - Compose_From_Cartesian(-4.0, 2.0); - Complex_Negative_Imaginary : constant Complex := - Compose_From_Cartesian(3.0, -5.0); - - - function A_Zero_Result (Z : Complex) return Boolean is - begin - return (Re(Z) = 0.0 and Im(Z) = 0.0); - end A_Zero_Result; - - - -- In order to evaluate complex elementary functions that are - -- prescribed to return a "real" result (meaning that the imaginary - -- component is zero), the Function A_Real_Result is defined. - - function A_Real_Result (Z : Complex) return Boolean is - begin - return Im(Z) = 0.0; - end A_Real_Result; - - - -- In order to evaluate complex elementary functions that are - -- prescribed to return an "imaginary" result (meaning that the real - -- component of the complex number is zero, and the imaginary - -- component is non-zero), the Function An_Imaginary_Result is defined. - - function An_Imaginary_Result (Z : Complex) return Boolean is - begin - return (Re(Z) = 0.0 and Im(Z) /= 0.0); - end An_Imaginary_Result; - - - begin - - -- Check that when the input parameter value is zero, the following - -- functions yield a zero result. - - if not A_Zero_Result( Sqrt(Complex_Zero) ) then - Report.Failed("Non-zero result from Function Sqrt with zero input"); - end if; - - if not A_Zero_Result( Sin(Complex_Zero) ) then - Report.Failed("Non-zero result from Function Sin with zero input"); - end if; - - if not A_Zero_Result( Arcsin(Complex_Zero) ) then - Report.Failed("Non-zero result from Function Arcsin with zero " & - "input"); - end if; - - if not A_Zero_Result( Tan(Complex_Zero) ) then - Report.Failed("Non-zero result from Function Tan with zero input"); - end if; - - if not A_Zero_Result( Arctan(Complex_Zero) ) then - Report.Failed("Non-zero result from Function Arctan with zero " & - "input"); - end if; - - if not A_Zero_Result( Sinh(Complex_Zero) ) then - Report.Failed("Non-zero result from Function Sinh with zero input"); - end if; - - if not A_Zero_Result( Arcsinh(Complex_Zero) ) then - Report.Failed("Non-zero result from Function Arcsinh with zero " & - "input"); - end if; - - if not A_Zero_Result( Tanh(Complex_Zero) ) then - Report.Failed("Non-zero result from Function Tanh with zero input"); - end if; - - if not A_Zero_Result( Arctanh(Complex_Zero) ) then - Report.Failed("Non-zero result from Function Arctanh with zero " & - "input"); - end if; - - - -- Check that when the input parameter value is zero, the following - -- functions yield a result of one. - - if Exp(Complex_Zero) /= Plus_One - then - Report.Failed("Non-zero result from Function Exp with zero input"); - end if; - - if Cos(Complex_Zero) /= Plus_One - then - Report.Failed("Non-zero result from Function Cos with zero input"); - end if; - - if Cosh(Complex_Zero) /= Plus_One - then - Report.Failed("Non-zero result from Function Cosh with zero input"); - end if; - - - -- Check that when the input parameter value is zero, the following - -- functions yield a real result. - - if not A_Real_Result( Arccos(Complex_Zero) ) then - Report.Failed("Non-real result from Function Arccos with zero input"); - end if; - - if not A_Real_Result( Arccot(Complex_Zero) ) then - Report.Failed("Non-real result from Function Arccot with zero input"); - end if; - - - -- Check that when the input parameter value is zero, the following - -- functions yield an imaginary result. - - if not An_Imaginary_Result( Arccoth(Complex_Zero) ) then - Report.Failed("Non-imaginary result from Function Arccoth with " & - "zero input"); - end if; - - - -- Check that when the input parameter value is one, the Sqrt function - -- yields a result of one. - - if Sqrt(Plus_One) /= Plus_One then - Report.Failed("Incorrect result from Function Sqrt with input " & - "value of one"); - end if; - - - -- Check that when the input parameter value is one, the following - -- functions yield a result of zero. - - if not A_Zero_Result( Log(Plus_One) ) then - Report.Failed("Non-zero result from Function Log with input " & - "value of one"); - end if; - - if not A_Zero_Result( Arccos(Plus_One) ) then - Report.Failed("Non-zero result from Function Arccos with input " & - "value of one"); - end if; - - if not A_Zero_Result( Arccosh(Plus_One) ) then - Report.Failed("Non-zero result from Function Arccosh with input " & - "value of one"); - end if; - - - -- Check that when the input parameter value is one, the Arcsin - -- function yields a real result. - - if not A_Real_Result( Arcsin(Plus_One) ) then - Report.Failed("Non-real result from Function Arcsin with input " & - "value of one"); - end if; - - - -- Check that when the input parameter value is minus one, the Sqrt - -- function yields a result of "i", when the sign of the imaginary - -- component of the input parameter is positive (and yields "-i", if - -- the sign on the imaginary component is negative), and the - -- Complex_Types.Real'Signed_Zeros attribute is True. - - if TC_Signed_Zeros then - - declare - Minus_One_With_Pos_Zero_Im_Component : Complex := - Compose_From_Cartesian(-1.0, +0.0); - Minus_One_With_Neg_Zero_Im_Component : Complex := - Compose_From_Cartesian - (-1.0, Real_Type(ImpDef.Annex_G.Negative_Zero)); - begin - - if Sqrt(Minus_One_With_Pos_Zero_Im_Component) /= Plus_i then - Report.Failed("Incorrect result from Function Sqrt, when " & - "input value is minus one with a positive " & - "imaginary component, Signed_Zeros being True"); - end if; - - if Sqrt(Minus_One_With_Neg_Zero_Im_Component) /= Minus_i then - Report.Failed("Incorrect result from Function Sqrt, when " & - "input value is minus one with a negative " & - "imaginary component, Signed_Zeros being True"); - end if; - end; - - else -- Signed_Zeros is False. - - -- Check that when the input parameter value is minus one, the Sqrt - -- function yields a result of "i", when the - -- Complex_Types.Real'Signed_Zeros attribute is False. - - if Sqrt(Minus_One) /= Plus_i then - Report.Failed("Incorrect result from Function Sqrt, when " & - "input value is minus one, Signed_Zeros being " & - "False"); - end if; - - end if; - - - -- Check that when the input parameter value is minus one, the Log - -- function yields an imaginary result. - - if not An_Imaginary_Result( Log(Minus_One) ) then - Report.Failed("Non-imaginary result from Function Log with a " & - "minus one input value"); - end if; - - -- Check that when the input parameter is minus one, the following - -- functions yield a real result. - - if not A_Real_Result( Arcsin(Minus_One) ) then - Report.Failed("Non-real result from Function Arcsin with a " & - "minus one input value"); - end if; - - if not A_Real_Result( Arccos(Minus_One) ) then - Report.Failed("Non-real result from Function Arccos with a " & - "minus one input value"); - end if; - - - -- Check that when the input parameter has a value of +i or -i, the - -- Log function yields an imaginary result. - - if not An_Imaginary_Result( Log(Plus_i) ) then - Report.Failed("Non-imaginary result from Function Log with an " & - "input value of ""+i"""); - end if; - - if not An_Imaginary_Result( Log(Minus_i) ) then - Report.Failed("Non-imaginary result from Function Log with an " & - "input value of ""-i"""); - end if; - - - -- Check that exponentiation by a zero exponent yields the value one. - - if "**"(Left => Compose_From_Cartesian(5.0, 3.0), - Right => Complex_Zero) /= Plus_One or - Complex_Negative_Real**0.0 /= Plus_One or - 15.0**Complex_Zero /= Plus_One - then - Report.Failed("Incorrect result from exponentiation with a zero " & - "exponent"); - end if; - - - -- Check that exponentiation by a unit exponent yields the value of - -- the left operand (as a complex value). - -- Note: a "unit exponent" is considered the complex number (1.0, 0.0) - - if "**"(Complex_Negative_Real, Plus_One) /= - Complex_Negative_Real or - Complex_Negative_Imaginary**Plus_One /= - Complex_Negative_Imaginary or - 4.0**Plus_One /= - Compose_From_Cartesian(4.0, 0.0) - then - Report.Failed("Incorrect result from exponentiation with a unit " & - "exponent"); - end if; - - - -- Check that exponentiation of the value one yields the value one. - - if "**"(Plus_One, Complex_Negative_Imaginary) /= Plus_One or - Plus_One**9.0 /= Plus_One or - 1.0**Complex_Negative_Real /= Plus_One - then - Report.Failed("Incorrect result from exponentiation of the value " & - "One"); - end if; - - - -- Check that exponentiation of the value zero yields the value zero. - begin - if not A_Zero_Result("**"(Complex_Zero, - Complex_Positive_Imaginary)) or - not A_Zero_Result(Complex_Zero**4.0) or - not A_Zero_Result(0.0**Complex_Positive_Real) - then - Report.Failed("Incorrect result from exponentiation of the " & - "value zero"); - end if; - exception - when others => - Report.Failed("Exception raised during the exponentiation of " & - "the complex value zero"); - end; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CXG1005; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a deleted file mode 100644 index 0d7afa46091..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a +++ /dev/null @@ -1,322 +0,0 @@ --- CXG2001.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 floating point attributes Model_Mantissa, --- Machine_Mantissa, Machine_Radix, and Machine_Rounds --- are properly reported. --- --- TEST DESCRIPTION: --- This test uses a generic package to compute and check the --- values of the Machine_ attributes listed above. The --- generic package is instantiated with the standard FLOAT --- type and a floating point type for the maximum number --- of digits of precision. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- --- --- CHANGE HISTORY: --- 26 JAN 96 SAIC Initial Release for 2.1 --- ---! - --- References: --- --- "Algorithms To Reveal Properties of Floating-Point Arithmetic" --- Michael A. Malcolm; CACM November 1972; pgs 949-951. --- --- Software Manual for Elementary Functions; W. J. Cody and W. Waite; --- Prentice-Hall; 1980 ------------------------------------------------------------------------ --- --- This test relies upon the fact that --- (A+2.0)-A is not necessarily 2.0. If A is large enough then adding --- a small value to A does not change the value of A. Consider the case --- where we have a decimal based floating point representation with 4 --- digits of precision. A floating point number would logically be --- represented as "DDDD * 10 ** exp" where D is a value in the range 0..9. --- The first loop of the test starts A at 2.0 and doubles it until --- ((A+1.0)-A)-1.0 is no longer zero. For our decimal floating point --- number this will be 1638 * 10**1 (the value 16384 rounded or truncated --- to fit in 4 digits). --- The second loop starts B at 2.0 and keeps doubling B until (A+B)-A is --- no longer 0. This will keep looping until B is 8.0 because that is --- the first value where rounding (assuming our machine rounds and addition --- employs a guard digit) will change the upper 4 digits of the result: --- 1638_ --- + 8 --- ------- --- 1639_ --- Without rounding the second loop will continue until --- B is 16: --- 1638_ --- + 16 --- ------- --- 1639_ --- --- The radix is then determined by (A+B)-A which will give 10. --- --- The use of Tmp and ITmp in the test is to force values to be --- stored into memory in the event that register precision is greater --- than the stored precision of the floating point values. --- --- --- The test for rounding is (ignoring the temporary variables used to --- get the stored precision) is --- Rounds := A + Radix/2.0 - A /= 0.0 ; --- where A is the value determined in the first step that is the smallest --- power of 2 such that A + 1.0 = A. This means that the true value of --- A has one more digit in its value than 'Machine_Mantissa. --- This check will detect the case where a value is always rounded. --- There is an additional case where values are rounded to the nearest --- even value. That is referred to as IEEE style rounding in the test. --- ------------------------------------------------------------------------ - -with System; -with Report; -with Ada.Numerics.Generic_Elementary_Functions; -procedure CXG2001 is - Verbose : constant Boolean := False; - - -- if one of the attribute computation loops exceeds Max_Iterations - -- it is most likely due to the compiler reordering an expression - -- that should not be reordered. - Illegal_Optimization : exception; - Max_Iterations : constant := 10_000; - - generic - type Real is digits <>; - package Chk_Attrs is - procedure Do_Test; - end Chk_Attrs; - - package body Chk_Attrs is - package EF is new Ada.Numerics.Generic_Elementary_Functions (Real); - function Log (X : Real) return Real renames EF.Log; - - - -- names used in paper - Radix : Integer; -- Beta - Mantissa_Digits : Integer; -- t - Rounds : Boolean; -- RND - - -- made global to Determine_Attributes to help thwart optimization - A, B : Real := 2.0; - Tmp, Tmpa, Tmp1 : Real; - ITmp : Integer; - Half_Radix : Real; - - -- special constants - not declared as constants so that - -- the "stored" precision will be used instead of a "register" - -- precision. - Zero : Real := 0.0; - One : Real := 1.0; - Two : Real := 2.0; - - - procedure Thwart_Optimization is - -- the purpose of this procedure is to reference the - -- global variables used by Determine_Attributes so - -- that the compiler is not likely to keep them in - -- a higher precision register for their entire lifetime. - begin - if Report.Ident_Bool (False) then - -- never executed - A := A + 5.0; - B := B + 6.0; - Tmp := Tmp + 1.0; - Tmp1 := Tmp1 + 2.0; - Tmpa := Tmpa + 2.0; - One := 12.34; Two := 56.78; Zero := 90.12; - end if; - end Thwart_Optimization; - - - -- determines values for Radix, Mantissa_Digits, and Rounds - -- This is mostly a straight translation of the C code. - -- The only significant addition is the iteration count - -- to prevent endless looping if things are really screwed up. - procedure Determine_Attributes is - Iterations : Integer; - begin - Rounds := True; - - Iterations := 0; - Tmp := Real'Machine (((A + One) - A) - One); - while Tmp = Zero loop - A := Real'Machine(A + A); - Tmp := Real'Machine(A + One); - Tmp1 := Real'Machine(Tmp - A); - Tmp := Real'Machine(Tmp1 - One); - - Iterations := Iterations + 1; - if Iterations > Max_Iterations then - raise Illegal_Optimization; - end if; - end loop; - - Iterations := 0; - Tmp := Real'Machine(A + B); - ITmp := Integer (Tmp - A); - while ITmp = 0 loop - B := Real'Machine(B + B); - Tmp := Real'Machine(A + B); - ITmp := Integer (Tmp - A); - - Iterations := Iterations + 1; - if Iterations > Max_Iterations then - raise Illegal_Optimization; - end if; - end loop; - - Radix := ITmp; - - Mantissa_Digits := 0; - B := 1.0; - Tmp := Real'Machine(((B + One) - B) - One); - Iterations := 0; - while (Tmp = Zero) loop - Mantissa_Digits := Mantissa_Digits + 1; - B := B * Real (Radix); - Tmp := Real'Machine(B + One); - Tmp1 := Real'Machine(Tmp - B); - Tmp := Real'Machine(Tmp1 - One); - - Iterations := Iterations + 1; - if Iterations > Max_Iterations then - raise Illegal_Optimization; - end if; - end loop; - - Rounds := False; - Half_Radix := Real (Radix) / Two; - Tmp := Real'Machine(A + Half_Radix); - Tmp1 := Real'Machine(Tmp - A); - if (Tmp1 /= Zero) then - Rounds := True; - end if; - Tmpa := Real'Machine(A + Real (Radix)); - Tmp := Real'Machine(Tmpa + Half_Radix); - if not Rounds and (Tmp - TmpA /= Zero) then - Rounds := True; - if Verbose then - Report.Comment ("IEEE style rounding"); - end if; - end if; - - exception - when others => - Thwart_Optimization; - raise; - end Determine_Attributes; - - - procedure Do_Test is - Show_Results : Boolean := Verbose; - Min_Mantissa_Digits : Integer; - begin - -- compute the actual Machine_* attribute values - Determine_Attributes; - - if Real'Machine_Radix /= Radix then - Report.Failed ("'Machine_Radix incorrectly reports" & - Integer'Image (Real'Machine_Radix)); - Show_Results := True; - end if; - - if Real'Machine_Mantissa /= Mantissa_Digits then - Report.Failed ("'Machine_Mantissa incorrectly reports" & - Integer'Image (Real'Machine_Mantissa)); - Show_Results := True; - end if; - - if Real'Machine_Rounds /= Rounds then - Report.Failed ("'Machine_Rounds incorrectly reports " & - Boolean'Image (Real'Machine_Rounds)); - Show_Results := True; - end if; - - if Show_Results then - Report.Comment ("computed Machine_Mantissa is" & - Integer'Image (Mantissa_Digits)); - Report.Comment ("computed Radix is" & - Integer'Image (Radix)); - Report.Comment ("computed Rounds is " & - Boolean'Image (Rounds)); - end if; - - -- check the model attributes against the machine attributes - -- G.2.2(3)/3;6.0 - if Real'Model_Mantissa > Real'Machine_Mantissa then - Report.Failed ("model mantissa > machine mantissa"); - end if; - - -- G.2.2(3)/2;6.0 - -- 'Model_Mantissa >= ceiling(d*log(10)/log(radix))+1 - Min_Mantissa_Digits := - Integer ( - Real'Ceiling ( - Real(Real'Digits) * Log(10.0) / Log(Real(Real'Machine_Radix)) - ) ) + 1; - if Real'Model_Mantissa < Min_Mantissa_Digits then - Report.Failed ("Model_Mantissa [" & - Integer'Image (Real'Model_Mantissa) & - "] < minimum mantissa digits [" & - Integer'Image (Min_Mantissa_Digits) & - "]"); - end if; - - exception - when Illegal_Optimization => - Report.Failed ("illegal optimization of" & - " floating point expression"); - end Do_Test; - end Chk_Attrs; - - package Chk_Float is new Chk_Attrs (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package Chk_A_Long_Float is new Chk_Attrs (A_Long_Float); -begin - Report.Test ("CXG2001", - "Check the attributes Model_Mantissa," & - " Machine_Mantissa, Machine_Radix," & - " and Machine_Rounds"); - - Report.Comment ("checking Standard.Float"); - Chk_Float.Do_Test; - - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - Chk_A_Long_Float.Do_Test; - - Report.Result; -end CXG2001; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a deleted file mode 100644 index 6a1f322e8bf..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a +++ /dev/null @@ -1,468 +0,0 @@ --- CXG2002.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 complex "abs" or modulus function returns --- results that are within the error bound allowed. --- --- TEST DESCRIPTION: --- This test uses a generic package to compute and check the --- values of the modulus function. In addition, a non-generic --- copy of this package is used to check the non-generic package --- Ada.Numerics.Complex_Types. --- Of special interest is the case where either the real or --- the imaginary part of the argument is very large while the --- other part is very small or 0. --- We want to check that the value is computed such that --- an overflow does not occur. If computed directly from the --- definition --- abs (x+yi) = sqrt(x**2 + y**2) --- then overflow or underflow is much more likely than if the --- argument is normalized first. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 31 JAN 96 SAIC Initial release for 2.1 --- 02 JUN 98 EDS Add parens to intermediate calculations. ---! - --- --- Reference: --- Problems and Methodologies in Mathematical Software Production; --- editors: P. C. Messina and A Murli; --- Lecture Notes in Computer Science --- Volume 142 --- Springer Verlag 1982 --- - -with System; -with Report; -with Ada.Numerics.Generic_Complex_Types; -with Ada.Numerics.Complex_Types; -procedure CXG2002 is - Verbose : constant Boolean := False; - Maximum_Relative_Error : constant := 3.0; - - generic - type Real is digits <>; - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Complex_Types is new - Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Types; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real := Maximum_Relative_Error) is - Rel_Error, - Abs_Error, - Max_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * (abs Expected * Real'Model_Epsilon); - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual - Expected) > Max_Error then - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & - Real'Image (Expected - Actual) & - " max_err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Do_Test is - Z : Complex; - X : Real; - T : Real; - begin - - --- test 1 --- - begin - T := Real'Safe_Last; - Z := T + 0.0*i; - X := abs Z; - Check (X, T, "test 1 -- abs(bigreal + 0i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 1"); - when others => - Report.Failed ("exception in test 1"); - end; - - --- test 2 --- - begin - T := Real'Safe_Last; - Z := 0.0 + T*i; - X := Modulus (Z); - Check (X, T, "test 2 -- abs(0 + bigreal*i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 2"); - when others => - Report.Failed ("exception in test 2"); - end; - - --- test 3 --- - begin - Z := 3.0 + 4.0*i; - X := abs Z; - Check (X, 5.0 , "test 3 -- abs(3 + 4*i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 3"); - when others => - Report.Failed ("exception in test 3"); - end; - - --- test 4 --- - declare - S : Real; - begin - S := Real(Real'Machine_Radix) ** (Real'Machine_EMax - 3); - Z := 3.0 * S + 4.0*S*i; - X := abs Z; - Check (X, 5.0*S, "test 4 -- abs(3S + 4S*i) for large S", - 5.0*Real'Model_Epsilon); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 4"); - when others => - Report.Failed ("exception in test 4"); - end; - - --- test 5 --- - begin - T := Real'Model_Small; - Z := T + 0.0*i; - X := abs Z; - Check (X, T , "test 5 -- abs(small + 0*i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 5"); - when others => - Report.Failed ("exception in test 5"); - end; - - --- test 6 --- - begin - T := Real'Model_Small; - Z := 0.0 + T*i; - X := abs Z; - Check (X, T , "test 6 -- abs(0 + small*i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 6"); - when others => - Report.Failed ("exception in test 6"); - end; - - --- test 7 --- - declare - S : Real; - begin - S := Real(Real'Machine_Radix) ** (Real'Model_EMin + 3); - Z := 3.0 * S + 4.0*S*i; - X := abs Z; - Check (X, 5.0*S, "test 7 -- abs(3S + 4S*i) for small S", - 5.0*Real'Model_Epsilon); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 7"); - when others => - Report.Failed ("exception in test 7"); - end; - - --- test 8 --- - declare - -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 - Sqrt2 : constant := - 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; - begin - Z := 1.0 + 1.0*i; - X := abs Z; - Check (X, Sqrt2 , "test 8 -- abs(1 + 1*i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 8"); - when others => - Report.Failed ("exception in test 8"); - end; - - --- test 9 --- - begin - T := 0.0; - Z := T + 0.0*i; - X := abs Z; - Check (X, T , "test 5 -- abs(0 + 0*i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 9"); - when others => - Report.Failed ("exception in test 9"); - end; - end Do_Test; - end Generic_Check; - - ----------------------------------------------------------------------- - --- non generic copy of the above generic package - ----------------------------------------------------------------------- - - package Non_Generic_Check is - subtype Real is Float; - procedure Do_Test; - end Non_Generic_Check; - - package body Non_Generic_Check is - use Ada.Numerics.Complex_Types; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real := Maximum_Relative_Error) is - Rel_Error, - Abs_Error, - Max_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * (abs Expected * Real'Model_Epsilon); - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual - Expected) > Max_Error then - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & - Real'Image (Expected - Actual) & - " max_err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Do_Test is - Z : Complex; - X : Real; - T : Real; - begin - - --- test 1 --- - begin - T := Real'Safe_Last; - Z := T + 0.0*i; - X := abs Z; - Check (X, T, "test 1 -- abs(bigreal + 0i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 1"); - when others => - Report.Failed ("exception in test 1"); - end; - - --- test 2 --- - begin - T := Real'Safe_Last; - Z := 0.0 + T*i; - X := Modulus (Z); - Check (X, T, "test 2 -- abs(0 + bigreal*i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 2"); - when others => - Report.Failed ("exception in test 2"); - end; - - --- test 3 --- - begin - Z := 3.0 + 4.0*i; - X := abs Z; - Check (X, 5.0 , "test 3 -- abs(3 + 4*i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 3"); - when others => - Report.Failed ("exception in test 3"); - end; - - --- test 4 --- - declare - S : Real; - begin - S := Real(Real'Machine_Radix) ** (Real'Machine_EMax - 3); - Z := 3.0 * S + 4.0*S*i; - X := abs Z; - Check (X, 5.0*S, "test 4 -- abs(3S + 4S*i) for large S", - 5.0*Real'Model_Epsilon); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 4"); - when others => - Report.Failed ("exception in test 4"); - end; - - --- test 5 --- - begin - T := Real'Model_Small; - Z := T + 0.0*i; - X := abs Z; - Check (X, T , "test 5 -- abs(small + 0*i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 5"); - when others => - Report.Failed ("exception in test 5"); - end; - - --- test 6 --- - begin - T := Real'Model_Small; - Z := 0.0 + T*i; - X := abs Z; - Check (X, T , "test 6 -- abs(0 + small*i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 6"); - when others => - Report.Failed ("exception in test 6"); - end; - - --- test 7 --- - declare - S : Real; - begin - S := Real(Real'Machine_Radix) ** (Real'Model_EMin + 3); - Z := 3.0 * S + 4.0*S*i; - X := abs Z; - Check (X, 5.0*S, "test 7 -- abs(3S + 4S*i) for small S", - 5.0*Real'Model_Epsilon); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 7"); - when others => - Report.Failed ("exception in test 7"); - end; - - --- test 8 --- - declare - -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 - Sqrt2 : constant := - 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; - begin - Z := 1.0 + 1.0*i; - X := abs Z; - Check (X, Sqrt2 , "test 8 -- abs(1 + 1*i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 8"); - when others => - Report.Failed ("exception in test 8"); - end; - - --- test 9 --- - begin - T := 0.0; - Z := T + 0.0*i; - X := abs Z; - Check (X, T , "test 5 -- abs(0 + 0*i)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 9"); - when others => - Report.Failed ("exception in test 9"); - end; - end Do_Test; - end Non_Generic_Check; - - ----------------------------------------------------------------------- - --- end of "manual instantiation" - ----------------------------------------------------------------------- - package Chk_Float is new Generic_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package Chk_A_Long_Float is new Generic_Check (A_Long_Float); -begin - Report.Test ("CXG2002", - "Check the accuracy of the complex modulus" & - " function"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - Chk_Float.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - Chk_A_Long_Float.Do_Test; - - if Verbose then - Report.Comment ("checking non-generic package"); - end if; - Non_Generic_Check.Do_Test; - Report.Result; -end CXG2002; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a deleted file mode 100644 index d1a225a50a1..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a +++ /dev/null @@ -1,701 +0,0 @@ --- CXG2003.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 sqrt function returns --- results that are within the error bound allowed. --- --- TEST DESCRIPTION: --- This test contains three test packages that are almost --- identical. The first two packages differ only in the --- floating point type that is being tested. The first --- and third package differ only in whether the generic --- elementary functions package or the pre-instantiated --- package is used. --- The test package is not generic so that the arguments --- and expected results for some of the test values --- can be expressed as universal real instead of being --- computed at runtime. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 2 FEB 96 SAIC Initial release for 2.1 --- 18 AUG 96 SAIC Made Check consistent with other tests. --- ---! - -with System; -with Report; -with Ada.Numerics.Generic_Elementary_Functions; -with Ada.Numerics.Elementary_Functions; -procedure CXG2003 is - Verbose : constant Boolean := False; - - package Float_Check is - subtype Real is Float; - procedure Do_Test; - end Float_Check; - - package body Float_Check is - package Elementary_Functions is new - Ada.Numerics.Generic_Elementary_Functions (Real); - function Sqrt (X : Real) return Real renames - Elementary_Functions.Sqrt; - function Log (X : Real) return Real renames - Elementary_Functions.Log; - function Exp (X : Real) return Real renames - Elementary_Functions.Exp; - - -- The default Maximum Relative Error is the value specified - -- in the LRM. - Default_MRE : constant Real := 2.0; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real := Default_MRE) is - Rel_Error : Real; - Abs_Error : Real; - Max_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual - Expected) > Max_Error then - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & - Real'Image (Actual - Expected) & - " mre:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Argument_Range_Check (A, B : Real; - Test : String) is - -- test a logarithmically distributed selection of - -- arguments selected from the range A to B. - X : Real; - Expected : Real; - Y : Real; - C : Real := Log(B/A); - Max_Samples : constant := 1000; - - begin - for I in 1..Max_Samples loop - Expected := A * Exp(C * Real (I) / Real (Max_Samples)); - X := Expected * Expected; - Y := Sqrt (X); - - -- note that since the expected value is computed, we - -- must take the error in that computation into account. - Check (Y, Expected, - "test " & Test & " -" & - Integer'Image (I) & - " of argument range", - 3.0); - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in argument range check"); - when others => - Report.Failed ("exception in argument range check"); - end Argument_Range_Check; - - procedure Do_Test is - begin - - --- test 1 --- - declare - T : constant := (Real'Machine_EMax - 1) / 2; - X : constant := (1.0 * Real'Machine_Radix) ** (2 * T); - Expected : constant := (1.0 * Real'Machine_Radix) ** T; - Y : Real; - begin - Y := Sqrt (X); - Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 1"); - when others => - Report.Failed ("exception in test 1"); - end; - - --- test 2 --- - declare - T : constant := (Real'Model_EMin + 1) / 2; - X : constant := (1.0 * Real'Machine_Radix) ** (2 * T); - Expected : constant := (1.0 * Real'Machine_Radix) ** T; - Y : Real; - begin - Y := Sqrt (X); - Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 2"); - when others => - Report.Failed ("exception in test 2"); - end; - - --- test 3 --- - declare - X : constant := 1.0; - Expected : constant := 1.0; - Y : Real; - begin - Y := Sqrt(X); - Check (Y, Expected, "test 3 -- sqrt(1.0)", - 0.0); -- no error allowed - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 3"); - when others => - Report.Failed ("exception in test 3"); - end; - - --- test 4 --- - declare - X : constant := 0.0; - Expected : constant := 0.0; - Y : Real; - begin - Y := Sqrt(X); - Check (Y, Expected, "test 4 -- sqrt(0.0)", - 0.0); -- no error allowed - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 4"); - when others => - Report.Failed ("exception in test 4"); - end; - - --- test 5 --- - declare - X : constant := -1.0; - Y : Real; - begin - Y := Sqrt(X); - -- the following code should not be executed. - -- The call to Check is to keep the call to Sqrt from - -- appearing to be dead code. - Check (Y, -1.0, "test 5 -- sqrt(-1)" ); - Report.Failed ("test 5 - argument_error expected"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 5"); - when Ada.Numerics.Argument_Error => - if Verbose then - Report.Comment ("test 5 correctly got argument_error"); - end if; - when others => - Report.Failed ("exception in test 5"); - end; - - --- test 6 --- - declare - X : constant := Ada.Numerics.Pi ** 2; - Expected : constant := Ada.Numerics.Pi; - Y : Real; - begin - Y := Sqrt (X); - Check (Y, Expected, "test 6 -- sqrt(pi**2)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 6"); - when others => - Report.Failed ("exception in test 6"); - end; - - --- test 7 & 8 --- - Argument_Range_Check (1.0/Sqrt(Real(Real'Machine_Radix)), - 1.0, - "7"); - Argument_Range_Check (1.0, - Sqrt(Real(Real'Machine_Radix)), - "8"); - end Do_Test; - end Float_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - - - package A_Long_Float_Check is - subtype Real is A_Long_Float; - procedure Do_Test; - end A_Long_Float_Check; - - package body A_Long_Float_Check is - package Elementary_Functions is new - Ada.Numerics.Generic_Elementary_Functions (Real); - function Sqrt (X : Real) return Real renames - Elementary_Functions.Sqrt; - function Log (X : Real) return Real renames - Elementary_Functions.Log; - function Exp (X : Real) return Real renames - Elementary_Functions.Exp; - - -- The default Maximum Relative Error is the value specified - -- in the LRM. - Default_MRE : constant Real := 2.0; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real := Default_MRE) is - Rel_Error : Real; - Abs_Error : Real; - Max_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual - Expected) > Max_Error then - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & - Real'Image (Actual - Expected) & - " mre:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Argument_Range_Check (A, B : Real; - Test : String) is - -- test a logarithmically distributed selection of - -- arguments selected from the range A to B. - X : Real; - Expected : Real; - Y : Real; - C : Real := Log(B/A); - Max_Samples : constant := 1000; - - begin - for I in 1..Max_Samples loop - Expected := A * Exp(C * Real (I) / Real (Max_Samples)); - X := Expected * Expected; - Y := Sqrt (X); - - -- note that since the expected value is computed, we - -- must take the error in that computation into account. - Check (Y, Expected, - "test " & Test & " -" & - Integer'Image (I) & - " of argument range", - 3.0); - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in argument range check"); - when others => - Report.Failed ("exception in argument range check"); - end Argument_Range_Check; - - - procedure Do_Test is - begin - - --- test 1 --- - declare - T : constant := (Real'Machine_EMax - 1) / 2; - X : constant := (1.0 * Real'Machine_Radix) ** (2 * T); - Expected : constant := (1.0 * Real'Machine_Radix) ** T; - Y : Real; - begin - Y := Sqrt (X); - Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 1"); - when others => - Report.Failed ("exception in test 1"); - end; - - --- test 2 --- - declare - T : constant := (Real'Model_EMin + 1) / 2; - X : constant := (1.0 * Real'Machine_Radix) ** (2 * T); - Expected : constant := (1.0 * Real'Machine_Radix) ** T; - Y : Real; - begin - Y := Sqrt (X); - Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 2"); - when others => - Report.Failed ("exception in test 2"); - end; - - --- test 3 --- - declare - X : constant := 1.0; - Expected : constant := 1.0; - Y : Real; - begin - Y := Sqrt(X); - Check (Y, Expected, "test 3 -- sqrt(1.0)", - 0.0); -- no error allowed - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 3"); - when others => - Report.Failed ("exception in test 3"); - end; - - --- test 4 --- - declare - X : constant := 0.0; - Expected : constant := 0.0; - Y : Real; - begin - Y := Sqrt(X); - Check (Y, Expected, "test 4 -- sqrt(0.0)", - 0.0); -- no error allowed - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 4"); - when others => - Report.Failed ("exception in test 4"); - end; - - --- test 5 --- - declare - X : constant := -1.0; - Y : Real; - begin - Y := Sqrt(X); - -- the following code should not be executed. - -- The call to Check is to keep the call to Sqrt from - -- appearing to be dead code. - Check (Y, -1.0, "test 5 -- sqrt(-1)" ); - Report.Failed ("test 5 - argument_error expected"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 5"); - when Ada.Numerics.Argument_Error => - if Verbose then - Report.Comment ("test 5 correctly got argument_error"); - end if; - when others => - Report.Failed ("exception in test 5"); - end; - - --- test 6 --- - declare - X : constant := Ada.Numerics.Pi ** 2; - Expected : constant := Ada.Numerics.Pi; - Y : Real; - begin - Y := Sqrt (X); - Check (Y, Expected, "test 6 -- sqrt(pi**2)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 6"); - when others => - Report.Failed ("exception in test 6"); - end; - - --- test 7 & 8 --- - Argument_Range_Check (1.0/Sqrt(Real(Real'Machine_Radix)), - 1.0, - "7"); - Argument_Range_Check (1.0, - Sqrt(Real(Real'Machine_Radix)), - "8"); - end Do_Test; - end A_Long_Float_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - package Non_Generic_Check is - procedure Do_Test; - end Non_Generic_Check; - - package body Non_Generic_Check is - package EF renames - Ada.Numerics.Elementary_Functions; - subtype Real is Float; - - -- The default Maximum Relative Error is the value specified - -- in the LRM. - Default_MRE : constant Real := 2.0; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real := Default_MRE) is - Rel_Error : Real; - Abs_Error : Real; - Max_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual - Expected) > Max_Error then - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & - Real'Image (Actual - Expected) & - " mre:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - - procedure Argument_Range_Check (A, B : Float; - Test : String) is - -- test a logarithmically distributed selection of - -- arguments selected from the range A to B. - X : Float; - Expected : Float; - Y : Float; - C : Float := EF.Log(B/A); - Max_Samples : constant := 1000; - - begin - for I in 1..Max_Samples loop - Expected := A * EF.Exp(C * Float (I) / Float (Max_Samples)); - X := Expected * Expected; - Y := EF.Sqrt (X); - - -- note that since the expected value is computed, we - -- must take the error in that computation into account. - Check (Y, Expected, - "test " & Test & " -" & - Integer'Image (I) & - " of argument range", - 3.0); - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in argument range check"); - when others => - Report.Failed ("exception in argument range check"); - end Argument_Range_Check; - - - procedure Do_Test is - begin - - --- test 1 --- - declare - T : constant := (Float'Machine_EMax - 1) / 2; - X : constant := (1.0 * Float'Machine_Radix) ** (2 * T); - Expected : constant := (1.0 * Float'Machine_Radix) ** T; - Y : Float; - begin - Y := EF.Sqrt (X); - Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 1"); - when others => - Report.Failed ("exception in test 1"); - end; - - --- test 2 --- - declare - T : constant := (Float'Model_EMin + 1) / 2; - X : constant := (1.0 * Float'Machine_Radix) ** (2 * T); - Expected : constant := (1.0 * Float'Machine_Radix) ** T; - Y : Float; - begin - Y := EF.Sqrt (X); - Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 2"); - when others => - Report.Failed ("exception in test 2"); - end; - - --- test 3 --- - declare - X : constant := 1.0; - Expected : constant := 1.0; - Y : Float; - begin - Y := EF.Sqrt(X); - Check (Y, Expected, "test 3 -- sqrt(1.0)", - 0.0); -- no error allowed - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 3"); - when others => - Report.Failed ("exception in test 3"); - end; - - --- test 4 --- - declare - X : constant := 0.0; - Expected : constant := 0.0; - Y : Float; - begin - Y := EF.Sqrt(X); - Check (Y, Expected, "test 4 -- sqrt(0.0)", - 0.0); -- no error allowed - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 4"); - when others => - Report.Failed ("exception in test 4"); - end; - - --- test 5 --- - declare - X : constant := -1.0; - Y : Float; - begin - Y := EF.Sqrt(X); - -- the following code should not be executed. - -- The call to Check is to keep the call to Sqrt from - -- appearing to be dead code. - Check (Y, -1.0, "test 5 -- sqrt(-1)" ); - Report.Failed ("test 5 - argument_error expected"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 5"); - when Ada.Numerics.Argument_Error => - if Verbose then - Report.Comment ("test 5 correctly got argument_error"); - end if; - when others => - Report.Failed ("exception in test 5"); - end; - - --- test 6 --- - declare - X : constant := Ada.Numerics.Pi ** 2; - Expected : constant := Ada.Numerics.Pi; - Y : Float; - begin - Y := EF.Sqrt (X); - Check (Y, Expected, "test 6 -- sqrt(pi**2)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 6"); - when others => - Report.Failed ("exception in test 6"); - end; - - --- test 7 & 8 --- - Argument_Range_Check (1.0/EF.Sqrt(Float(Float'Machine_Radix)), - 1.0, - "7"); - Argument_Range_Check (1.0, - EF.Sqrt(Float(Float'Machine_Radix)), - "8"); - end Do_Test; - end Non_Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - -begin - Report.Test ("CXG2003", - "Check the accuracy of the sqrt function"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking non-generic package"); - end if; - - Non_Generic_Check.Do_Test; - - Report.Result; -end CXG2003; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a deleted file mode 100644 index 2df296d3d42..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a +++ /dev/null @@ -1,499 +0,0 @@ --- CXG2004.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 sin and cos functions return --- results that are within the error bound allowed. --- --- TEST DESCRIPTION: --- This test consists of a generic package that is --- instantiated to check both float and a long float type. --- The test for each floating point type is divided into --- the following parts: --- Special value checks where the result is a known constant. --- Checks using an identity relationship. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 13 FEB 96 SAIC Initial release for 2.1 --- 22 APR 96 SAIC Changed to generic implementation. --- 18 AUG 96 SAIC Improvements to commentary. --- 23 OCT 96 SAIC Exact results are not required unless the --- cycle is specified. --- 28 FEB 97 PWB.CTA Removed checks where cycle 2.0*Pi is specified --- 02 JUN 98 EDS Revised calculations to ensure that X is exactly --- three times Y per advice of numerics experts. --- --- CHANGE NOTE: --- According to Ken Dritz, author of the Numerics Annex of the RM, --- one should never specify the cycle 2.0*Pi for the trigonometric --- functions. In particular, if the machine number for the first --- argument is not an exact multiple of the machine number for the --- explicit cycle, then the specified exact results cannot be --- reasonably expected. The affected checks in this test have been --- marked as comments, with the additional notation "pwb-math". --- Phil Brashear ---! - --- --- References: --- --- Software Manual for the Elementary Functions --- William J. Cody, Jr. and William Waite --- Prentice-Hall, 1980 --- --- CRC Standard Mathematical Tables --- 23rd Edition --- --- Implementation and Testing of Function Software --- W. J. Cody --- Problems and Methodologies in Mathematical Software Production --- editors P. C. Messina and A. Murli --- Lecture Notes in Computer Science Volume 142 --- Springer Verlag, 1982 --- --- The sin and cos checks are translated directly from --- the netlib FORTRAN code that was written by W. Cody. --- - -with System; -with Report; -with Ada.Numerics.Generic_Elementary_Functions; -with Ada.Numerics.Elementary_Functions; -procedure CXG2004 is - Verbose : constant Boolean := False; - Number_Samples : constant := 1000; - - -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 - Sqrt2 : constant := - 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; - Sqrt3 : constant := - 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; - - Pi : constant := Ada.Numerics.Pi; - - generic - type Real is digits <>; - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Elementary_Functions is new - Ada.Numerics.Generic_Elementary_Functions (Real); - - function Sin (X : Real) return Real renames - Elementary_Functions.Sin; - function Cos (X : Real) return Real renames - Elementary_Functions.Cos; - function Sin (X, Cycle : Real) return Real renames - Elementary_Functions.Sin; - function Cos (X, Cycle : Real) return Real renames - Elementary_Functions.Cos; - - Accuracy_Error_Reported : Boolean := False; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Rel_Error, - Abs_Error, - Max_Error : Real; - begin - - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - - -- in addition to the relative error checks we apply the - -- criteria of G.2.4(16) - if abs (Actual) > 1.0 then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & " result > 1.0"); - elsif abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & - Real'Image (Actual - Expected) & - " mre:" & - Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Sin_Check (A, B : Real; - Arg_Range : String) is - -- test a selection of - -- arguments selected from the range A to B. - -- - -- This test uses the identity - -- sin(x) = sin(x/3)*(3 - 4 * sin(x/3)**2) - -- - -- Note that in this test we must take into account the - -- error in the calculation of the expected result so - -- the maximum relative error is larger than the - -- accuracy required by the ARM. - - X, Y, ZZ : Real; - Actual, Expected : Real; - MRE : Real; - Ran : Real; - begin - Accuracy_Error_Reported := False; -- reset - for I in 1 .. Number_Samples loop - -- Evenly distributed selection of arguments - Ran := Real (I) / Real (Number_Samples); - - -- make sure x and x/3 are both exactly representable - -- on the machine. See "Implementation and Testing of - -- Function Software" page 44. - X := (B - A) * Ran + A; - Y := Real'Leading_Part - ( X/3.0, - Real'Machine_Mantissa - Real'Exponent (3.0) ); - X := Y * 3.0; - - Actual := Sin (X); - - ZZ := Sin(Y); - Expected := ZZ * (3.0 - 4.0 * ZZ * ZZ); - - -- note that since the expected value is computed, we - -- must take the error in that computation into account. - -- See Cody pp 139-141. - MRE := 4.0; - - Check (Actual, Expected, - "sin test of range" & Arg_Range & - Integer'Image (I), - MRE); - exit when Accuracy_Error_Reported; - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in sin check"); - when others => - Report.Failed ("exception in sin check"); - end Sin_Check; - - - - procedure Cos_Check (A, B : Real; - Arg_Range : String) is - -- test a selection of - -- arguments selected from the range A to B. - -- - -- This test uses the identity - -- cos(x) = cos(x/3)*(4 * cos(x/3)**2 - 3) - -- - -- Note that in this test we must take into account the - -- error in the calculation of the expected result so - -- the maximum relative error is larger than the - -- accuracy required by the ARM. - - X, Y, ZZ : Real; - Actual, Expected : Real; - MRE : Real; - Ran : Real; - begin - Accuracy_Error_Reported := False; -- reset - for I in 1 .. Number_Samples loop - -- Evenly distributed selection of arguments - Ran := Real (I) / Real (Number_Samples); - - -- make sure x and x/3 are both exactly representable - -- on the machine. See "Implementation and Testing of - -- Function Software" page 44. - X := (B - A) * Ran + A; - Y := Real'Leading_Part - ( X/3.0, - Real'Machine_Mantissa - Real'Exponent (3.0) ); - X := Y * 3.0; - - Actual := Cos (X); - - ZZ := Cos(Y); - Expected := ZZ * (4.0 * ZZ * ZZ - 3.0); - - -- note that since the expected value is computed, we - -- must take the error in that computation into account. - -- See Cody pp 141-143. - MRE := 6.0; - - Check (Actual, Expected, - "cos test of range" & Arg_Range & - Integer'Image (I), - MRE); - exit when Accuracy_Error_Reported; - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in cos check"); - when others => - Report.Failed ("exception in cos check"); - end Cos_Check; - - - procedure Special_Angle_Checks is - type Data_Point is - record - Degrees, - Radians, - Sine, - Cosine : Real; - Sin_Result_Error, - Cos_Result_Error : Boolean; - end record; - - type Test_Data_Type is array (Positive range <>) of Data_Point; - - -- the values in the following table only involve static - -- expressions to minimize any loss of precision. However, - -- there are two sources of error that must be accounted for - -- in the following tests. - -- First, when a cycle is not specified there can be a roundoff - -- error in the value of Pi used. This error does not apply - -- when a cycle of 2.0 * Pi is explicitly provided. - -- Second, the expected results that involve sqrt values also - -- have a potential roundoff error. - -- The amount of error due to error in the argument is computed - -- as follows: - -- sin(x+err) = sin(x)*cos(err) + cos(x)*sin(err) - -- ~= sin(x) + err * cos(x) - -- similarly for cos the error due to error in the argument is - -- computed as follows: - -- cos(x+err) = cos(x)*cos(err) - sin(x)*sin(err) - -- ~= cos(x) - err * sin(x) - -- In both cases the term "err" is bounded by 0.5 * argument. - - Test_Data : constant Test_Data_Type := ( --- degrees radians sine cosine sin_er cos_er test # - ( 0.0, 0.0, 0.0, 1.0, False, False ), -- 1 - ( 30.0, Pi/6.0, 0.5, Sqrt3/2.0, False, True ), -- 2 - ( 60.0, Pi/3.0, Sqrt3/2.0, 0.5, True, False ), -- 3 - ( 90.0, Pi/2.0, 1.0, 0.0, False, False ), -- 4 - (120.0, 2.0*Pi/3.0, Sqrt3/2.0, -0.5, True, False ), -- 5 - (150.0, 5.0*Pi/6.0, 0.5, -Sqrt3/2.0, False, True ), -- 6 - (180.0, Pi, 0.0, -1.0, False, False ), -- 7 - (210.0, 7.0*Pi/6.0, -0.5, -Sqrt3/2.0, False, True ), -- 8 - (240.0, 8.0*Pi/6.0, -Sqrt3/2.0, -0.5, True, False ), -- 9 - (270.0, 9.0*Pi/6.0, -1.0, 0.0, False, False ), -- 10 - (300.0, 10.0*Pi/6.0, -Sqrt3/2.0, 0.5, True, False ), -- 11 - (330.0, 11.0*Pi/6.0, -0.5, Sqrt3/2.0, False, True ), -- 12 - (360.0, 2.0*Pi, 0.0, 1.0, False, False ), -- 13 - ( 45.0, Pi/4.0, Sqrt2/2.0, Sqrt2/2.0, True, True ), -- 14 - (135.0, 3.0*Pi/4.0, Sqrt2/2.0, -Sqrt2/2.0, True, True ), -- 15 - (225.0, 5.0*Pi/4.0, -Sqrt2/2.0, -Sqrt2/2.0, True, True ), -- 16 - (315.0, 7.0*Pi/4.0, -Sqrt2/2.0, Sqrt2/2.0, True, True ), -- 17 - (405.0, 9.0*Pi/4.0, Sqrt2/2.0, Sqrt2/2.0, True, True ) ); -- 18 - - - Y : Real; - Sin_Arg_Err, - Cos_Arg_Err, - Sin_Result_Err, - Cos_Result_Err : Real; - begin - for I in Test_Data'Range loop - -- compute error components - Sin_Arg_Err := abs Test_Data (I).Cosine * - abs Test_Data (I).Radians / 2.0; - Cos_Arg_Err := abs Test_Data (I).Sine * - abs Test_Data (I).Radians / 2.0; - - if Test_Data (I).Sin_Result_Error then - Sin_Result_Err := 0.5; - else - Sin_Result_Err := 0.0; - end if; - - if Test_Data (I).Cos_Result_Error then - Cos_Result_Err := 1.0; - else - Cos_Result_Err := 0.0; - end if; - - - - Y := Sin (Test_Data (I).Radians); - Check (Y, Test_Data (I).Sine, - "test" & Integer'Image (I) & " sin(r)", - 2.0 + Sin_Arg_Err + Sin_Result_Err); - Y := Cos (Test_Data (I).Radians); - Check (Y, Test_Data (I).Cosine, - "test" & Integer'Image (I) & " cos(r)", - 2.0 + Cos_Arg_Err + Cos_Result_Err); - Y := Sin (Test_Data (I).Degrees, 360.0); - Check (Y, Test_Data (I).Sine, - "test" & Integer'Image (I) & " sin(d,360)", - 2.0 + Sin_Result_Err); - Y := Cos (Test_Data (I).Degrees, 360.0); - Check (Y, Test_Data (I).Cosine, - "test" & Integer'Image (I) & " cos(d,360)", - 2.0 + Cos_Result_Err); ---pwb-math Y := Sin (Test_Data (I).Radians, 2.0*Pi); ---pwb-math Check (Y, Test_Data (I).Sine, ---pwb-math "test" & Integer'Image (I) & " sin(r,2pi)", ---pwb-math 2.0 + Sin_Result_Err); ---pwb-math Y := Cos (Test_Data (I).Radians, 2.0*Pi); ---pwb-math Check (Y, Test_Data (I).Cosine, ---pwb-math "test" & Integer'Image (I) & " cos(r,2pi)", ---pwb-math 2.0 + Cos_Result_Err); - end loop; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in special angle test"); - when others => - Report.Failed ("exception in special angle test"); - end Special_Angle_Checks; - - - -- check the rule of A.5.1(41);6.0 which requires that the - -- result be exact if the mathematical result is 0.0, 1.0, - -- or -1.0 - procedure Exact_Result_Checks is - type Data_Point is - record - Degrees, - Sine, - Cosine : Real; - end record; - - type Test_Data_Type is array (Positive range <>) of Data_Point; - Test_Data : constant Test_Data_Type := ( - -- degrees sine cosine test # - ( 0.0, 0.0, 1.0 ), -- 1 - ( 90.0, 1.0, 0.0 ), -- 2 - (180.0, 0.0, -1.0 ), -- 3 - (270.0, -1.0, 0.0 ), -- 4 - (360.0, 0.0, 1.0 ), -- 5 - ( 90.0 + 360.0, 1.0, 0.0 ), -- 6 - (180.0 + 360.0, 0.0, -1.0 ), -- 7 - (270.0 + 360.0,-1.0, 0.0 ), -- 8 - (360.0 + 360.0, 0.0, 1.0 ) ); -- 9 - - Y : Real; - begin - for I in Test_Data'Range loop - Y := Sin (Test_Data(I).Degrees, 360.0); - if Y /= Test_Data(I).Sine then - Report.Failed ("exact result for sin(" & - Real'Image (Test_Data(I).Degrees) & - ", 360.0) is not" & - Real'Image (Test_Data(I).Sine) & - " Difference is " & - Real'Image (Y - Test_Data(I).Sine) ); - end if; - - Y := Cos (Test_Data(I).Degrees, 360.0); - if Y /= Test_Data(I).Cosine then - Report.Failed ("exact result for cos(" & - Real'Image (Test_Data(I).Degrees) & - ", 360.0) is not" & - Real'Image (Test_Data(I).Cosine) & - " Difference is " & - Real'Image (Y - Test_Data(I).Cosine) ); - end if; - end loop; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in exact result check"); - when others => - Report.Failed ("exception in exact result check"); - end Exact_Result_Checks; - - - procedure Do_Test is - begin - Special_Angle_Checks; - Sin_Check (0.0, Pi/2.0, "0..pi/2"); - Sin_Check (6.0*Pi, 6.5*Pi, "6pi..6.5pi"); - Cos_Check (7.0*Pi, 7.5*Pi, "7pi..7.5pi"); - Exact_Result_Checks; - end Do_Test; - end Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - package Float_Check is new Generic_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package A_Long_Float_Check is new Generic_Check (A_Long_Float); - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - -begin - Report.Test ("CXG2004", - "Check the accuracy of the sin and cos functions"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - Report.Result; -end CXG2004; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a deleted file mode 100644 index 4054b83d88a..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a +++ /dev/null @@ -1,204 +0,0 @@ --- CXG2005.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 floating point addition and multiplication --- have the required accuracy. --- --- TEST DESCRIPTION: --- The check for the required precision is essentially a --- check that a guard digit is used for the operations. --- This test uses a generic package to check the addition --- and multiplication results. The --- generic package is instantiated with the standard FLOAT --- type and a floating point type for the maximum number --- of digits of precision. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- --- --- CHANGE HISTORY: --- 14 FEB 96 SAIC Initial Release for 2.1 --- 16 SEP 99 RLB Repaired to avoid printing thousands of (almost) --- identical failure messages. ---! - --- References: --- --- Basic Concepts for Computational Software --- W. J. Cody --- Problems and Methodologies in Mathematical Software Production --- editors P. C. Messina and A. Murli --- Lecture Notes in Computer Science Vol 142 --- Springer Verlag, 1982 --- --- Software Manual for the Elementary Functions --- William J. Cody and William Waite --- Prentice-Hall, 1980 --- - -with System; -with Report; -procedure CXG2005 is - Verbose : constant Boolean := False; - - generic - type Real is digits <>; - package Guard_Digit_Check is - procedure Do_Test; - end Guard_Digit_Check; - - package body Guard_Digit_Check is - -- made global so that the compiler will be more likely - -- to keep the values in memory instead of in higher - -- precision registers. - X, Y, Z : Real; - OneX : Real; - Eps, BN : Real; - - -- special constants - not declared as constants so that - -- the "stored" precision will be used instead of a "register" - -- precision. - Zero : Real := 0.0; - One : Real := 1.0; - Two : Real := 2.0; - - Failure_Count : Natural := 0; - - procedure Thwart_Optimization is - -- the purpose of this procedure is to reference the - -- global variables used by the test so - -- that the compiler is not likely to keep them in - -- a higher precision register for their entire lifetime. - begin - if Report.Ident_Bool (False) then - -- never executed - X := X + 5.0; - Y := Y + 6.0; - Z := Z + 1.0; - Eps := Eps + 2.0; - BN := BN + 2.0; - OneX := X + Y; - One := 12.34; Two := 56.78; Zero := 90.12; - end if; - end Thwart_Optimization; - - - procedure Addition_Test is - begin - for K in 1..10 loop - Eps := Real (K) * Real'Model_Epsilon; - for N in 1.. Real'Machine_EMax - 1 loop - BN := Real(Real'Machine_Radix) ** N; - X := (One + Eps) * BN; - Y := (One - Eps) * BN; - Z := X - Y; -- true value for Z is 2*Eps*BN - - if Z /= Eps*BN + Eps*BN then - Report.Failed ("addition check failed. K=" & - Integer'Image (K) & - " N=" & Integer'Image (N) & - " difference=" & Real'Image (Z - 2.0*Eps*BN) & - " Eps*BN=" & Real'Image (Eps*BN) ); - Failure_Count := Failure_Count + 1; - exit when Failure_Count > K*4; -- Avoid displaying dozens of messages. - end if; - end loop; - end loop; - exception - when others => - Thwart_Optimization; - Report.Failed ("unexpected exception in addition test"); - end Addition_Test; - - - procedure Multiplication_Test is - begin - X := Real (Real'Machine_Radix) ** (Real'Machine_EMax - 1); - OneX := One * X; - Thwart_Optimization; - if OneX /= X then - Report.Failed ("multiplication for large values"); - end if; - - X := Real (Real'Machine_Radix) ** (Real'Model_EMin + 1); - OneX := One * X; - Thwart_Optimization; - if OneX /= X then - Report.Failed ("multiplication for small values"); - end if; - - -- selection of "random" values between 1/radix and radix - Y := One / Real (Real'Machine_Radix); - Z := Real(Real'Machine_Radix) - One/Real(Real'Machine_Radix); - for I in 0..100 loop - X := Y + Real (I) / 100.0 * Z; - OneX := One * X; - Thwart_Optimization; - if OneX /= X then - Report.Failed ("multiplication for case" & Integer'Image (I)); - exit when Failure_Count > 40+8; -- Avoid displaying dozens of messages. - end if; - end loop; - exception - when others => - Thwart_Optimization; - Report.Failed ("unexpected exception in multiplication test"); - end Multiplication_Test; - - - procedure Do_Test is - begin - Addition_Test; - Multiplication_Test; - end Do_Test; - end Guard_Digit_Check; - - package Chk_Float is new Guard_Digit_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package Chk_A_Long_Float is new Guard_Digit_Check (A_Long_Float); -begin - Report.Test ("CXG2005", - "Check the accuracy of floating point" & - " addition and multiplication"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - Chk_Float.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - Chk_A_Long_Float.Do_Test; - - Report.Result; -end CXG2005; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a deleted file mode 100644 index da15dc3be67..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a +++ /dev/null @@ -1,281 +0,0 @@ --- CXG2006.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 complex Argument function returns --- results that are within the error bound allowed. --- Check that Argument_Error is raised if the Cycle parameter --- is less than or equal to zero. --- --- TEST DESCRIPTION: --- This test uses a generic package to compute and check the --- values of the Argument function. --- Of special interest is the case where either the real or --- the imaginary part of the parameter is very large while the --- other part is very small or 0. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 15 FEB 96 SAIC Initial release for 2.1 --- 03 MAR 97 PWB.CTA Removed checks involving explicit cycle => 2.0*Pi --- --- CHANGE NOTE: --- According to Ken Dritz, author of the Numerics Annex of the RM, --- one should never specify the cycle 2.0*Pi for the trigonometric --- functions. In particular, if the machine number for the first --- argument is not an exact multiple of the machine number for the --- explicit cycle, then the specified exact results cannot be --- reasonably expected. The affected checks in this test have been --- marked as comments, with the additional notation "pwb-math". --- Phil Brashear ---! - --- --- Reference: --- Problems and Methodologies in Mathematical Software Production; --- editors: P. C. Messina and A Murli; --- Lecture Notes in Computer Science --- Volume 142 --- Springer Verlag 1982 --- - -with System; -with Report; -with ImpDef.Annex_G; -with Ada.Numerics; -with Ada.Numerics.Generic_Complex_Types; -with Ada.Numerics.Complex_Types; -procedure CXG2006 is - Verbose : constant Boolean := False; - - - -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 - Sqrt2 : constant := - 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; - Sqrt3 : constant := - 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; - - Pi : constant := Ada.Numerics.Pi; - - generic - type Real is digits <>; - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Complex_Types is new - Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Types; - - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Rel_Error : Real; - Abs_Error : Real; - Max_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual - Expected) > Max_Error then - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & - Real'Image (Actual - Expected) & - " mre:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Special_Cases is - type Data_Point is - record - Re, - Im, - Radians, - Degrees, - Error_Bound : Real; - end record; - - type Test_Data_Type is array (Positive range <>) of Data_Point; - - -- the values in the following table only involve static - -- expressions to minimize errors in precision introduced by the - -- test. For cases where Pi is used in the argument we must - -- allow an extra 1.0*MRE to account for roundoff error in the - -- argument. Where the result involves a square root we allow - -- an extra 0.5*MRE to allow for roundoff error. - Test_Data : constant Test_Data_Type := ( --- Re Im Radians Degrees Err Test # - (0.0, 0.0, 0.0, 0.0, 4.0 ), -- 1 - (1.0, 0.0, 0.0, 0.0, 4.0 ), -- 2 - (Real'Safe_Last, 0.0, 0.0, 0.0, 4.0 ), -- 3 - (Real'Model_Small, 0.0, 0.0, 0.0, 4.0 ), -- 4 - (1.0, 1.0, Pi/4.0, 45.0, 5.0 ), -- 5 - (1.0, -1.0, -Pi/4.0, -45.0, 5.0 ), -- 6 - (-1.0, -1.0, -3.0*Pi/4.0,-135.0, 5.0 ), -- 7 - (-1.0, 1.0, 3.0*Pi/4.0, 135.0, 5.0 ), -- 8 - (Sqrt3, 1.0, Pi/6.0, 30.0, 5.5 ), -- 9 - (-Sqrt3, 1.0, 5.0*Pi/6.0, 150.0, 5.5 ), -- 10 - (Sqrt3, -1.0, -Pi/6.0, -30.0, 5.5 ), -- 11 - (-Sqrt3, -1.0, -5.0*Pi/6.0,-150.0, 5.5 ), -- 12 - (Real'Model_Small, Real'Model_Small, Pi/4.0, 45.0, 5.0 ), -- 13 - (-Real'Safe_Last, 0.0, Pi, 180.0, 5.0 ), -- 14 - (-Real'Safe_Last, -Real'Model_Small, -Pi,-180.0, 5.0 ), -- 15 - (100000.0, 100000.0, Pi/4.0, 45.0, 5.0 )); -- 16 - - X : Real; - Z : Complex; - begin - for I in Test_Data'Range loop - begin - Z := (Test_Data(I).Re, Test_Data(I).Im); - X := Argument (Z); - Check (X, Test_Data(I).Radians, - "test" & Integer'Image (I) & " argument(z)", - Test_Data (I).Error_Bound); ---pwb-math X := Argument (Z, 2.0*Pi); ---pwb-math Check (X, Test_Data(I).Radians, ---pwb-math "test" & Integer'Image (I) & " argument(z, 2pi)", ---pwb-math Test_Data (I).Error_Bound); - X := Argument (Z, 360.0); - Check (X, Test_Data(I).Degrees, - "test" & Integer'Image (I) & " argument(z, 360)", - Test_Data (I).Error_Bound); - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test" & - Integer'Image (I)); - when others => - Report.Failed ("exception in test" & - Integer'Image (I)); - end; - end loop; - - if Real'Signed_Zeros then - begin - X := Argument ((-1.0, Real(ImpDef.Annex_G.Negative_Zero))); - Check (X, -Pi, "test of arg((-1,-0)", 4.0); - exception - when others => - Report.Failed ("exception in signed zero test"); - end; - end if; - end Special_Cases; - - - procedure Exception_Cases is - -- check that Argument_Error is raised if Cycle is <= 0 - Z : Complex := (1.0, 1.0); - X : Real; - Y : Real; - begin - begin - X := Argument (Z, Cycle => 0.0); - Report.Failed ("no exception for cycle = 0.0"); - exception - when Ada.Numerics.Argument_Error => null; - when others => - Report.Failed ("wrong exception for cycle = 0.0"); - end; - - begin - Y := Argument (Z, Cycle => -3.0); - Report.Failed ("no exception for cycle < 0.0"); - exception - when Ada.Numerics.Argument_Error => null; - when others => - Report.Failed ("wrong exception for cycle < 0.0"); - end; - - if Report.Ident_Int (2) = 1 then - -- optimization thwarting code - never executed - Report.Failed("2=1" & Real'Image (X+Y)); - end if; - end Exception_Cases; - - - procedure Do_Test is - begin - Special_Cases; - Exception_Cases; - end Do_Test; - end Generic_Check; - - package Chk_Float is new Generic_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package Chk_A_Long_Float is new Generic_Check (A_Long_Float); -begin - Report.Test ("CXG2006", - "Check the accuracy of the complex argument" & - " function"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Chk_Float.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - Chk_A_Long_Float.Do_Test; - - Report.Result; -end CXG2006; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a deleted file mode 100644 index ba07df29d52..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a +++ /dev/null @@ -1,291 +0,0 @@ --- CXG2007.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 complex Compose_From_Polar function returns --- results that are within the error bound allowed. --- Check that Argument_Error is raised if the Cycle parameter --- is less than or equal to zero. --- --- TEST DESCRIPTION: --- This test uses a generic package to compute and check the --- values of the Compose_From_Polar function. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 23 FEB 96 SAIC Initial release for 2.1 --- 23 APR 96 SAIC Fixed error checking --- 03 MAR 97 PWB.CTA Deleted checks with explicit Cycle => 2.0*Pi --- --- CHANGE NOTE: --- According to Ken Dritz, author of the Numerics Annex of the RM, --- one should never specify the cycle 2.0*Pi for the trigonometric --- functions. In particular, if the machine number for the first --- argument is not an exact multiple of the machine number for the --- explicit cycle, then the specified exact results cannot be --- reasonably expected. The affected checks in this test have been --- marked as comments, with the additional notation "pwb-math". --- Phil Brashear ---! - -with System; -with Report; -with Ada.Numerics; -with Ada.Numerics.Generic_Complex_Types; -procedure CXG2007 is - Verbose : constant Boolean := False; - - - -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 - Sqrt2 : constant := - 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; - Sqrt3 : constant := - 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; - - Pi : constant := Ada.Numerics.Pi; - - generic - type Real is digits <>; - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Complex_Types is new - Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Types; - - Maximum_Relative_Error : constant Real := 3.0; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real; - Arg_Error : Real) is - -- Arg_Error is additional absolute error that is allowed beyond - -- the MRE to account for error in the result that can be - -- attributed to error in the arguments. - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Small instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - Max_Error := Max_Error + Arg_Error; - - if abs (Actual - Expected) > Max_Error then - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Check (Actual, Expected : Complex; - Test_Name : String; - MRE : Real; - Arg_Error : Real) is - -- Arg_Error is additional absolute error that is allowed beyond - -- the MRE to account for error in the result that can be - -- attributed to error in the arguments. - begin - Check (Actual.Re, Expected.Re, - Test_Name & " real part", - MRE, Arg_Error); - Check (Actual.Im, Expected.Im, - Test_Name & " imaginary part", - MRE, Arg_Error); - end Check; - - - procedure Special_Cases is - type Data_Point is - record - Re, - Im, - Modulus, - Radians, - Degrees, - Arg_Error : Real; - end record; - - -- shorthand names for various constants - P4 : constant := Pi/4.0; - P6 : constant := Pi/6.0; - - MER2 : constant Real := Real'Model_Epsilon * Sqrt2; - - type Test_Data_Type is array (Positive range <>) of Data_Point; - - -- the values in the following table only involve static - -- expressions so no loss of precision occurs. - Test_Data : constant Test_Data_Type := ( - --Re Im Modulus Radians Degrees Arg_Err - ( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ), -- 1 - ( 0.0, 0.0, 0.0, Pi, 180.0, 0.0 ), -- 2 - - ( 1.0, 0.0, 1.0, 0.0, 0.0, 0.0 ), -- 3 - (-1.0, 0.0, -1.0, 0.0, 0.0, 0.0 ), -- 4 - - ( 1.0, 1.0, Sqrt2, P4, 45.0, MER2), -- 5 - (-1.0, 1.0, -Sqrt2, -P4, -45.0, MER2), -- 6 - ( 1.0, -1.0, Sqrt2, -P4, -45.0, MER2), -- 7 - (-1.0, -1.0, -Sqrt2, P4, 45.0, MER2), -- 8 - (-1.0, -1.0, Sqrt2, -3.0*P4,-135.0, MER2), -- 9 - (-1.0, 1.0, Sqrt2, 3.0*P4, 135.0, MER2), -- 10 - ( 1.0, -1.0, -Sqrt2, 3.0*P4, 135.0, MER2), -- 11 - - (-1.0, 0.0, 1.0, Pi, 180.0, 0.0 ), -- 12 - ( 1.0, 0.0, -1.0, Pi, 180.0, 0.0 ) ); -- 13 - - - Z : Complex; - Exp : Complex; - begin - for I in Test_Data'Range loop - begin - Exp := (Test_Data (I).Re, Test_Data (I).Im); - - Z := Compose_From_Polar (Test_Data (I).Modulus, - Test_Data (I).Radians); - Check (Z, Exp, - "test" & Integer'Image (I) & " compose_from_polar(m,r)", - Maximum_Relative_Error, Test_Data (I).Arg_Error); - ---pwb-math Z := Compose_From_Polar (Test_Data (I).Modulus, ---pwb-math Test_Data (I).Radians, ---pwb-math 2.0*Pi); ---pwb-math Check (Z, Exp, ---pwb-math "test" & Integer'Image (I) & " compose_from_polar(m,r,2pi)", ---pwb-math Maximum_Relative_Error, Test_Data (I).Arg_Error); - - Z := Compose_From_Polar (Test_Data (I).Modulus, - Test_Data (I).Degrees, - 360.0); - Check (Z, Exp, - "test" & Integer'Image (I) & " compose_from_polar(m,d,360)", - Maximum_Relative_Error, Test_Data (I).Arg_Error); - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test" & - Integer'Image (I)); - when others => - Report.Failed ("exception in test" & - Integer'Image (I)); - end; - end loop; - end Special_Cases; - - - procedure Exception_Cases is - -- check that Argument_Error is raised if Cycle is <= 0 - Z : Complex; - W : Complex; - begin - begin - Z := Compose_From_Polar (3.0, 0.0, Cycle => 0.0); - Report.Failed ("no exception for cycle = 0.0"); - exception - when Ada.Numerics.Argument_Error => null; - when others => - Report.Failed ("wrong exception for cycle = 0.0"); - end; - - begin - W := Compose_From_Polar (6.0, 1.0, Cycle => -10.0); - Report.Failed ("no exception for cycle < 0.0"); - exception - when Ada.Numerics.Argument_Error => null; - when others => - Report.Failed ("wrong exception for cycle < 0.0"); - end; - - if Report.Ident_Int (1) = 2 then - -- not executed - used to make it appear that we use the - -- results of the above computation - Z := Z * W; - Report.Failed(Real'Image (Z.Re + Z.Im)); - end if; - end Exception_Cases; - - - procedure Do_Test is - begin - Special_Cases; - Exception_Cases; - end Do_Test; - end Generic_Check; - - package Chk_Float is new Generic_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package Chk_A_Long_Float is new Generic_Check (A_Long_Float); -begin - Report.Test ("CXG2007", - "Check the accuracy of the Compose_From_Polar" & - " function"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - Chk_Float.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - Chk_A_Long_Float.Do_Test; - - Report.Result; -end CXG2007; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a deleted file mode 100644 index 58cf367f61c..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a +++ /dev/null @@ -1,948 +0,0 @@ --- CXG2008.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 complex multiplication and division --- operations return results that are within the allowed --- error bound. --- Check that all the required pure Numerics packages are pure. --- --- TEST DESCRIPTION: --- This test contains three test packages that are almost --- identical. The first two packages differ only in the --- floating point type that is being tested. The first --- and third package differ only in whether the generic --- complex types package or the pre-instantiated --- package is used. --- The test package is not generic so that the arguments --- and expected results for some of the test values --- can be expressed as universal real instead of being --- computed at runtime. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 24 FEB 96 SAIC Initial release for 2.1 --- 03 JUN 98 EDS Correct the test program's incorrect assumption --- that Constraint_Error must be raised by complex --- division by zero, which is contrary to the --- allowance given by the Ada 95 standard G.1.1(40). --- 13 MAR 01 RLB Replaced commented out Pure check on non-generic --- packages, as required by Defect Report --- 8652/0020 and as reflected in Technical --- Corrigendum 1. ---! - ------------------------------------------------------------------------------- --- Check that the required pure packages are pure by withing them from a --- pure package. The non-generic versions of those packages are required to --- be pure by Defect Report 8652/0020, Technical Corrigendum 1 [A.5.1(9/1) and --- G.1.1(25/1)]. -with Ada.Numerics.Generic_Elementary_Functions; -with Ada.Numerics.Elementary_Functions; -with Ada.Numerics.Generic_Complex_Types; -with Ada.Numerics.Complex_Types; -with Ada.Numerics.Generic_Complex_Elementary_Functions; -with Ada.Numerics.Complex_Elementary_Functions; -package CXG2008_0 is - pragma Pure; - -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 - Sqrt2 : constant := - 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; - Sqrt3 : constant := - 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; -end CXG2008_0; - ------------------------------------------------------------------------------- - -with System; -with Report; -with Ada.Numerics.Generic_Complex_Types; -with Ada.Numerics.Complex_Types; -with CXG2008_0; use CXG2008_0; -procedure CXG2008 is - Verbose : constant Boolean := False; - - package Float_Check is - subtype Real is Float; - procedure Do_Test; - end Float_Check; - - package body Float_Check is - package Complex_Types is new - Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Types; - - -- keep track if an accuracy failure has occurred so the test - -- can be short-circuited to avoid thousands of error messages. - Failure_Detected : Boolean := False; - - Mult_MBE : constant Real := 5.0; - Divide_MBE : constant Real := 13.0; - - - procedure Check (Actual, Expected : Complex; - Test_Name : String; - MBE : Real) is - Rel_Error : Real; - Abs_Error : Real; - Max_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon; - Abs_Error := MBE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual.Re - Expected.Re) > Max_Error then - Failure_Detected := True; - Report.Failed (Test_Name & - " actual.re: " & Real'Image (Actual.Re) & - " expected.re: " & Real'Image (Expected.Re) & - " difference.re " & - Real'Image (Actual.Re - Expected.Re) & - " mre:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result for real part"); - else - Report.Comment (Test_Name & " passed for real part"); - end if; - end if; - - Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - if abs (Actual.Im - Expected.Im) > Max_Error then - Failure_Detected := True; - Report.Failed (Test_Name & - " actual.im: " & Real'Image (Actual.Im) & - " expected.im: " & Real'Image (Expected.Im) & - " difference.im " & - Real'Image (Actual.Im - Expected.Im) & - " mre:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result for imaginary part"); - else - Report.Comment (Test_Name & " passed for imaginary part"); - end if; - end if; - end Check; - - - procedure Special_Values is - begin - - --- test 1 --- - declare - T : constant := (Real'Machine_EMax - 1) / 2; - Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T); - Expected : Complex := (0.0, 0.0); - X : Complex := (0.0, 0.0); - Y : Complex := (Big, Big); - Z : Complex; - begin - Z := X * Y; - Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)", - Mult_MBE); - Z := Y * X; - Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)", - Mult_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 1"); - when others => - Report.Failed ("exception in test 1"); - end; - - --- test 2 --- - declare - T : constant := Real'Model_EMin + 1; - Tiny : constant := (1.0 * Real'Machine_Radix) ** T; - U : Complex := (Tiny, Tiny); - X : Complex := (0.0, 0.0); - Expected : Complex := (0.0, 0.0); - Z : Complex; - begin - Z := U * X; - Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)", - Mult_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 2"); - when others => - Report.Failed ("exception in test 2"); - end; - - --- test 3 --- - declare - T : constant := (Real'Machine_EMax - 1) / 2; - Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T); - B : Complex := (Big, Big); - X : Complex := (0.0, 0.0); - Z : Complex; - begin - if Real'Machine_Overflows then - Z := B / X; - Report.Failed ("test 3 - Constraint_Error not raised"); - Check (Z, Z, "not executed - optimizer thwarting", 0.0); - end if; - exception - when Constraint_Error => null; -- expected - when others => - Report.Failed ("exception in test 3"); - end; - - --- test 4 --- - declare - T : constant := Real'Model_EMin + 1; - Tiny : constant := (1.0 * Real'Machine_Radix) ** T; - U : Complex := (Tiny, Tiny); - X : Complex := (0.0, 0.0); - Z : Complex; - begin - if Real'Machine_Overflows then - Z := U / X; - Report.Failed ("test 4 - Constraint_Error not raised"); - Check (Z, Z, "not executed - optimizer thwarting", 0.0); - end if; - exception - when Constraint_Error => null; -- expected - when others => - Report.Failed ("exception in test 4"); - end; - - - --- test 5 --- - declare - X : Complex := (Sqrt2, Sqrt2); - Z : Complex; - Expected : constant Complex := (0.0, 4.0); - begin - Z := X * X; - Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)", - Mult_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 5"); - when others => - Report.Failed ("exception in test 5"); - end; - - --- test 6 --- - declare - X : Complex := Sqrt3 - Sqrt3 * i; - Z : Complex; - Expected : constant Complex := (0.0, -6.0); - begin - Z := X * X; - Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)", - Mult_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 6"); - when others => - Report.Failed ("exception in test 6"); - end; - - --- test 7 --- - declare - X : Complex := Sqrt2 + Sqrt2 * i; - Y : Complex := Sqrt2 - Sqrt2 * i; - Z : Complex; - Expected : constant Complex := 0.0 + i; - begin - Z := X / Y; - Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)", - Divide_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 7"); - when others => - Report.Failed ("exception in test 7"); - end; - end Special_Values; - - - procedure Do_Mult_Div (X, Y : Complex) is - Z : Complex; - Args : constant String := - "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " & - "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ; - begin - Z := (X * X) / X; - Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE); - Z := (X * Y) / X; - Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE); - Z := (X * Y) / Y; - Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args); - when others => - Report.Failed ("exception in Do_Mult_Div for " & Args); - end Do_Mult_Div; - - -- select complex values X and Y where the real and imaginary - -- parts are selected from the ranges (1/radix..1) and - -- (1..radix). This translates into quite a few combinations. - procedure Mult_Div_Check is - Samples : constant := 17; - Radix : constant Real := Real(Real'Machine_Radix); - Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix); - Low_Sample : Real; -- (1/radix .. 1) - High_Sample : Real; -- (1 .. radix) - Sample : array (1..2) of Real; - X, Y : Complex; - begin - for I in 1 .. Samples loop - Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) + - Inv_Radix; - Sample (1) := Low_Sample; - for J in 1 .. Samples loop - High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) + - Radix; - Sample (2) := High_Sample; - for K in 1 .. 2 loop - for L in 1 .. 2 loop - X := Complex'(Sample (K), Sample (L)); - Y := Complex'(Sample (L), Sample (K)); - Do_Mult_Div (X, Y); - if Failure_Detected then - return; -- minimize flood of error messages - end if; - end loop; - end loop; - end loop; -- J - end loop; -- I - end Mult_Div_Check; - - - procedure Do_Test is - begin - Special_Values; - Mult_Div_Check; - end Do_Test; - end Float_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - -- check the floating point type with the most digits - - package A_Long_Float_Check is - type A_Long_Float is digits System.Max_Digits; - subtype Real is A_Long_Float; - procedure Do_Test; - end A_Long_Float_Check; - - package body A_Long_Float_Check is - - package Complex_Types is new - Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Types; - - -- keep track if an accuracy failure has occurred so the test - -- can be short-circuited to avoid thousands of error messages. - Failure_Detected : Boolean := False; - - Mult_MBE : constant Real := 5.0; - Divide_MBE : constant Real := 13.0; - - - procedure Check (Actual, Expected : Complex; - Test_Name : String; - MBE : Real) is - Rel_Error : Real; - Abs_Error : Real; - Max_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon; - Abs_Error := MBE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual.Re - Expected.Re) > Max_Error then - Failure_Detected := True; - Report.Failed (Test_Name & - " actual.re: " & Real'Image (Actual.Re) & - " expected.re: " & Real'Image (Expected.Re) & - " difference.re " & - Real'Image (Actual.Re - Expected.Re) & - " mre:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result for real part"); - else - Report.Comment (Test_Name & " passed for real part"); - end if; - end if; - - Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - if abs (Actual.Im - Expected.Im) > Max_Error then - Failure_Detected := True; - Report.Failed (Test_Name & - " actual.im: " & Real'Image (Actual.Im) & - " expected.im: " & Real'Image (Expected.Im) & - " difference.im " & - Real'Image (Actual.Im - Expected.Im) & - " mre:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result for imaginary part"); - else - Report.Comment (Test_Name & " passed for imaginary part"); - end if; - end if; - end Check; - - - procedure Special_Values is - begin - - --- test 1 --- - declare - T : constant := (Real'Machine_EMax - 1) / 2; - Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T); - Expected : Complex := (0.0, 0.0); - X : Complex := (0.0, 0.0); - Y : Complex := (Big, Big); - Z : Complex; - begin - Z := X * Y; - Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)", - Mult_MBE); - Z := Y * X; - Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)", - Mult_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 1"); - when others => - Report.Failed ("exception in test 1"); - end; - - --- test 2 --- - declare - T : constant := Real'Model_EMin + 1; - Tiny : constant := (1.0 * Real'Machine_Radix) ** T; - U : Complex := (Tiny, Tiny); - X : Complex := (0.0, 0.0); - Expected : Complex := (0.0, 0.0); - Z : Complex; - begin - Z := U * X; - Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)", - Mult_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 2"); - when others => - Report.Failed ("exception in test 2"); - end; - - --- test 3 --- - declare - T : constant := (Real'Machine_EMax - 1) / 2; - Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T); - B : Complex := (Big, Big); - X : Complex := (0.0, 0.0); - Z : Complex; - begin - if Real'Machine_Overflows then - Z := B / X; - Report.Failed ("test 3 - Constraint_Error not raised"); - Check (Z, Z, "not executed - optimizer thwarting", 0.0); - end if; - exception - when Constraint_Error => null; -- expected - when others => - Report.Failed ("exception in test 3"); - end; - - --- test 4 --- - declare - T : constant := Real'Model_EMin + 1; - Tiny : constant := (1.0 * Real'Machine_Radix) ** T; - U : Complex := (Tiny, Tiny); - X : Complex := (0.0, 0.0); - Z : Complex; - begin - if Real'Machine_Overflows then - Z := U / X; - Report.Failed ("test 4 - Constraint_Error not raised"); - Check (Z, Z, "not executed - optimizer thwarting", 0.0); - end if; - exception - when Constraint_Error => null; -- expected - when others => - Report.Failed ("exception in test 4"); - end; - - - --- test 5 --- - declare - X : Complex := (Sqrt2, Sqrt2); - Z : Complex; - Expected : constant Complex := (0.0, 4.0); - begin - Z := X * X; - Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)", - Mult_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 5"); - when others => - Report.Failed ("exception in test 5"); - end; - - --- test 6 --- - declare - X : Complex := Sqrt3 - Sqrt3 * i; - Z : Complex; - Expected : constant Complex := (0.0, -6.0); - begin - Z := X * X; - Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)", - Mult_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 6"); - when others => - Report.Failed ("exception in test 6"); - end; - - --- test 7 --- - declare - X : Complex := Sqrt2 + Sqrt2 * i; - Y : Complex := Sqrt2 - Sqrt2 * i; - Z : Complex; - Expected : constant Complex := 0.0 + i; - begin - Z := X / Y; - Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)", - Divide_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 7"); - when others => - Report.Failed ("exception in test 7"); - end; - end Special_Values; - - - procedure Do_Mult_Div (X, Y : Complex) is - Z : Complex; - Args : constant String := - "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " & - "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ; - begin - Z := (X * X) / X; - Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE); - Z := (X * Y) / X; - Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE); - Z := (X * Y) / Y; - Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args); - when others => - Report.Failed ("exception in Do_Mult_Div for " & Args); - end Do_Mult_Div; - - -- select complex values X and Y where the real and imaginary - -- parts are selected from the ranges (1/radix..1) and - -- (1..radix). This translates into quite a few combinations. - procedure Mult_Div_Check is - Samples : constant := 17; - Radix : constant Real := Real(Real'Machine_Radix); - Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix); - Low_Sample : Real; -- (1/radix .. 1) - High_Sample : Real; -- (1 .. radix) - Sample : array (1..2) of Real; - X, Y : Complex; - begin - for I in 1 .. Samples loop - Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) + - Inv_Radix; - Sample (1) := Low_Sample; - for J in 1 .. Samples loop - High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) + - Radix; - Sample (2) := High_Sample; - for K in 1 .. 2 loop - for L in 1 .. 2 loop - X := Complex'(Sample (K), Sample (L)); - Y := Complex'(Sample (L), Sample (K)); - Do_Mult_Div (X, Y); - if Failure_Detected then - return; -- minimize flood of error messages - end if; - end loop; - end loop; - end loop; -- J - end loop; -- I - end Mult_Div_Check; - - - procedure Do_Test is - begin - Special_Values; - Mult_Div_Check; - end Do_Test; - end A_Long_Float_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - package Non_Generic_Check is - subtype Real is Float; - procedure Do_Test; - end Non_Generic_Check; - - package body Non_Generic_Check is - - use Ada.Numerics.Complex_Types; - - -- keep track if an accuracy failure has occurred so the test - -- can be short-circuited to avoid thousands of error messages. - Failure_Detected : Boolean := False; - - Mult_MBE : constant Real := 5.0; - Divide_MBE : constant Real := 13.0; - - - procedure Check (Actual, Expected : Complex; - Test_Name : String; - MBE : Real) is - Rel_Error : Real; - Abs_Error : Real; - Max_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon; - Abs_Error := MBE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual.Re - Expected.Re) > Max_Error then - Failure_Detected := True; - Report.Failed (Test_Name & - " actual.re: " & Real'Image (Actual.Re) & - " expected.re: " & Real'Image (Expected.Re) & - " difference.re " & - Real'Image (Actual.Re - Expected.Re) & - " mre:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result for real part"); - else - Report.Comment (Test_Name & " passed for real part"); - end if; - end if; - - Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - if abs (Actual.Im - Expected.Im) > Max_Error then - Failure_Detected := True; - Report.Failed (Test_Name & - " actual.im: " & Real'Image (Actual.Im) & - " expected.im: " & Real'Image (Expected.Im) & - " difference.im " & - Real'Image (Actual.Im - Expected.Im) & - " mre:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result for imaginary part"); - else - Report.Comment (Test_Name & " passed for imaginary part"); - end if; - end if; - end Check; - - - procedure Special_Values is - begin - - --- test 1 --- - declare - T : constant := (Real'Machine_EMax - 1) / 2; - Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T); - Expected : Complex := (0.0, 0.0); - X : Complex := (0.0, 0.0); - Y : Complex := (Big, Big); - Z : Complex; - begin - Z := X * Y; - Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)", - Mult_MBE); - Z := Y * X; - Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)", - Mult_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 1"); - when others => - Report.Failed ("exception in test 1"); - end; - - --- test 2 --- - declare - T : constant := Real'Model_EMin + 1; - Tiny : constant := (1.0 * Real'Machine_Radix) ** T; - U : Complex := (Tiny, Tiny); - X : Complex := (0.0, 0.0); - Expected : Complex := (0.0, 0.0); - Z : Complex; - begin - Z := U * X; - Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)", - Mult_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 2"); - when others => - Report.Failed ("exception in test 2"); - end; - - --- test 3 --- - declare - T : constant := (Real'Machine_EMax - 1) / 2; - Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T); - B : Complex := (Big, Big); - X : Complex := (0.0, 0.0); - Z : Complex; - begin - if Real'Machine_Overflows then - Z := B / X; - Report.Failed ("test 3 - Constraint_Error not raised"); - Check (Z, Z, "not executed - optimizer thwarting", 0.0); - end if; - exception - when Constraint_Error => null; -- expected - when others => - Report.Failed ("exception in test 3"); - end; - - --- test 4 --- - declare - T : constant := Real'Model_EMin + 1; - Tiny : constant := (1.0 * Real'Machine_Radix) ** T; - U : Complex := (Tiny, Tiny); - X : Complex := (0.0, 0.0); - Z : Complex; - begin - if Real'Machine_Overflows then - Z := U / X; - Report.Failed ("test 4 - Constraint_Error not raised"); - Check (Z, Z, "not executed - optimizer thwarting", 0.0); - end if; - exception - when Constraint_Error => null; -- expected - when others => - Report.Failed ("exception in test 4"); - end; - - - --- test 5 --- - declare - X : Complex := (Sqrt2, Sqrt2); - Z : Complex; - Expected : constant Complex := (0.0, 4.0); - begin - Z := X * X; - Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)", - Mult_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 5"); - when others => - Report.Failed ("exception in test 5"); - end; - - --- test 6 --- - declare - X : Complex := Sqrt3 - Sqrt3 * i; - Z : Complex; - Expected : constant Complex := (0.0, -6.0); - begin - Z := X * X; - Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)", - Mult_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 6"); - when others => - Report.Failed ("exception in test 6"); - end; - - --- test 7 --- - declare - X : Complex := Sqrt2 + Sqrt2 * i; - Y : Complex := Sqrt2 - Sqrt2 * i; - Z : Complex; - Expected : constant Complex := 0.0 + i; - begin - Z := X / Y; - Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)", - Divide_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 7"); - when others => - Report.Failed ("exception in test 7"); - end; - end Special_Values; - - - procedure Do_Mult_Div (X, Y : Complex) is - Z : Complex; - Args : constant String := - "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " & - "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ; - begin - Z := (X * X) / X; - Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE); - Z := (X * Y) / X; - Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE); - Z := (X * Y) / Y; - Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args); - when others => - Report.Failed ("exception in Do_Mult_Div for " & Args); - end Do_Mult_Div; - - -- select complex values X and Y where the real and imaginary - -- parts are selected from the ranges (1/radix..1) and - -- (1..radix). This translates into quite a few combinations. - procedure Mult_Div_Check is - Samples : constant := 17; - Radix : constant Real := Real(Real'Machine_Radix); - Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix); - Low_Sample : Real; -- (1/radix .. 1) - High_Sample : Real; -- (1 .. radix) - Sample : array (1..2) of Real; - X, Y : Complex; - begin - for I in 1 .. Samples loop - Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) + - Inv_Radix; - Sample (1) := Low_Sample; - for J in 1 .. Samples loop - High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) + - Radix; - Sample (2) := High_Sample; - for K in 1 .. 2 loop - for L in 1 .. 2 loop - X := Complex'(Sample (K), Sample (L)); - Y := Complex'(Sample (L), Sample (K)); - Do_Mult_Div (X, Y); - if Failure_Detected then - return; -- minimize flood of error messages - end if; - end loop; - end loop; - end loop; -- J - end loop; -- I - end Mult_Div_Check; - - - procedure Do_Test is - begin - Special_Values; - Mult_Div_Check; - end Do_Test; - end Non_Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - -begin - Report.Test ("CXG2008", - "Check the accuracy of the complex multiplication and" & - " division operators"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking non-generic package"); - end if; - - Non_Generic_Check.Do_Test; - - Report.Result; -end CXG2008; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a deleted file mode 100644 index 0b11ca53887..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a +++ /dev/null @@ -1,421 +0,0 @@ --- CXG2009.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 real sqrt and complex modulus functions --- return results that are within the allowed --- error bound. --- --- TEST DESCRIPTION: --- This test checks the accuracy of the sqrt and modulus functions --- by computing the norm of various vectors where the result --- is known in advance. --- This test uses real and complex math together as would an --- actual application. Considerable use of generics is also --- employed. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 26 FEB 96 SAIC Initial release for 2.1 --- 22 AUG 96 SAIC Revised Check procedure --- ---! - ------------------------------------------------------------------------------- - -with System; -with Report; -with Ada.Numerics.Generic_Complex_Types; -with Ada.Numerics.Generic_Elementary_Functions; -procedure CXG2009 is - Verbose : constant Boolean := False; - - --===================================================================== - - generic - type Real is digits <>; - package Generic_Real_Norm_Check is - procedure Do_Test; - end Generic_Real_Norm_Check; - - ----------------------------------------------------------------------- - - package body Generic_Real_Norm_Check is - type Vector is array (Integer range <>) of Real; - - package GEF is new Ada.Numerics.Generic_Elementary_Functions (Real); - function Sqrt (X : Real) return Real renames GEF.Sqrt; - - function One_Norm (V : Vector) return Real is - -- sum of absolute values of the elements of the vector - Result : Real := 0.0; - begin - for I in V'Range loop - Result := Result + abs V(I); - end loop; - return Result; - end One_Norm; - - function Inf_Norm (V : Vector) return Real is - -- greatest absolute vector element - Result : Real := 0.0; - begin - for I in V'Range loop - if abs V(I) > Result then - Result := abs V(I); - end if; - end loop; - return Result; - end Inf_Norm; - - function Two_Norm (V : Vector) return Real is - -- if greatest absolute vector element is 0 then return 0 - -- else return greatest * sqrt (sum((element / greatest) ** 2))) - -- where greatest is Inf_Norm of the vector - Inf_N : Real; - Sum_Squares : Real; - Term : Real; - begin - Inf_N := Inf_Norm (V); - if Inf_N = 0.0 then - return 0.0; - end if; - Sum_Squares := 0.0; - for I in V'Range loop - Term := V (I) / Inf_N; - Sum_Squares := Sum_Squares + Term * Term; - end loop; - return Inf_N * Sqrt (Sum_Squares); - end Two_Norm; - - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real; - Vector_Length : Integer) is - Rel_Error : Real; - Abs_Error : Real; - Max_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual - Expected) > Max_Error then - Report.Failed (Test_Name & - " VectLength:" & - Integer'Image (Vector_Length) & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & - Real'Image (Actual - Expected) & - " mre:" & Real'Image (Max_Error) ); - elsif Verbose then - Report.Comment (Test_Name & " vector length" & - Integer'Image (Vector_Length)); - end if; - end Check; - - - procedure Do_Test is - begin - for Vector_Length in 1 .. 10 loop - declare - V : Vector (1..Vector_Length) := (1..Vector_Length => 0.0); - V1 : Vector (1..Vector_Length) := (1..Vector_Length => 1.0); - begin - Check (One_Norm (V), 0.0, "one_norm (z)", 0.0, Vector_Length); - Check (Inf_Norm (V), 0.0, "inf_norm (z)", 0.0, Vector_Length); - - for J in 1..Vector_Length loop - V := (1..Vector_Length => 0.0); - V (J) := 1.0; - Check (One_Norm (V), 1.0, "one_norm (010)", - 0.0, Vector_Length); - Check (Inf_Norm (V), 1.0, "inf_norm (010)", - 0.0, Vector_Length); - Check (Two_Norm (V), 1.0, "two_norm (010)", - 0.0, Vector_Length); - end loop; - - Check (One_Norm (V1), Real (Vector_Length), "one_norm (1)", - 0.0, Vector_Length); - Check (Inf_Norm (V1), 1.0, "inf_norm (1)", - 0.0, Vector_Length); - - -- error in computing Two_Norm and expected result - -- are as follows (ME is Model_Epsilon * Expected_Value): - -- 2ME from expected Sqrt - -- 2ME from Sqrt in Two_Norm times the error in the - -- vector calculation. - -- The vector calculation contains the following error - -- based upon the length N of the vector: - -- N*1ME from squaring terms in Two_Norm - -- N*1ME from the division of each term in Two_Norm - -- (N-1)*1ME from the sum of the terms - -- This gives (2 + 2 * (N + N + (N-1)) ) * ME - -- which simplifies to (2 + 2N + 2N + 2N - 2) * ME - -- or 6*N*ME - Check (Two_Norm (V1), Sqrt (Real(Vector_Length)), - "two_norm (1)", - (Real (6 * Vector_Length)), - Vector_Length); - exception - when others => Report.Failed ("exception for vector length" & - Integer'Image (Vector_Length) ); - end; - end loop; - end Do_Test; - end Generic_Real_Norm_Check; - - --===================================================================== - - generic - type Real is digits <>; - package Generic_Complex_Norm_Check is - procedure Do_Test; - end Generic_Complex_Norm_Check; - - ----------------------------------------------------------------------- - - package body Generic_Complex_Norm_Check is - package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Types; - type Vector is array (Integer range <>) of Complex; - - package GEF is new Ada.Numerics.Generic_Elementary_Functions (Real); - function Sqrt (X : Real) return Real renames GEF.Sqrt; - - function One_Norm (V : Vector) return Real is - Result : Real := 0.0; - begin - for I in V'Range loop - Result := Result + abs V(I); - end loop; - return Result; - end One_Norm; - - function Inf_Norm (V : Vector) return Real is - Result : Real := 0.0; - begin - for I in V'Range loop - if abs V(I) > Result then - Result := abs V(I); - end if; - end loop; - return Result; - end Inf_Norm; - - function Two_Norm (V : Vector) return Real is - Inf_N : Real; - Sum_Squares : Real; - Term : Real; - begin - Inf_N := Inf_Norm (V); - if Inf_N = 0.0 then - return 0.0; - end if; - Sum_Squares := 0.0; - for I in V'Range loop - Term := abs (V (I) / Inf_N ); - Sum_Squares := Sum_Squares + Term * Term; - end loop; - return Inf_N * Sqrt (Sum_Squares); - end Two_Norm; - - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real; - Vector_Length : Integer) is - Rel_Error : Real; - Abs_Error : Real; - Max_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual - Expected) > Max_Error then - Report.Failed (Test_Name & - " VectLength:" & - Integer'Image (Vector_Length) & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & - Real'Image (Actual - Expected) & - " mre:" & Real'Image (Max_Error) ); - elsif Verbose then - Report.Comment (Test_Name & " vector length" & - Integer'Image (Vector_Length)); - end if; - end Check; - - - procedure Do_Test is - begin - for Vector_Length in 1 .. 10 loop - declare - V : Vector (1..Vector_Length) := - (1..Vector_Length => (0.0, 0.0)); - X, Y : Vector (1..Vector_Length); - begin - Check (One_Norm (V), 0.0, "one_norm (z)", 0.0, Vector_Length); - Check (Inf_Norm (V), 0.0, "inf_norm (z)", 0.0, Vector_Length); - - for J in 1..Vector_Length loop - X := (1..Vector_Length => (0.0, 0.0) ); - Y := X; -- X and Y are now both zeroed - X (J).Re := 1.0; - Y (J).Im := 1.0; - Check (One_Norm (X), 1.0, "one_norm (0x0)", - 0.0, Vector_Length); - Check (Inf_Norm (X), 1.0, "inf_norm (0x0)", - 0.0, Vector_Length); - Check (Two_Norm (X), 1.0, "two_norm (0x0)", - 0.0, Vector_Length); - Check (One_Norm (Y), 1.0, "one_norm (0y0)", - 0.0, Vector_Length); - Check (Inf_Norm (Y), 1.0, "inf_norm (0y0)", - 0.0, Vector_Length); - Check (Two_Norm (Y), 1.0, "two_norm (0y0)", - 0.0, Vector_Length); - end loop; - - V := (1..Vector_Length => (3.0, 4.0)); - - -- error in One_Norm is 3*N*ME for abs computation + - -- (N-1)*ME for the additions - -- which gives (4N-1) * ME - Check (One_Norm (V), 5.0 * Real (Vector_Length), - "one_norm ((3,4))", - Real (4*Vector_Length - 1), - Vector_Length); - - -- error in Inf_Norm is from abs of single element (3ME) - Check (Inf_Norm (V), 5.0, - "inf_norm ((3,4))", - 3.0, - Vector_Length); - - -- error in following comes from: - -- 2ME in sqrt of expected result - -- 3ME in Inf_Norm calculation - -- 2ME in sqrt of vector calculation - -- vector calculation has following error - -- 3N*ME for abs - -- N*ME for squaring - -- N*ME for division - -- (N-1)ME for sum - -- this results in [2 + 3 + 2(6N-1) ] * ME - -- or (12N + 3)ME - Check (Two_Norm (V), 5.0 * Sqrt (Real(Vector_Length)), - "two_norm ((3,4))", - (12.0 * Real (Vector_Length) + 3.0), - Vector_Length); - exception - when others => Report.Failed ("exception for complex " & - "vector length" & - Integer'Image (Vector_Length) ); - end; - end loop; - end Do_Test; - end Generic_Complex_Norm_Check; - - --===================================================================== - - generic - type Real is digits <>; - package Generic_Norm_Check is - procedure Do_Test; - end Generic_Norm_Check; - - ----------------------------------------------------------------------- - - package body Generic_Norm_Check is - package RNC is new Generic_Real_Norm_Check (Real); - package CNC is new Generic_Complex_Norm_Check (Real); - procedure Do_Test is - begin - RNC.Do_Test; - CNC.Do_Test; - end Do_Test; - end Generic_Norm_Check; - - --===================================================================== - - package Float_Check is new Generic_Norm_Check (Float); - - type A_Long_Float is digits System.Max_Digits; - package A_Long_Float_Check is new Generic_Norm_Check (A_Long_Float); - - ----------------------------------------------------------------------- - -begin - Report.Test ("CXG2009", - "Check the accuracy of the real sqrt and complex " & - " modulus functions"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - Report.Result; -end CXG2009; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a deleted file mode 100644 index 4140a487526..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a +++ /dev/null @@ -1,892 +0,0 @@ --- CXG2010.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 exp function returns --- results that are within the error bound allowed. --- --- TEST DESCRIPTION: --- This test contains three test packages that are almost --- identical. The first two packages differ only in the --- floating point type that is being tested. The first --- and third package differ only in whether the generic --- elementary functions package or the pre-instantiated --- package is used. --- The test package is not generic so that the arguments --- and expected results for some of the test values --- can be expressed as universal real instead of being --- computed at runtime. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex and where the Machine_Radix is 2, 4, 8, or 16. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 1 Mar 96 SAIC Initial release for 2.1 --- 2 Sep 96 SAIC Improved check routine --- ---! - --- --- References: --- --- Software Manual for the Elementary Functions --- William J. Cody, Jr. and William Waite --- Prentice-Hall, 1980 --- --- CRC Standard Mathematical Tables --- 23rd Edition --- --- Implementation and Testing of Function Software --- W. J. Cody --- Problems and Methodologies in Mathematical Software Production --- editors P. C. Messina and A. Murli --- Lecture Notes in Computer Science Volume 142 --- Springer Verlag, 1982 --- - --- --- Notes on derivation of error bound for exp(p)*exp(-p) --- --- Let a = true value of exp(p) and ac be the computed value. --- Then a = ac(1+e1), where |e1| <= 4*Model_Epsilon. --- Similarly, let b = true value of exp(-p) and bc be the computed value. --- Then b = bc(1+e2), where |e2| <= 4*ME. --- --- The product of x and y is (x*y)(1+e3), where |e3| <= 1.0ME --- --- Hence, the computed ab is [ac(1+e1)*bc(1+e2)](1+e3) = --- (ac*bc)[1 + e1 + e2 + e3 + e1e2 + e1e3 + e2e3 + e1e2e3). --- --- Throwing away the last four tiny terms, we have (ac*bc)(1 + eta), --- --- where |eta| <= (4+4+1)ME = 9.0Model_Epsilon. - -with System; -with Report; -with Ada.Numerics.Generic_Elementary_Functions; -with Ada.Numerics.Elementary_Functions; -procedure CXG2010 is - Verbose : constant Boolean := False; - Max_Samples : constant := 1000; - Accuracy_Error_Reported : Boolean := False; - - package Float_Check is - subtype Real is Float; - procedure Do_Test; - end Float_Check; - - package body Float_Check is - package Elementary_Functions is new - Ada.Numerics.Generic_Elementary_Functions (Real); - function Sqrt (X : Real) return Real renames - Elementary_Functions.Sqrt; - function Exp (X : Real) return Real renames - Elementary_Functions.Exp; - - - -- The following value is a lower bound on the accuracy - -- required. It is normally 0.0 so that the lower bound - -- is computed from Model_Epsilon. However, for tests - -- where the expected result is only known to a certain - -- amount of precision this bound takes on a non-zero - -- value to account for that level of precision. - Error_Low_Bound : Real := 0.0; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon - -- instead of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - -- take into account the low bound on the error - if Max_Error < Error_Low_Bound then - Max_Error := Error_Low_Bound; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Argument_Range_Check_1 (A, B : Real; - Test : String) is - -- test a evenly distributed selection of - -- arguments selected from the range A to B. - -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V) - -- The parameter One_Minus_Exp_Minus_V is the value - -- 1.0 - Exp (-V) - -- accurate to machine precision. - -- This procedure is a translation of part of Cody's test - X : Real; - Y : Real; - ZX, ZY : Real; - V : constant := 1.0 / 16.0; - One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2; - - begin - Accuracy_Error_Reported := False; - for I in 1..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - Y := X - V; - if Y < 0.0 then - X := Y + V; - end if; - - ZX := Exp (X); - ZY := Exp (Y); - - -- ZX := Exp(X) - Exp(X) * (1 - Exp(-V); - -- which simplifies to ZX := Exp (X-V); - ZX := ZX - ZX * One_Minus_Exp_Minus_V; - - -- note that since the expected value is computed, we - -- must take the error in that computation into account. - Check (ZY, ZX, - "test " & Test & " -" & - Integer'Image (I) & - " exp (" & Real'Image (X) & ")", - 9.0); - exit when Accuracy_Error_Reported; - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in argument range check 1"); - when others => - Report.Failed ("exception in argument range check 1"); - end Argument_Range_Check_1; - - - - procedure Argument_Range_Check_2 (A, B : Real; - Test : String) is - -- test a evenly distributed selection of - -- arguments selected from the range A to B. - -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V) - -- The parameter One_Minus_Exp_Minus_V is the value - -- 1.0 - Exp (-V) - -- accurate to machine precision. - -- This procedure is a translation of part of Cody's test - X : Real; - Y : Real; - ZX, ZY : Real; - V : constant := 45.0 / 16.0; - -- 1/16 - Exp(45/16) - Coeff : constant := 2.4453321046920570389E-3; - - begin - Accuracy_Error_Reported := False; - for I in 1..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - Y := X - V; - if Y < 0.0 then - X := Y + V; - end if; - - ZX := Exp (X); - ZY := Exp (Y); - - -- ZX := Exp(X) * 1/16 - Exp(X) * Coeff; - -- where Coeff is 1/16 - Exp(45/16) - -- which simplifies to ZX := Exp (X-V); - ZX := ZX * 0.0625 - ZX * Coeff; - - -- note that since the expected value is computed, we - -- must take the error in that computation into account. - Check (ZY, ZX, - "test " & Test & " -" & - Integer'Image (I) & - " exp (" & Real'Image (X) & ")", - 9.0); - exit when Accuracy_Error_Reported; - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in argument range check 2"); - when others => - Report.Failed ("exception in argument range check 2"); - end Argument_Range_Check_2; - - - procedure Do_Test is - begin - - --- test 1 --- - declare - Y : Real; - begin - Y := Exp(1.0); - -- normal accuracy requirements - Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 1"); - when others => - Report.Failed ("exception in test 1"); - end; - - --- test 2 --- - declare - Y : Real; - begin - Y := Exp(16.0) * Exp(-16.0); - Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 2"); - when others => - Report.Failed ("exception in test 2"); - end; - - --- test 3 --- - declare - Y : Real; - begin - Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi); - Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 3"); - when others => - Report.Failed ("exception in test 3"); - end; - - --- test 4 --- - declare - Y : Real; - begin - Y := Exp(0.0); - Check (Y, 1.0, "test 4 -- exp(0.0)", - 0.0); -- no error allowed - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 4"); - when others => - Report.Failed ("exception in test 4"); - end; - - --- test 5 --- - -- constants used here only have 19 digits of precision - if Real'Digits > 19 then - Error_Low_Bound := 0.00000_00000_00000_0001; - Report.Comment ("exp accuracy checked to 19 digits"); - end if; - - Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)), - 1.0, - "5"); - Error_Low_Bound := 0.0; -- reset - - --- test 6 --- - -- constants used here only have 19 digits of precision - if Real'Digits > 19 then - Error_Low_Bound := 0.00000_00000_00000_0001; - Report.Comment ("exp accuracy checked to 19 digits"); - end if; - - Argument_Range_Check_2 (1.0, - Sqrt(Real(Real'Machine_Radix)), - "6"); - Error_Low_Bound := 0.0; -- reset - - end Do_Test; - end Float_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - - - package A_Long_Float_Check is - subtype Real is A_Long_Float; - procedure Do_Test; - end A_Long_Float_Check; - - package body A_Long_Float_Check is - package Elementary_Functions is new - Ada.Numerics.Generic_Elementary_Functions (Real); - function Sqrt (X : Real) return Real renames - Elementary_Functions.Sqrt; - function Exp (X : Real) return Real renames - Elementary_Functions.Exp; - - - -- The following value is a lower bound on the accuracy - -- required. It is normally 0.0 so that the lower bound - -- is computed from Model_Epsilon. However, for tests - -- where the expected result is only known to a certain - -- amount of precision this bound takes on a non-zero - -- value to account for that level of precision. - Error_Low_Bound : Real := 0.0; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon - -- instead of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - -- take into account the low bound on the error - if Max_Error < Error_Low_Bound then - Max_Error := Error_Low_Bound; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Argument_Range_Check_1 (A, B : Real; - Test : String) is - -- test a evenly distributed selection of - -- arguments selected from the range A to B. - -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V) - -- The parameter One_Minus_Exp_Minus_V is the value - -- 1.0 - Exp (-V) - -- accurate to machine precision. - -- This procedure is a translation of part of Cody's test - X : Real; - Y : Real; - ZX, ZY : Real; - V : constant := 1.0 / 16.0; - One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2; - - begin - Accuracy_Error_Reported := False; - for I in 1..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - Y := X - V; - if Y < 0.0 then - X := Y + V; - end if; - - ZX := Exp (X); - ZY := Exp (Y); - - -- ZX := Exp(X) - Exp(X) * (1 - Exp(-V); - -- which simplifies to ZX := Exp (X-V); - ZX := ZX - ZX * One_Minus_Exp_Minus_V; - - -- note that since the expected value is computed, we - -- must take the error in that computation into account. - Check (ZY, ZX, - "test " & Test & " -" & - Integer'Image (I) & - " exp (" & Real'Image (X) & ")", - 9.0); - exit when Accuracy_Error_Reported; - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in argument range check 1"); - when others => - Report.Failed ("exception in argument range check 1"); - end Argument_Range_Check_1; - - - - procedure Argument_Range_Check_2 (A, B : Real; - Test : String) is - -- test a evenly distributed selection of - -- arguments selected from the range A to B. - -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V) - -- The parameter One_Minus_Exp_Minus_V is the value - -- 1.0 - Exp (-V) - -- accurate to machine precision. - -- This procedure is a translation of part of Cody's test - X : Real; - Y : Real; - ZX, ZY : Real; - V : constant := 45.0 / 16.0; - -- 1/16 - Exp(45/16) - Coeff : constant := 2.4453321046920570389E-3; - - begin - Accuracy_Error_Reported := False; - for I in 1..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - Y := X - V; - if Y < 0.0 then - X := Y + V; - end if; - - ZX := Exp (X); - ZY := Exp (Y); - - -- ZX := Exp(X) * 1/16 - Exp(X) * Coeff; - -- where Coeff is 1/16 - Exp(45/16) - -- which simplifies to ZX := Exp (X-V); - ZX := ZX * 0.0625 - ZX * Coeff; - - -- note that since the expected value is computed, we - -- must take the error in that computation into account. - Check (ZY, ZX, - "test " & Test & " -" & - Integer'Image (I) & - " exp (" & Real'Image (X) & ")", - 9.0); - exit when Accuracy_Error_Reported; - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in argument range check 2"); - when others => - Report.Failed ("exception in argument range check 2"); - end Argument_Range_Check_2; - - - procedure Do_Test is - begin - - --- test 1 --- - declare - Y : Real; - begin - Y := Exp(1.0); - -- normal accuracy requirements - Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 1"); - when others => - Report.Failed ("exception in test 1"); - end; - - --- test 2 --- - declare - Y : Real; - begin - Y := Exp(16.0) * Exp(-16.0); - Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 2"); - when others => - Report.Failed ("exception in test 2"); - end; - - --- test 3 --- - declare - Y : Real; - begin - Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi); - Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 3"); - when others => - Report.Failed ("exception in test 3"); - end; - - --- test 4 --- - declare - Y : Real; - begin - Y := Exp(0.0); - Check (Y, 1.0, "test 4 -- exp(0.0)", - 0.0); -- no error allowed - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 4"); - when others => - Report.Failed ("exception in test 4"); - end; - - --- test 5 --- - -- constants used here only have 19 digits of precision - if Real'Digits > 19 then - Error_Low_Bound := 0.00000_00000_00000_0001; - Report.Comment ("exp accuracy checked to 19 digits"); - end if; - - Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)), - 1.0, - "5"); - Error_Low_Bound := 0.0; -- reset - - --- test 6 --- - -- constants used here only have 19 digits of precision - if Real'Digits > 19 then - Error_Low_Bound := 0.00000_00000_00000_0001; - Report.Comment ("exp accuracy checked to 19 digits"); - end if; - - Argument_Range_Check_2 (1.0, - Sqrt(Real(Real'Machine_Radix)), - "6"); - Error_Low_Bound := 0.0; -- reset - - end Do_Test; - end A_Long_Float_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - package Non_Generic_Check is - procedure Do_Test; - subtype Real is Float; - end Non_Generic_Check; - - package body Non_Generic_Check is - - package Elementary_Functions renames - Ada.Numerics.Elementary_Functions; - function Sqrt (X : Real) return Real renames - Elementary_Functions.Sqrt; - function Exp (X : Real) return Real renames - Elementary_Functions.Exp; - - - -- The following value is a lower bound on the accuracy - -- required. It is normally 0.0 so that the lower bound - -- is computed from Model_Epsilon. However, for tests - -- where the expected result is only known to a certain - -- amount of precision this bound takes on a non-zero - -- value to account for that level of precision. - Error_Low_Bound : Real := 0.0; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon - -- instead of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - -- take into account the low bound on the error - if Max_Error < Error_Low_Bound then - Max_Error := Error_Low_Bound; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Argument_Range_Check_1 (A, B : Real; - Test : String) is - -- test a evenly distributed selection of - -- arguments selected from the range A to B. - -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V) - -- The parameter One_Minus_Exp_Minus_V is the value - -- 1.0 - Exp (-V) - -- accurate to machine precision. - -- This procedure is a translation of part of Cody's test - X : Real; - Y : Real; - ZX, ZY : Real; - V : constant := 1.0 / 16.0; - One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2; - - begin - Accuracy_Error_Reported := False; - for I in 1..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - Y := X - V; - if Y < 0.0 then - X := Y + V; - end if; - - ZX := Exp (X); - ZY := Exp (Y); - - -- ZX := Exp(X) - Exp(X) * (1 - Exp(-V); - -- which simplifies to ZX := Exp (X-V); - ZX := ZX - ZX * One_Minus_Exp_Minus_V; - - -- note that since the expected value is computed, we - -- must take the error in that computation into account. - Check (ZY, ZX, - "test " & Test & " -" & - Integer'Image (I) & - " exp (" & Real'Image (X) & ")", - 9.0); - exit when Accuracy_Error_Reported; - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in argument range check 1"); - when others => - Report.Failed ("exception in argument range check 1"); - end Argument_Range_Check_1; - - - - procedure Argument_Range_Check_2 (A, B : Real; - Test : String) is - -- test a evenly distributed selection of - -- arguments selected from the range A to B. - -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V) - -- The parameter One_Minus_Exp_Minus_V is the value - -- 1.0 - Exp (-V) - -- accurate to machine precision. - -- This procedure is a translation of part of Cody's test - X : Real; - Y : Real; - ZX, ZY : Real; - V : constant := 45.0 / 16.0; - -- 1/16 - Exp(45/16) - Coeff : constant := 2.4453321046920570389E-3; - - begin - Accuracy_Error_Reported := False; - for I in 1..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - Y := X - V; - if Y < 0.0 then - X := Y + V; - end if; - - ZX := Exp (X); - ZY := Exp (Y); - - -- ZX := Exp(X) * 1/16 - Exp(X) * Coeff; - -- where Coeff is 1/16 - Exp(45/16) - -- which simplifies to ZX := Exp (X-V); - ZX := ZX * 0.0625 - ZX * Coeff; - - -- note that since the expected value is computed, we - -- must take the error in that computation into account. - Check (ZY, ZX, - "test " & Test & " -" & - Integer'Image (I) & - " exp (" & Real'Image (X) & ")", - 9.0); - exit when Accuracy_Error_Reported; - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in argument range check 2"); - when others => - Report.Failed ("exception in argument range check 2"); - end Argument_Range_Check_2; - - - procedure Do_Test is - begin - - --- test 1 --- - declare - Y : Real; - begin - Y := Exp(1.0); - -- normal accuracy requirements - Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 1"); - when others => - Report.Failed ("exception in test 1"); - end; - - --- test 2 --- - declare - Y : Real; - begin - Y := Exp(16.0) * Exp(-16.0); - Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 2"); - when others => - Report.Failed ("exception in test 2"); - end; - - --- test 3 --- - declare - Y : Real; - begin - Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi); - Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 3"); - when others => - Report.Failed ("exception in test 3"); - end; - - --- test 4 --- - declare - Y : Real; - begin - Y := Exp(0.0); - Check (Y, 1.0, "test 4 -- exp(0.0)", - 0.0); -- no error allowed - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 4"); - when others => - Report.Failed ("exception in test 4"); - end; - - --- test 5 --- - -- constants used here only have 19 digits of precision - if Real'Digits > 19 then - Error_Low_Bound := 0.00000_00000_00000_0001; - Report.Comment ("exp accuracy checked to 19 digits"); - end if; - - Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)), - 1.0, - "5"); - Error_Low_Bound := 0.0; -- reset - - --- test 6 --- - -- constants used here only have 19 digits of precision - if Real'Digits > 19 then - Error_Low_Bound := 0.00000_00000_00000_0001; - Report.Comment ("exp accuracy checked to 19 digits"); - end if; - - Argument_Range_Check_2 (1.0, - Sqrt(Real(Real'Machine_Radix)), - "6"); - Error_Low_Bound := 0.0; -- reset - - end Do_Test; - end Non_Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - -begin - Report.Test ("CXG2010", - "Check the accuracy of the exp function"); - - -- the test only applies to machines with a radix of 2,4,8, or 16 - case Float'Machine_Radix is - when 2 | 4 | 8 | 16 => null; - when others => - Report.Not_Applicable ("only applicable to binary radix"); - Report.Result; - return; - end case; - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking non-generic package"); - end if; - - Non_Generic_Check.Do_Test; - - Report.Result; -end CXG2010; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a deleted file mode 100644 index 2c018b1321e..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a +++ /dev/null @@ -1,490 +0,0 @@ --- CXG2011.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 log function returns --- results that are within the error bound allowed. --- --- TEST DESCRIPTION: --- This test consists of a generic package that is --- instantiated to check both Float and a long float type. --- The test for each floating point type is divided into --- several parts: --- Special value checks where the result is a known constant. --- Checks in a range where a Taylor series can be used to compute --- the expected result. --- Checks that use an identity for determining the result. --- Exception checks. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 1 Mar 96 SAIC Initial release for 2.1 --- 22 Aug 96 SAIC Improved Check routine --- 02 DEC 97 EDS Log (0.0) must raise Constraint_Error, --- not Argument_Error ---! - --- --- References: --- --- Software Manual for the Elementary Functions --- William J. Cody, Jr. and William Waite --- Prentice-Hall, 1980 --- --- CRC Standard Mathematical Tables --- 23rd Edition --- --- Implementation and Testing of Function Software --- W. J. Cody --- Problems and Methodologies in Mathematical Software Production --- editors P. C. Messina and A. Murli --- Lecture Notes in Computer Science Volume 142 --- Springer Verlag, 1982 --- - -with System; -with Report; -with Ada.Numerics.Generic_Elementary_Functions; -procedure CXG2011 is - Verbose : constant Boolean := False; - Max_Samples : constant := 1000; - - -- CRC Handbook Page 738 - Ln10 : constant := 2.30258_50929_94045_68401_79914_54684_36420_76011_01489; - Ln2 : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755_00134; - - generic - type Real is digits <>; - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Elementary_Functions is new - Ada.Numerics.Generic_Elementary_Functions (Real); - function Sqrt (X : Real'Base) return Real'Base renames - Elementary_Functions.Sqrt; - function Exp (X : Real'Base) return Real'Base renames - Elementary_Functions.Exp; - function Log (X : Real'Base) return Real'Base renames - Elementary_Functions.Log; - function Log (X, Base : Real'Base) return Real'Base renames - Elementary_Functions.Log; - - -- flag used to terminate some tests early - Accuracy_Error_Reported : Boolean := False; - - - -- The following value is a lower bound on the accuracy - -- required. It is normally 0.0 so that the lower bound - -- is computed from Model_Epsilon. However, for tests - -- where the expected result is only known to a certain - -- amount of precision this bound takes on a non-zero - -- value to account for that level of precision. - Error_Low_Bound : Real := 0.0; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon - -- instead of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - -- take into account the low bound on the error - if Max_Error < Error_Low_Bound then - Max_Error := Error_Low_Bound; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Special_Value_Test is - begin - - --- test 1 --- - declare - Y : Real; - begin - Y := Log(1.0); - Check (Y, 0.0, "special value test 1 -- log(1)", - 0.0); -- no error allowed - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 1"); - when others => - Report.Failed ("exception in test 1"); - end; - - --- test 2 --- - declare - Y : Real; - begin - Y := Log(10.0); - Check (Y, Ln10, "special value test 2 -- log(10)", 4.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 2"); - when others => - Report.Failed ("exception in test 2"); - end; - - --- test 3 --- - declare - Y : Real; - begin - Y := Log (2.0); - Check (Y, Ln2, "special value test 3 -- log(2)", 4.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 3"); - when others => - Report.Failed ("exception in test 3"); - end; - - --- test 4 --- - declare - Y : Real; - begin - Y := Log (2.0 ** 18, 2.0); - Check (Y, 18.0, "special value test 4 -- log(2**18,2)", 4.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in test 4"); - when others => - Report.Failed ("exception in test 4"); - end; - end Special_Value_Test; - - - procedure Taylor_Series_Test is - -- Use a 4 term taylor series expansion to check a selection of - -- arguments very near 1.0. - -- The range is chosen so that the 4 term taylor series will - -- provide accuracy to machine precision. Cody pg 49-50. - Half_Range : constant Real := Real'Model_Epsilon * 50.0; - A : constant Real := 1.0 - Half_Range; - B : constant Real := 1.0 + Half_Range; - X : Real; - Xm1 : Real; - Expected : Real; - Actual : Real; - - begin - Accuracy_Error_Reported := False; -- reset - for I in 1..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - - Xm1 := X - 1.0; - -- The following is the first 4 terms of the taylor series - -- that has been rearranged to minimize error in the calculation - Expected := (Xm1 * (1.0/3.0 - Xm1/4.0) - 0.5) * Xm1 * Xm1 + Xm1; - - Actual := Log (X); - Check (Actual, Expected, - "Taylor Series Test -" & - Integer'Image (I) & - " log (" & Real'Image (X) & ")", - 4.0); - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Taylor Series Test"); - when others => - Report.Failed ("exception in Taylor Series Test"); - end Taylor_Series_Test; - - - - procedure Log_Difference_Identity is - -- Check using the identity ln(x) = ln(17x/16) - ln(17/16) - -- over the range A to B. - -- The selected range assures that both X and 17x/16 will - -- have the same exponents and neither argument gets too close - -- to 1. Cody pg 50. - A : constant Real := 1.0 / Sqrt (2.0); - B : constant Real := 15.0 / 16.0; - X : Real; - Expected : Real; - Actual : Real; - begin - Accuracy_Error_Reported := False; -- reset - for I in 1..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - -- magic argument purification - X := Real'Machine (Real'Machine (X+8.0) - 8.0); - - Expected := Log (X + X / 16.0) - Log (17.0/16.0); - - Actual := Log (X); - Check (Actual, Expected, - "Log Difference Identity -" & - Integer'Image (I) & - " log (" & Real'Image (X) & ")", - 4.0); - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Log Difference Identity Test"); - when others => - Report.Failed ("exception in Log Difference Identity Test"); - end Log_Difference_Identity; - - - procedure Log_Product_Identity is - -- Check using the identity ln(x**2) = 2ln(x) - -- over the range A to B. - -- This large range is chosen to minimize the possibility of - -- undetected systematic errors. Cody pg 53. - A : constant Real := 16.0; - B : constant Real := 240.0; - X : Real; - Expected : Real; - Actual : Real; - begin - Accuracy_Error_Reported := False; -- reset - for I in 1..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - -- magic argument purification - X := Real'Machine (Real'Machine (X+8.0) - 8.0); - - Expected := 2.0 * Log (X); - - Actual := Log (X*X); - Check (Actual, Expected, - "Log Product Identity -" & - Integer'Image (I) & - " log (" & Real'Image (X) & ")", - 4.0); - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Log Product Identity Test"); - when others => - Report.Failed ("exception in Log Product Identity Test"); - end Log_Product_Identity; - - - procedure Log10_Test is - -- Check using the identity log(x) = log(11x/10) - log(1.1) - -- over the range A to B. See Cody pg 52. - A : constant Real := 1.0 / Sqrt (10.0); - B : constant Real := 0.9; - X : Real; - Expected : Real; - Actual : Real; - begin - if Real'Digits > 17 then - -- constant used below is accuract to 17 digits - Error_Low_Bound := 0.00000_00000_00000_01; - Report.Comment ("log accuracy checked to 19 digits"); - end if; - Accuracy_Error_Reported := False; -- reset - for I in 1..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - - Expected := Log (X + X/10.0, 10.0) - - 3.77060_15822_50407_5E-4 - 21.0 / 512.0; - - Actual := Log (X, 10.0); - Check (Actual, Expected, - "Log 10 Test -" & - Integer'Image (I) & - " log (" & Real'Image (X) & ")", - 4.0); - - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - exit when Accuracy_Error_Reported; - end loop; - Error_Low_Bound := 0.0; -- reset - - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Log 10 Test"); - when others => - Report.Failed ("exception in Log 10 Test"); - end Log10_Test; - - - procedure Exception_Test is - X1, X2, X3, X4 : Real; - begin - begin - X1 := Log (0.0); - Report.Failed ("exception not raised for LOG(0)"); - exception - -- Log (0.0) must raise Constraint_Error, not Argument_Error, - -- as per A.5.1(28,29). Was incorrect in ACVC 2.1 release. - when Ada.Numerics.Argument_Error => - Report.Failed ("Argument_Error raised instead of" & - " Constraint_Error for LOG(0)--A.5.1(28,29)"); - when Constraint_Error => null; -- ok - when others => - Report.Failed ("wrong exception raised for LOG(0)"); - end; - - begin - X2 := Log ( 1.0, 0.0); - Report.Failed ("exception not raised for LOG(1,0)"); - exception - when Ada.Numerics.Argument_Error => null; -- ok - when Constraint_Error => - Report.Failed ("constraint_error raised instead of" & - " argument_error for LOG(1,0)"); - when others => - Report.Failed ("wrong exception raised for LOG(1,0)"); - end; - - begin - X3 := Log (1.0, 1.0); - Report.Failed ("exception not raised for LOG(1,1)"); - exception - when Ada.Numerics.Argument_Error => null; -- ok - when Constraint_Error => - Report.Failed ("constraint_error raised instead of" & - " argument_error for LOG(1,1)"); - when others => - Report.Failed ("wrong exception raised for LOG(1,1)"); - end; - - begin - X4 := Log (1.0, -10.0); - Report.Failed ("exception not raised for LOG(1,-10)"); - exception - when Ada.Numerics.Argument_Error => null; -- ok - when Constraint_Error => - Report.Failed ("constraint_error raised instead of" & - " argument_error for LOG(1,-10)"); - when others => - Report.Failed ("wrong exception raised for LOG(1,-10)"); - end; - - -- optimizer thwarting - if Report.Ident_Bool (False) then - Report.Comment (Real'Image (X1+X2+X3+X4)); - end if; - end Exception_Test; - - - procedure Do_Test is - begin - Special_Value_Test; - Taylor_Series_Test; - Log_Difference_Identity; - Log_Product_Identity; - Log10_Test; - Exception_Test; - end Do_Test; - end Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - package Float_Check is new Generic_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package A_Long_Float_Check is new Generic_Check (A_Long_Float); - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - -begin - Report.Test ("CXG2011", - "Check the accuracy of the log function"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - - Report.Result; -end CXG2011; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a deleted file mode 100644 index 6a665d0e077..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a +++ /dev/null @@ -1,438 +0,0 @@ --- CXG2012.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 exponentiation operator returns --- results that are within the error bound allowed. --- --- TEST DESCRIPTION: --- This test consists of a generic package that is --- instantiated to check both Float and a long float type. --- The test for each floating point type is divided into --- several parts: --- Special value checks where the result is a known constant. --- Checks that use an identity for determining the result. --- Exception checks. --- While this test concentrates on the "**" operator --- defined in Generic_Elementary_Functions, a check is also --- performed on the standard "**" operator. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 7 Mar 96 SAIC Initial release for 2.1 --- 2 Sep 96 SAIC Improvements as suggested by reviewers --- 3 Jun 98 EDS Add parens to ensure that the expression is not --- evaluated by multiplying its two large terms --- together and overflowing. --- 3 Dec 01 RLB Added 'Machine to insure that equality tests --- are certain to work. --- ---! - --- --- References: --- --- Software Manual for the Elementary Functions --- William J. Cody, Jr. and William Waite --- Prentice-Hall, 1980 --- --- CRC Standard Mathematical Tables --- 23rd Edition --- --- Implementation and Testing of Function Software --- W. J. Cody --- Problems and Methodologies in Mathematical Software Production --- editors P. C. Messina and A. Murli --- Lecture Notes in Computer Science Volume 142 --- Springer Verlag, 1982 --- - -with System; -with Report; -with Ada.Numerics.Generic_Elementary_Functions; -procedure CXG2012 is - Verbose : constant Boolean := False; - Max_Samples : constant := 1000; - - -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 - Sqrt2 : constant := - 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; - Sqrt3 : constant := - 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; - - - generic - type Real is digits <>; - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Elementary_Functions is new - Ada.Numerics.Generic_Elementary_Functions (Real); - function Sqrt (X : Real) return Real renames - Elementary_Functions.Sqrt; - function Exp (X : Real) return Real renames - Elementary_Functions.Exp; - function Log (X : Real) return Real renames - Elementary_Functions.Log; - function "**" (L, R : Real) return Real renames - Elementary_Functions."**"; - - -- flag used to terminate some tests early - Accuracy_Error_Reported : Boolean := False; - - - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon - -- instead of Model_Epsilon and Expected. - Rel_Error := MRE * (abs Expected * Real'Model_Epsilon); - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - -- the following version of Check computes the allowed error bound - -- using the operands - procedure Check (Actual, Expected : Real; - Left, Right : Real; - Test_Name : String; - MRE_Factor : Real := 1.0) is - MRE : Real; - begin - MRE := MRE_Factor * (4.0 + abs (Right * Log(Left)) / 32.0); - Check (Actual, Expected, Test_Name, MRE); - end Check; - - - procedure Real_To_Integer_Test is - type Int_Check is - record - Left : Real; - Right : Integer; - Expected : Real; - end record; - type Int_Checks is array (Positive range <>) of Int_Check; - - -- the following tests use only model numbers so the result - -- is expected to be exact. - IC : constant Int_Checks := - ( ( 2.0, 5, 32.0), - ( -2.0, 5, -32.0), - ( 0.5, -5, 32.0), - ( 2.0, 0, 1.0), - ( 0.0, 0, 1.0) ); - begin - for I in IC'Range loop - declare - Y : Real; - begin - Y := IC (I).Left ** IC (I).Right; - Check (Y, IC (I).Expected, - "real to integer test" & - Real'Image (IC (I).Left) & " ** " & - Integer'Image (IC (I).Right), - 0.0); -- no error allowed - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in rtoi test " & - Integer'Image (I)); - when others => - Report.Failed ("exception in rtoi test " & - Integer'Image (I)); - end; - end loop; - end Real_To_Integer_Test; - - - procedure Special_Value_Test is - No_Error : constant := 0.0; - begin - Check (0.0 ** 1.0, 0.0, "0**1", No_Error); - Check (1.0 ** 0.0, 1.0, "1**0", No_Error); - - Check ( 2.0 ** 5.0, 32.0, 2.0, 5.0, "2**5"); - Check ( 0.5**(-5.0), 32.0, 0.5, -5.0, "0.5**-5"); - - Check (Sqrt2 ** 4.0, 4.0, Sqrt2, 4.0, "Sqrt2**4"); - Check (Sqrt3 ** 6.0, 27.0, Sqrt3, 6.0, "Sqrt3**6"); - - Check (2.0 ** 0.5, Sqrt2, 2.0, 0.5, "2.0**0.5"); - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Special Value Test"); - when others => - Report.Failed ("exception in Special Value Test"); - end Special_Value_Test; - - - procedure Small_Range_Test is - -- Several checks over the range 1/radix .. 1 - A : constant Real := 1.0 / Real (Real'Machine_Radix); - B : constant Real := 1.0; - X : Real; - -- In the cases below where the expected result is - -- inexact we allow an additional error amount of - -- 1.0 * Model_Epsilon to account for that error. - -- This is accomplished by the factor of 1.25 times - -- the computed error bound (which is > 4.0) thus - -- increasing the error bound by at least - -- 1.0 * Model_Epsilon - begin - Accuracy_Error_Reported := False; -- reset - for I in 0..Max_Samples loop - X := Real'Machine((B - A) * Real (I) / Real (Max_Samples) + A); - - Check (X ** 1.0, X, -- exact result required - "Small range" & Integer'Image (I) & ": " & - Real'Image (X) & " ** 1.0", - 0.0); - - Check ((X*X) ** 1.5, X**3, X*X, 1.5, - "Small range" & Integer'Image (I) & ": " & - Real'Image (X*X) & " ** 1.5", - 1.25); - - Check (X ** 13.5, 1.0 / (X ** (-13.5)), X, 13.5, - "Small range" & Integer'Image (I) & ": " & - Real'Image (X) & " ** 13.5", - 2.0); -- 2 ** computations - - Check ((X*X) ** 1.25, X**(2.5), X*X, 1.25, - "Small range" & Integer'Image (I) & ": " & - Real'Image (X*X) & " ** 1.25", - 2.0); -- 2 ** computations - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - - end loop; - - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Small Range Test"); - when others => - Report.Failed ("exception in Small Range Test"); - end Small_Range_Test; - - - procedure Large_Range_Test is - -- Check over the range A to B where A is 1.0 and - -- B is a large value. - A : constant Real := 1.0; - B : Real; - X : Real; - Iteration : Integer := 0; - Subtest : Character := 'X'; - begin - -- upper bound of range should be as large as possible where - -- B**3 is still valid. - B := Real'Safe_Last ** 0.333; - Accuracy_Error_Reported := False; -- reset - for I in 0..Max_Samples loop - Iteration := I; - Subtest := 'X'; - X := Real'Machine((B - A) * (Real (I) / Real (Max_Samples)) + A); - - Subtest := 'A'; - Check (X ** 1.0, X, -- exact result required - "Large range" & Integer'Image (I) & ": " & - Real'Image (X) & " ** 1.0", - 0.0); - - Subtest := 'B'; - Check ((X*X) ** 1.5, X**3, X*X, 1.5, - "Large range" & Integer'Image (I) & ": " & - Real'Image (X*X) & " ** 1.5", - 1.25); -- inexact expected result - - Subtest := 'C'; - Check ((X*X) ** 1.25, X**(2.5), X*X, 1.25, - "Large range" & Integer'Image (I) & ": " & - Real'Image (X*X) & " ** 1.25", - 2.0); -- two ** operators - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - - end loop; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Large Range Test" & - Integer'Image (Iteration) & Subtest); - when others => - Report.Failed ("exception in Large Range Test" & - Integer'Image (Iteration) & Subtest); - end Large_Range_Test; - - - procedure Exception_Test is - X1, X2, X3, X4 : Real; - begin - begin - X1 := 0.0 ** (-1.0); - Report.Failed ("exception not raised for 0**-1"); - exception - when Ada.Numerics.Argument_Error => - Report.Failed ("argument_error raised instead of" & - " constraint_error for 0**-1"); - when Constraint_Error => null; -- ok - when others => - Report.Failed ("wrong exception raised for 0**-1"); - end; - - begin - X2 := 0.0 ** 0.0; - Report.Failed ("exception not raised for 0**0"); - exception - when Ada.Numerics.Argument_Error => null; -- ok - when Constraint_Error => - Report.Failed ("constraint_error raised instead of" & - " argument_error for 0**0"); - when others => - Report.Failed ("wrong exception raised for 0**0"); - end; - - begin - X3 := (-1.0) ** 1.0; - Report.Failed ("exception not raised for -1**1"); - exception - when Ada.Numerics.Argument_Error => null; -- ok - when Constraint_Error => - Report.Failed ("constraint_error raised instead of" & - " argument_error for -1**1"); - when others => - Report.Failed ("wrong exception raised for -1**1"); - end; - - begin - X4 := (-2.0) ** 2.0; - Report.Failed ("exception not raised for -2**2"); - exception - when Ada.Numerics.Argument_Error => null; -- ok - when Constraint_Error => - Report.Failed ("constraint_error raised instead of" & - " argument_error for -2**2"); - when others => - Report.Failed ("wrong exception raised for -2**2"); - end; - - -- optimizer thwarting - if Report.Ident_Bool (False) then - Report.Comment (Real'Image (X1+X2+X3+X4)); - end if; - end Exception_Test; - - - procedure Do_Test is - begin - Real_To_Integer_Test; - Special_Value_Test; - Small_Range_Test; - Large_Range_Test; - Exception_Test; - end Do_Test; - end Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - package Float_Check is new Generic_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package A_Long_Float_Check is new Generic_Check (A_Long_Float); - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - -begin - Report.Test ("CXG2012", - "Check the accuracy of the ** operator"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - - Report.Result; -end CXG2012; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a deleted file mode 100644 index 94f180b804d..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a +++ /dev/null @@ -1,367 +0,0 @@ --- CXG2013.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 TAN and COT functions return --- results that are within the error bound allowed. --- --- TEST DESCRIPTION: --- This test consists of a generic package that is --- instantiated to check both Float and a long float type. --- The test for each floating point type is divided into --- several parts: --- Special value checks where the result is a known constant. --- Checks that use an identity for determining the result. --- Exception checks. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 11 Mar 96 SAIC Initial release for 2.1 --- 17 Aug 96 SAIC Commentary fixes. --- 03 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi --- 02 DEC 97 EDS Change Max_Samples constant to 1001. --- 29 JUN 98 EDS Deleted Special_Angle_Test as fatally flawed. - ---! - --- --- References: --- --- Software Manual for the Elementary Functions --- William J. Cody, Jr. and William Waite --- Prentice-Hall, 1980 --- --- CRC Standard Mathematical Tables --- 23rd Edition --- --- Implementation and Testing of Function Software --- W. J. Cody --- Problems and Methodologies in Mathematical Software Production --- editors P. C. Messina and A. Murli --- Lecture Notes in Computer Science Volume 142 --- Springer Verlag, 1982 --- - -with System; -with Report; -with Ada.Numerics.Generic_Elementary_Functions; -procedure CXG2013 is - Verbose : constant Boolean := False; - Max_Samples : constant := 1001; - - -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 - Sqrt2 : constant := - 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; - Sqrt3 : constant := - 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; - - Pi : constant := Ada.Numerics.Pi; - - generic - type Real is digits <>; - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Elementary_Functions is new - Ada.Numerics.Generic_Elementary_Functions (Real); - function Sqrt (X : Real) return Real renames - Elementary_Functions.Sqrt; - function Tan (X : Real) return Real renames - Elementary_Functions.Tan; - function Cot (X : Real) return Real renames - Elementary_Functions.Cot; - function Tan (X, Cycle : Real) return Real renames - Elementary_Functions.Tan; - function Cot (X, Cycle : Real) return Real renames - Elementary_Functions.Cot; - - -- flag used to terminate some tests early - Accuracy_Error_Reported : Boolean := False; - - -- factor to be applied in computing MRE - Maximum_Relative_Error : constant Real := 4.0; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - - procedure Exact_Result_Test is - No_Error : constant := 0.0; - begin - -- A.5.1(38);6.0 - Check (Tan (0.0), 0.0, "tan(0)", No_Error); - - -- A.5.1(41);6.0 - Check (Tan (180.0, 360.0), 0.0, "tan(180,360)", No_Error); - Check (Tan (360.0, 360.0), 0.0, "tan(360,360)", No_Error); - Check (Tan (720.0, 360.0), 0.0, "tan(720,360)", No_Error); - - -- A.5.1(41);6.0 - Check (Cot ( 90.0, 360.0), 0.0, "cot( 90,360)", No_Error); - Check (Cot (270.0, 360.0), 0.0, "cot(270,360)", No_Error); - Check (Cot (810.0, 360.0), 0.0, "cot(810,360)", No_Error); - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Exact_Result Test"); - when others => - Report.Failed ("exception in Exact_Result Test"); - end Exact_Result_Test; - - - procedure Tan_Test (A, B : Real) is - -- Use identity Tan(X) = [2*Tan(x/2)]/[1-Tan(x/2) ** 2] - -- checks over the range -pi/4 .. pi/4 require no argument reduction - -- checks over the range 7pi/8 .. 9pi/8 require argument reduction - X, Y : Real; - Actual1, Actual2 : Real; - begin - Accuracy_Error_Reported := False; -- reset - for I in 1..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - -- argument purification to insure x and x/2 are exact - -- See Cody page 170. - Y := Real'Machine (X*0.5); - X := Real'Machine (Y + Y); - - Actual1 := Tan(X); - Actual2 := (2.0 * Tan (Y)) / (1.0 - Tan (Y) ** 2); - - if abs (X - Pi) > ( (B-A)/Real(2*Max_Samples) ) then - Check (Actual1, Actual2, - "Tan_Test " & Integer'Image (I) & ": tan(" & - Real'Image (X) & ") ", - (1.0 + Sqrt2) * Maximum_Relative_Error); - -- see Cody pg 165 for error bound info - end if; - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - - end loop; - - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Tan_Test"); - when others => - Report.Failed ("exception in Tan_Test"); - end Tan_Test; - - - - procedure Cot_Test is - -- Use identity Cot(X) = [Cot(X/2)**2 - 1]/[2*Cot(X/2)] - A : constant := 6.0 * Pi; - B : constant := 25.0 / 4.0 * Pi; - X, Y : Real; - Actual1, Actual2 : Real; - begin - Accuracy_Error_Reported := False; -- reset - for I in 1..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - -- argument purification to insure x and x/2 are exact. - -- See Cody page 170. - Y := Real'Machine (X*0.5); - X := Real'Machine (Y + Y); - - Actual1 := Cot(X); - Actual2 := (Cot (Y) ** 2 - 1.0) / (2.0 * Cot (Y)); - - Check (Actual1, Actual2, - "Cot_Test " & Integer'Image (I) & ": cot(" & - Real'Image (X) & ") ", - (1.0 + Sqrt2) * Maximum_Relative_Error); - -- see Cody pg 165 for error bound info - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - - end loop; - - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Cot_Test"); - when others => - Report.Failed ("exception in Cot_Test"); - end Cot_Test; - - - procedure Exception_Test is - X1, X2, X3, X4, X5 : Real := 0.0; - begin - - - begin -- A.5.1(20);6.0 - X1 := Tan (0.0, Cycle => 0.0); - Report.Failed ("no exception for cycle = 0.0"); - exception - when Ada.Numerics.Argument_Error => null; - when others => - Report.Failed ("wrong exception for cycle = 0.0"); - end; - - begin -- A.5.1(20);6.0 - X2 := Cot (1.0, Cycle => -3.0); - Report.Failed ("no exception for cycle < 0.0"); - exception - when Ada.Numerics.Argument_Error => null; - when others => - Report.Failed ("wrong exception for cycle < 0.0"); - end; - - -- the remaining tests only apply to machines that overflow - if Real'Machine_Overflows then -- A.5.1(28);6.0 - - begin -- A.5.1(29);6.0 - X3 := Cot (0.0); - Report.Failed ("exception not raised for cot(0)"); - exception - when Constraint_Error => null; -- ok - when others => - Report.Failed ("wrong exception raised for cot(0)"); - end; - - begin -- A.5.1(31);6.0 - X4 := Tan (90.0, 360.0); - Report.Failed ("exception not raised for tan(90,360)"); - exception - when Constraint_Error => null; -- ok - when others => - Report.Failed ("wrong exception raised for tan(90,360)"); - end; - - begin -- A.5.1(32);6.0 - X5 := Cot (180.0, 360.0); - Report.Failed ("exception not raised for cot(180,360)"); - exception - when Constraint_Error => null; -- ok - when others => - Report.Failed ("wrong exception raised for cot(180,360)"); - end; - end if; - - -- optimizer thwarting - if Report.Ident_Bool (False) then - Report.Comment (Real'Image (X1+X2+X3+X4+X5)); - end if; - end Exception_Test; - - - procedure Do_Test is - begin - Exact_Result_Test; - Tan_Test (-Pi/4.0, Pi/4.0); - Tan_Test (7.0*Pi/8.0, 9.0*Pi/8.0); - Cot_Test; - Exception_Test; - end Do_Test; - end Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - package Float_Check is new Generic_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package A_Long_Float_Check is new Generic_Check (A_Long_Float); - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - -begin - Report.Test ("CXG2013", - "Check the accuracy of the TAN and COT functions"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - - Report.Result; -end CXG2013; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a deleted file mode 100644 index 48499a2556f..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a +++ /dev/null @@ -1,399 +0,0 @@ --- CXG2014.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 SINH and COSH functions return --- results that are within the error bound allowed. --- --- TEST DESCRIPTION: --- This test consists of a generic package that is --- instantiated to check both Float and a long float type. --- The test for each floating point type is divided into --- several parts: --- Special value checks where the result is a known constant. --- Checks that use an identity for determining the result. --- Exception checks. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 15 Mar 96 SAIC Initial release for 2.1 --- 03 Jun 98 EDS In line 80, change 1000 to 1024, making it a model --- number. Add Taylor Series terms in line 281. --- 15 Feb 99 RLB Repaired Subtraction_Error_Test to avoid precision --- problems. ---! - --- --- References: --- --- Software Manual for the Elementary Functions --- William J. Cody, Jr. and William Waite --- Prentice-Hall, 1980 --- --- CRC Standard Mathematical Tables --- 23rd Edition --- --- Implementation and Testing of Function Software --- W. J. Cody --- Problems and Methodologies in Mathematical Software Production --- editors P. C. Messina and A. Murli --- Lecture Notes in Computer Science Volume 142 --- Springer Verlag, 1982 --- - -with System; -with Report; -with Ada.Numerics.Generic_Elementary_Functions; -procedure CXG2014 is - Verbose : constant Boolean := False; - Max_Samples : constant := 1024; - - E : constant := Ada.Numerics.E; - Cosh1 : constant := (E + 1.0 / E) / 2.0; -- cosh(1.0) - - generic - type Real is digits <>; - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Elementary_Functions is new - Ada.Numerics.Generic_Elementary_Functions (Real); - function Sinh (X : Real) return Real renames - Elementary_Functions.Sinh; - function Cosh (X : Real) return Real renames - Elementary_Functions.Cosh; - function Log (X : Real) return Real renames - Elementary_Functions.Log; - - -- flag used to terminate some tests early - Accuracy_Error_Reported : Boolean := False; - - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Small instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Small; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Special_Value_Test is - -- In the following tests the expected result is accurate - -- to the machine precision so the minimum guaranteed error - -- bound can be used. - Minimum_Error : constant := 8.0; - begin - Check (Sinh (1.0), - (E - 1.0 / E) / 2.0, - "sinh(1)", - Minimum_Error); - Check (Cosh (1.0), - Cosh1, - "cosh(1)", - Minimum_Error); - Check (Sinh (2.0), - (E * E - (1.0 / (E * E))) / 2.0, - "sinh(2)", - Minimum_Error); - Check (Cosh (2.0), - (E * E + (1.0 / (E * E))) / 2.0, - "cosh(2)", - Minimum_Error); - Check (Sinh (-1.0), - (1.0 / E - E) / 2.0, - "sinh(-1)", - Minimum_Error); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in special value test"); - when others => - Report.Failed ("exception in special value test"); - end Special_Value_Test; - - - - procedure Exact_Result_Test is - No_Error : constant := 0.0; - begin - -- A.5.1(38);6.0 - Check (Sinh (0.0), 0.0, "sinh(0)", No_Error); - Check (Cosh (0.0), 1.0, "cosh(0)", No_Error); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Exact_Result Test"); - when others => - Report.Failed ("exception in Exact_Result Test"); - end Exact_Result_Test; - - - procedure Identity_1_Test is - -- For the Sinh test use the identity - -- 2 * Sinh(x) * Cosh(1) = Sinh(x+1) + Sinh (x-1) - -- which is transformed to - -- Sinh(x) = ((Sinh(x+1) + Sinh(x-1)) * C - -- where C = 1/(2*Cosh(1)) - -- - -- For the Cosh test use the identity - -- 2 * Cosh(x) * Cosh(1) = Cosh(x+1) + Cosh(x-1) - -- which is transformed to - -- Cosh(x) = C * (Cosh(x+1) + Cosh(x-1)) - -- where C is the same as above - -- - -- see Cody pg 230-231 for details on the error analysis. - -- The net result is a relative error bound of 16 * Model_Epsilon. - - A : constant := 3.0; - -- large upper bound but not so large as to cause Cosh(B) - -- to overflow - B : constant Real := Log(Real'Safe_Last) - 2.0; - X_Minus_1, X, X_Plus_1 : Real; - Actual1, Actual2 : Real; - C : constant := 1.0 / (2.0 * Cosh1); - begin - Accuracy_Error_Reported := False; -- reset - for I in 1..Max_Samples loop - -- make sure there is no error in x-1, x, and x+1 - X_Plus_1 := (B - A) * Real (I) / Real (Max_Samples) + A; - X_Plus_1 := Real'Machine (X_Plus_1); - X := Real'Machine (X_Plus_1 - 1.0); - X_Minus_1 := Real'Machine (X - 1.0); - - -- Sinh(x) = ((Sinh(x+1) + Sinh(x-1)) * C - Actual1 := Sinh(X); - Actual2 := C * (Sinh(X_Plus_1) + Sinh(X_Minus_1)); - - Check (Actual1, Actual2, - "Identity_1_Test " & Integer'Image (I) & ": sinh(" & - Real'Image (X) & ") ", - 16.0); - - -- Cosh(x) = C * (Cosh(x+1) + Cosh(x-1)) - Actual1 := Cosh (X); - Actual2 := C * (Cosh(X_Plus_1) + Cosh (X_Minus_1)); - Check (Actual1, Actual2, - "Identity_1_Test " & Integer'Image (I) & ": cosh(" & - Real'Image (X) & ") ", - 16.0); - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - - end loop; - - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Identity_1_Test" & - " for X=" & Real'Image (X)); - when others => - Report.Failed ("exception in Identity_1_Test" & - " for X=" & Real'Image (X)); - end Identity_1_Test; - - - - procedure Subtraction_Error_Test is - -- This test detects the error resulting from subtraction if - -- the obvious algorithm was used for computing sinh. That is, - -- it it is computed as (e**x - e**-x)/2. - -- We check the result by using a Taylor series expansion that - -- will produce a result accurate to the machine precision for - -- the range under test. - -- - -- The maximum relative error bound for this test is - -- 8 for the sinh operation and 7 for the Taylor series - -- for a total of 15 * Model_Epsilon - A : constant := 0.0; - B : constant := 0.5; - X : Real; - X_Squared : Real; - Actual, Expected : Real; - begin - if Real'digits > 15 then - return; -- The approximation below is not accurate beyond - -- 15 digits. Adding more terms makes the error - -- larger, so it makes the test worse for more normal - -- values. Thus, we skip this subtest for larger than - -- 15 digits. - end if; - Accuracy_Error_Reported := False; -- reset - for I in 1..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - X_Squared := X * X; - - Actual := Sinh(X); - - -- The Taylor series regrouped a bit - Expected := - X * (1.0 + (X_Squared / 6.0) * - (1.0 + (X_Squared/20.0) * - (1.0 + (X_Squared/42.0) * - (1.0 + (X_Squared/72.0) * - (1.0 + (X_Squared/110.0) * - (1.0 + (X_Squared/156.0) - )))))); - - Check (Actual, Expected, - "Subtraction_Error_Test " & Integer'Image (I) & ": sinh(" & - Real'Image (X) & ") ", - 15.0); - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - - end loop; - - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Subtraction_Error_Test"); - when others => - Report.Failed ("exception in Subtraction_Error_Test"); - end Subtraction_Error_Test; - - - procedure Exception_Test is - X1, X2 : Real := 0.0; - begin - -- this part of the test is only applicable if 'Machine_Overflows - -- is true. - if Real'Machine_Overflows then - - begin - X1 := Sinh (Real'Safe_Last / 2.0); - Report.Failed ("no exception for sinh overflow"); - exception - when Constraint_Error => null; - when others => - Report.Failed ("wrong exception sinh overflow"); - end; - - begin - X2 := Cosh (Real'Safe_Last / 2.0); - Report.Failed ("no exception for cosh overflow"); - exception - when Constraint_Error => null; - when others => - Report.Failed ("wrong exception cosh overflow"); - end; - - end if; - - -- optimizer thwarting - if Report.Ident_Bool (False) then - Report.Comment (Real'Image (X1 + X2)); - end if; - end Exception_Test; - - - procedure Do_Test is - begin - Special_Value_Test; - Exact_Result_Test; - Identity_1_Test; - Subtraction_Error_Test; - Exception_Test; - end Do_Test; - end Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - package Float_Check is new Generic_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package A_Long_Float_Check is new Generic_Check (A_Long_Float); - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - -begin - Report.Test ("CXG2014", - "Check the accuracy of the SINH and COSH functions"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - - Report.Result; -end CXG2014; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a deleted file mode 100644 index 50fda5e1f4f..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a +++ /dev/null @@ -1,686 +0,0 @@ --- CXG2015.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 ARCSIN and ARCCOS functions return --- results that are within the error bound allowed. --- --- TEST DESCRIPTION: --- This test consists of a generic package that is --- instantiated to check both Float and a long float type. --- The test for each floating point type is divided into --- several parts: --- Special value checks where the result is a known constant. --- Checks in a specific range where a Taylor series can be --- used to compute an accurate result for comparison. --- Exception checks. --- The Taylor series tests are a direct translation of the --- FORTRAN code found in the reference. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 18 Mar 96 SAIC Initial release for 2.1 --- 24 Apr 96 SAIC Fixed error bounds. --- 17 Aug 96 SAIC Added reference information and improved --- checking for machines with more than 23 --- digits of precision. --- 03 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi --- 22 Dec 99 RLB Added model range checking to "exact" results, --- in order to avoid too strictly requiring a specific --- result, and too weakly checking results. --- --- CHANGE NOTE: --- According to Ken Dritz, author of the Numerics Annex of the RM, --- one should never specify the cycle 2.0*Pi for the trigonometric --- functions. In particular, if the machine number for the first --- argument is not an exact multiple of the machine number for the --- explicit cycle, then the specified exact results cannot be --- reasonably expected. The affected checks in this test have been --- marked as comments, with the additional notation "pwb-math". --- Phil Brashear ---! - --- --- References: --- --- Software Manual for the Elementary Functions --- William J. Cody, Jr. and William Waite --- Prentice-Hall, 1980 --- --- CRC Standard Mathematical Tables --- 23rd Edition --- --- Implementation and Testing of Function Software --- W. J. Cody --- Problems and Methodologies in Mathematical Software Production --- editors P. C. Messina and A. Murli --- Lecture Notes in Computer Science Volume 142 --- Springer Verlag, 1982 --- --- CELEFUNT: A Portable Test Package for Complex Elementary Functions --- ACM Collected Algorithms number 714 - -with System; -with Report; -with Ada.Numerics.Generic_Elementary_Functions; -procedure CXG2015 is - Verbose : constant Boolean := False; - Max_Samples : constant := 1000; - - - -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 - Sqrt2 : constant := - 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; - Sqrt3 : constant := - 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; - - Pi : constant := Ada.Numerics.Pi; - - -- relative error bound from G.2.4(7);6.0 - Minimum_Error : constant := 4.0; - - generic - type Real is digits <>; - Half_PI_Low : in Real; -- The machine number closest to, but not greater - -- than PI/2.0. - Half_PI_High : in Real;-- The machine number closest to, but not less - -- than PI/2.0. - PI_Low : in Real; -- The machine number closest to, but not greater - -- than PI. - PI_High : in Real; -- The machine number closest to, but not less - -- than PI. - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Elementary_Functions is new - Ada.Numerics.Generic_Elementary_Functions (Real); - - function Arcsin (X : Real) return Real renames - Elementary_Functions.Arcsin; - function Arcsin (X, Cycle : Real) return Real renames - Elementary_Functions.Arcsin; - function Arccos (X : Real) return Real renames - Elementary_Functions.ArcCos; - function Arccos (X, Cycle : Real) return Real renames - Elementary_Functions.ArcCos; - - -- needed for support - function Log (X, Base : Real) return Real renames - Elementary_Functions.Log; - - -- flag used to terminate some tests early - Accuracy_Error_Reported : Boolean := False; - - -- The following value is a lower bound on the accuracy - -- required. It is normally 0.0 so that the lower bound - -- is computed from Model_Epsilon. However, for tests - -- where the expected result is only known to a certain - -- amount of precision this bound takes on a non-zero - -- value to account for that level of precision. - Error_Low_Bound : Real := 0.0; - - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - -- take into account the low bound on the error - if Max_Error < Error_Low_Bound then - Max_Error := Error_Low_Bound; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Special_Value_Test is - -- In the following tests the expected result is accurate - -- to the machine precision so the minimum guaranteed error - -- bound can be used. - - type Data_Point is - record - Degrees, - Radians, - Argument, - Error_Bound : Real; - end record; - - type Test_Data_Type is array (Positive range <>) of Data_Point; - - -- the values in the following tables only involve static - -- expressions so no loss of precision occurs. However, - -- rounding can be an issue with expressions involving Pi - -- and square roots. The error bound specified in the - -- table takes the sqrt error into account but not the - -- error due to Pi. The Pi error is added in in the - -- radians test below. - - Arcsin_Test_Data : constant Test_Data_Type := ( - -- degrees radians sine error_bound test # - --( 0.0, 0.0, 0.0, 0.0 ), -- 1 - In Exact_Result_Test. - ( 30.0, Pi/6.0, 0.5, 4.0 ), -- 2 - ( 60.0, Pi/3.0, Sqrt3/2.0, 5.0 ), -- 3 - --( 90.0, Pi/2.0, 1.0, 4.0 ), -- 4 - In Exact_Result_Test. - --(-90.0, -Pi/2.0, -1.0, 4.0 ), -- 5 - In Exact_Result_Test. - (-60.0, -Pi/3.0, -Sqrt3/2.0, 5.0 ), -- 6 - (-30.0, -Pi/6.0, -0.5, 4.0 ), -- 7 - ( 45.0, Pi/4.0, Sqrt2/2.0, 5.0 ), -- 8 - (-45.0, -Pi/4.0, -Sqrt2/2.0, 5.0 ) ); -- 9 - - Arccos_Test_Data : constant Test_Data_Type := ( - -- degrees radians cosine error_bound test # - --( 0.0, 0.0, 1.0, 0.0 ), -- 1 - In Exact_Result_Test. - ( 30.0, Pi/6.0, Sqrt3/2.0, 5.0 ), -- 2 - ( 60.0, Pi/3.0, 0.5, 4.0 ), -- 3 - --( 90.0, Pi/2.0, 0.0, 4.0 ), -- 4 - In Exact_Result_Test. - (120.0, 2.0*Pi/3.0, -0.5, 4.0 ), -- 5 - (150.0, 5.0*Pi/6.0, -Sqrt3/2.0, 5.0 ), -- 6 - --(180.0, Pi, -1.0, 4.0 ), -- 7 - In Exact_Result_Test. - ( 45.0, Pi/4.0, Sqrt2/2.0, 5.0 ), -- 8 - (135.0, 3.0*Pi/4.0, -Sqrt2/2.0, 5.0 ) ); -- 9 - - Cycle_Error, - Radian_Error : Real; - begin - for I in Arcsin_Test_Data'Range loop - - -- note exact result requirements A.5.1(38);6.0 and - -- G.2.4(12);6.0 - if Arcsin_Test_Data (I).Error_Bound = 0.0 then - Cycle_Error := 0.0; - Radian_Error := 0.0; - else - Cycle_Error := Arcsin_Test_Data (I).Error_Bound; - -- allow for rounding error in the specification of Pi - Radian_Error := Cycle_Error + 1.0; - end if; - - Check (Arcsin (Arcsin_Test_Data (I).Argument), - Arcsin_Test_Data (I).Radians, - "test" & Integer'Image (I) & - " arcsin(" & - Real'Image (Arcsin_Test_Data (I).Argument) & - ")", - Radian_Error); ---pwb-math Check (Arcsin (Arcsin_Test_Data (I).Argument, 2.0 * Pi), ---pwb-math Arcsin_Test_Data (I).Radians, ---pwb-math "test" & Integer'Image (I) & ---pwb-math " arcsin(" & ---pwb-math Real'Image (Arcsin_Test_Data (I).Argument) & ---pwb-math ", 2pi)", ---pwb-math Cycle_Error); - Check (Arcsin (Arcsin_Test_Data (I).Argument, 360.0), - Arcsin_Test_Data (I).Degrees, - "test" & Integer'Image (I) & - " arcsin(" & - Real'Image (Arcsin_Test_Data (I).Argument) & - ", 360)", - Cycle_Error); - end loop; - - - for I in Arccos_Test_Data'Range loop - - -- note exact result requirements A.5.1(39);6.0 and - -- G.2.4(12);6.0 - if Arccos_Test_Data (I).Error_Bound = 0.0 then - Cycle_Error := 0.0; - Radian_Error := 0.0; - else - Cycle_Error := Arccos_Test_Data (I).Error_Bound; - -- allow for rounding error in the specification of Pi - Radian_Error := Cycle_Error + 1.0; - end if; - - Check (Arccos (Arccos_Test_Data (I).Argument), - Arccos_Test_Data (I).Radians, - "test" & Integer'Image (I) & - " arccos(" & - Real'Image (Arccos_Test_Data (I).Argument) & - ")", - Radian_Error); ---pwb-math Check (Arccos (Arccos_Test_Data (I).Argument, 2.0 * Pi), ---pwb-math Arccos_Test_Data (I).Radians, ---pwb-math "test" & Integer'Image (I) & ---pwb-math " arccos(" & ---pwb-math Real'Image (Arccos_Test_Data (I).Argument) & ---pwb-math ", 2pi)", ---pwb-math Cycle_Error); - Check (Arccos (Arccos_Test_Data (I).Argument, 360.0), - Arccos_Test_Data (I).Degrees, - "test" & Integer'Image (I) & - " arccos(" & - Real'Image (Arccos_Test_Data (I).Argument) & - ", 360)", - Cycle_Error); - end loop; - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in special value test"); - when others => - Report.Failed ("exception in special value test"); - end Special_Value_Test; - - - procedure Check_Exact (Actual, Expected_Low, Expected_High : Real; - Test_Name : String) is - -- If the expected result is not a model number, then Expected_Low is - -- the first machine number less than the (exact) expected - -- result, and Expected_High is the first machine number greater than - -- the (exact) expected result. If the expected result is a model - -- number, Expected_Low = Expected_High = the result. - Model_Expected_Low : Real := Expected_Low; - Model_Expected_High : Real := Expected_High; - begin - -- Calculate the first model number nearest to, but below (or equal) - -- to the expected result: - while Real'Model (Model_Expected_Low) /= Model_Expected_Low loop - -- Try the next machine number lower: - Model_Expected_Low := Real'Adjacent(Model_Expected_Low, 0.0); - end loop; - -- Calculate the first model number nearest to, but above (or equal) - -- to the expected result: - while Real'Model (Model_Expected_High) /= Model_Expected_High loop - -- Try the next machine number higher: - Model_Expected_High := Real'Adjacent(Model_Expected_High, 100.0); - end loop; - - if Actual < Model_Expected_Low or Actual > Model_Expected_High then - Accuracy_Error_Reported := True; - if Actual < Model_Expected_Low then - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected low: " & Real'Image (Model_Expected_Low) & - " expected high: " & Real'Image (Model_Expected_High) & - " difference: " & Real'Image (Actual - Expected_Low)); - else - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected low: " & Real'Image (Model_Expected_Low) & - " expected high: " & Real'Image (Model_Expected_High) & - " difference: " & Real'Image (Expected_High - Actual)); - end if; - elsif Verbose then - Report.Comment (Test_Name & " passed"); - end if; - end Check_Exact; - - - procedure Exact_Result_Test is - begin - -- A.5.1(38) - Check_Exact (Arcsin (0.0), 0.0, 0.0, "arcsin(0)"); - Check_Exact (Arcsin (0.0, 45.0), 0.0, 0.0, "arcsin(0,45)"); - - -- A.5.1(39) - Check_Exact (Arccos (1.0), 0.0, 0.0, "arccos(1)"); - Check_Exact (Arccos (1.0, 75.0), 0.0, 0.0, "arccos(1,75)"); - - -- G.2.4(11-13) - Check_Exact (Arcsin (1.0), Half_PI_Low, Half_PI_High, "arcsin(1)"); - Check_Exact (Arcsin (1.0, 360.0), 90.0, 90.0, "arcsin(1,360)"); - - Check_Exact (Arcsin (-1.0), -Half_PI_High, -Half_PI_Low, "arcsin(-1)"); - Check_Exact (Arcsin (-1.0, 360.0), -90.0, -90.0, "arcsin(-1,360)"); - - Check_Exact (Arccos (0.0), Half_PI_Low, Half_PI_High, "arccos(0)"); - Check_Exact (Arccos (0.0, 360.0), 90.0, 90.0, "arccos(0,360)"); - - Check_Exact (Arccos (-1.0), PI_Low, PI_High, "arccos(-1)"); - Check_Exact (Arccos (-1.0, 360.0), 180.0, 180.0, "arccos(-1,360)"); - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Exact_Result Test"); - when others => - Report.Failed ("Exception in Exact_Result Test"); - end Exact_Result_Test; - - - procedure Arcsin_Taylor_Series_Test is - -- the following range is chosen so that the Taylor series - -- used will produce a result accurate to machine precision. - -- - -- The following formula is used for the Taylor series: - -- TS(x) = x { 1 + (xsq/2) [ (1/3) + (3/4)xsq { (1/5) + - -- (5/6)xsq [ (1/7) + (7/8)xsq/9 ] } ] } - -- where xsq = x * x - -- - A : constant := -0.125; - B : constant := 0.125; - X : Real; - Y, Y_Sq : Real; - Actual, Sum, Xm : Real; - -- terms in Taylor series - K : constant Integer := Integer ( - Log ( - Real (Real'Machine_Radix) ** Real'Machine_Mantissa, - 10.0)) + 1; - begin - Accuracy_Error_Reported := False; -- reset - for I in 1..Max_Samples loop - -- make sure there is no error in x-1, x, and x+1 - X := (B - A) * Real (I) / Real (Max_Samples) + A; - - Y := X; - Y_Sq := Y * Y; - Sum := 0.0; - Xm := Real (K + K + 1); - for M in 1 .. K loop - Sum := Y_Sq * (Sum + 1.0/Xm); - Xm := Xm - 2.0; - Sum := Sum * (Xm /(Xm + 1.0)); - end loop; - Sum := Sum * Y; - Actual := Y + Sum; - Sum := (Y - Actual) + Sum; - if not Real'Machine_Rounds then - Actual := Actual + (Sum + Sum); - end if; - - Check (Actual, Arcsin (X), - "Taylor Series test" & Integer'Image (I) & ": arcsin(" & - Real'Image (X) & ") ", - Minimum_Error); - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - - end loop; - - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Arcsin_Taylor_Series_Test" & - " for X=" & Real'Image (X)); - when others => - Report.Failed ("exception in Arcsin_Taylor_Series_Test" & - " for X=" & Real'Image (X)); - end Arcsin_Taylor_Series_Test; - - - - procedure Arccos_Taylor_Series_Test is - -- the following range is chosen so that the Taylor series - -- used will produce a result accurate to machine precision. - -- - -- The following formula is used for the Taylor series: - -- TS(x) = x { 1 + (xsq/2) [ (1/3) + (3/4)xsq { (1/5) + - -- (5/6)xsq [ (1/7) + (7/8)xsq/9 ] } ] } - -- arccos(x) = pi/2 - TS(x) - A : constant := -0.125; - B : constant := 0.125; - C1, C2 : Real; - X : Real; - Y, Y_Sq : Real; - Actual, Sum, Xm, S : Real; - -- terms in Taylor series - K : constant Integer := Integer ( - Log ( - Real (Real'Machine_Radix) ** Real'Machine_Mantissa, - 10.0)) + 1; - begin - if Real'Digits > 23 then - -- constants in this section only accurate to 23 digits - Error_Low_Bound := 0.00000_00000_00000_00000_001; - Report.Comment ("arctan accuracy checked to 23 digits"); - end if; - - -- C1 + C2 equals Pi/2 accurate to 23 digits - if Real'Machine_Radix = 10 then - C1 := 1.57; - C2 := 7.9632679489661923132E-4; - else - C1 := 201.0 / 128.0; - C2 := 4.8382679489661923132E-4; - end if; - - Accuracy_Error_Reported := False; -- reset - for I in 1..Max_Samples loop - -- make sure there is no error in x-1, x, and x+1 - X := (B - A) * Real (I) / Real (Max_Samples) + A; - - Y := X; - Y_Sq := Y * Y; - Sum := 0.0; - Xm := Real (K + K + 1); - for M in 1 .. K loop - Sum := Y_Sq * (Sum + 1.0/Xm); - Xm := Xm - 2.0; - Sum := Sum * (Xm /(Xm + 1.0)); - end loop; - Sum := Sum * Y; - - -- at this point we have arcsin(x). - -- We compute arccos(x) = pi/2 - arcsin(x). - -- The following code segment is translated directly from - -- the CELEFUNT FORTRAN implementation - - S := C1 + C2; - Sum := ((C1 - S) + C2) - Sum; - Actual := S + Sum; - Sum := ((S - Actual) + Sum) - Y; - S := Actual; - Actual := S + Sum; - Sum := (S - Actual) + Sum; - - if not Real'Machine_Rounds then - Actual := Actual + (Sum + Sum); - end if; - - Check (Actual, Arccos (X), - "Taylor Series test" & Integer'Image (I) & ": arccos(" & - Real'Image (X) & ") ", - Minimum_Error); - - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - exit when Accuracy_Error_Reported; - end loop; - Error_Low_Bound := 0.0; -- reset - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Arccos_Taylor_Series_Test" & - " for X=" & Real'Image (X)); - when others => - Report.Failed ("exception in Arccos_Taylor_Series_Test" & - " for X=" & Real'Image (X)); - end Arccos_Taylor_Series_Test; - - - - procedure Identity_Test is - -- test the identity arcsin(-x) = -arcsin(x) - -- range chosen to be most of the valid range of the argument. - A : constant := -0.999; - B : constant := 0.999; - X : Real; - begin - Accuracy_Error_Reported := False; -- reset - for I in 1..Max_Samples loop - -- make sure there is no error in x-1, x, and x+1 - X := (B - A) * Real (I) / Real (Max_Samples) + A; - - Check (Arcsin(-X), -Arcsin (X), - "Identity test" & Integer'Image (I) & ": arcsin(" & - Real'Image (X) & ") ", - 8.0); -- 2 arcsin evaluations => twice the error bound - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - end loop; - end Identity_Test; - - - procedure Exception_Test is - X1, X2 : Real := 0.0; - begin - begin - X1 := Arcsin (1.1); - Report.Failed ("no exception for Arcsin (1.1)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error instead of " & - "Argument_Error for Arcsin (1.1)"); - when Ada.Numerics.Argument_Error => - null; -- expected result - when others => - Report.Failed ("wrong exception for Arcsin(1.1)"); - end; - - begin - X2 := Arccos (-1.1); - Report.Failed ("no exception for Arccos (-1.1)"); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error instead of " & - "Argument_Error for Arccos (-1.1)"); - when Ada.Numerics.Argument_Error => - null; -- expected result - when others => - Report.Failed ("wrong exception for Arccos(-1.1)"); - end; - - - -- optimizer thwarting - if Report.Ident_Bool (False) then - Report.Comment (Real'Image (X1 + X2)); - end if; - end Exception_Test; - - - procedure Do_Test is - begin - Special_Value_Test; - Exact_Result_Test; - Arcsin_Taylor_Series_Test; - Arccos_Taylor_Series_Test; - Identity_Test; - Exception_Test; - end Do_Test; - end Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - -- These expressions must be truly static, which is why we have to do them - -- outside of the generic, and we use the named numbers. Note that we know - -- that PI is not a machine number (it is irrational), and it should be - -- represented to more digits than supported by the target machine. - Float_Half_PI_Low : constant := Float'Adjacent(PI/2.0, 0.0); - Float_Half_PI_High : constant := Float'Adjacent(PI/2.0, 10.0); - Float_PI_Low : constant := Float'Adjacent(PI, 0.0); - Float_PI_High : constant := Float'Adjacent(PI, 10.0); - package Float_Check is new Generic_Check (Float, - Half_PI_Low => Float_Half_PI_Low, - Half_PI_High => Float_Half_PI_High, - PI_Low => Float_PI_Low, - PI_High => Float_PI_High); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - A_Long_Float_Half_PI_Low : constant := A_Long_Float'Adjacent(PI/2.0, 0.0); - A_Long_Float_Half_PI_High : constant := A_Long_Float'Adjacent(PI/2.0, 10.0); - A_Long_Float_PI_Low : constant := A_Long_Float'Adjacent(PI, 0.0); - A_Long_Float_PI_High : constant := A_Long_Float'Adjacent(PI, 10.0); - package A_Long_Float_Check is new Generic_Check (A_Long_Float, - Half_PI_Low => A_Long_Float_Half_PI_Low, - Half_PI_High => A_Long_Float_Half_PI_High, - PI_Low => A_Long_Float_PI_Low, - PI_High => A_Long_Float_PI_High); - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - -begin - Report.Test ("CXG2015", - "Check the accuracy of the ARCSIN and ARCCOS functions"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - - Report.Result; -end CXG2015; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a deleted file mode 100644 index 832b118224a..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a +++ /dev/null @@ -1,482 +0,0 @@ --- CXG2016.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 ARCTAN function returns a --- result that is within the error bound allowed. --- --- TEST DESCRIPTION: --- This test consists of a generic package that is --- instantiated to check both Float and a long float type. --- The test for each floating point type is divided into --- several parts: --- Special value checks where the result is a known constant. --- Exception checks. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 19 Mar 96 SAIC Initial release for 2.1 --- 30 APR 96 SAIC Fixed optimization issue --- 17 AUG 96 SAIC Incorporated Reviewer's suggestions. --- 12 OCT 96 SAIC Incorporated Reviewer's suggestions. --- 02 DEC 97 EDS Remove procedure Identity_1_Test and calls to --- procedure. --- 29 JUN 98 EDS Replace -0.0 with call to ImpDef.Annex_G.Negative_Zero --- 28 APR 99 RLB Replaced comma accidentally deleted in above change. --- 15 DEC 99 RLB Added model range checking to "exact" results, --- in order to avoid too strictly requiring a specific --- result. ---! - --- --- References: --- --- Software Manual for the Elementary Functions --- William J. Cody, Jr. and William Waite --- Prentice-Hall, 1980 --- --- CRC Standard Mathematical Tables --- 23rd Edition --- --- Implementation and Testing of Function Software --- W. J. Cody --- Problems and Methodologies in Mathematical Software Production --- editors P. C. Messina and A. Murli --- Lecture Notes in Computer Science Volume 142 --- Springer Verlag, 1982 --- - -with System; -with Report; -with Ada.Numerics.Generic_Elementary_Functions; -with Impdef.Annex_G; -procedure CXG2016 is - Verbose : constant Boolean := False; - Max_Samples : constant := 1000; - - -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 - Sqrt2 : constant := - 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; - Sqrt3 : constant := - 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; - - Pi : constant := Ada.Numerics.Pi; - - generic - type Real is digits <>; - Half_PI_Low : in Real; -- The machine number closest to, but not greater - -- than PI/2.0. - Half_PI_High : in Real;-- The machine number closest to, but not less - -- than PI/2.0. - PI_Low : in Real; -- The machine number closest to, but not greater - -- than PI. - PI_High : in Real; -- The machine number closest to, but not less - -- than PI. - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Elementary_Functions is new - Ada.Numerics.Generic_Elementary_Functions (Real); - - function Arctan (Y : Real; - X : Real := 1.0) return Real renames - Elementary_Functions.Arctan; - function Arctan (Y : Real; - X : Real := 1.0; - Cycle : Real) return Real renames - Elementary_Functions.Arctan; - - -- flag used to terminate some tests early - Accuracy_Error_Reported : Boolean := False; - - -- The following value is a lower bound on the accuracy - -- required. It is normally 0.0 so that the lower bound - -- is computed from Model_Epsilon. However, for tests - -- where the expected result is only known to a certain - -- amount of precision this bound takes on a non-zero - -- value to account for that level of precision. - Error_Low_Bound : Real := 0.0; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon - -- instead of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - -- take into account the low bound on the error - if Max_Error < Error_Low_Bound then - Max_Error := Error_Low_Bound; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Special_Value_Test is - -- If eta is very small, arctan(x + eta) ~= arctan(x) + eta/(1+x*x). - -- - -- For tests 4 and 5, there is an error of 4.0ME for arctan + an - -- additional error of 1.0ME because pi is not exact for a total of 5.0ME. - -- - -- In test 3 there is the error for pi plus an additional error - -- of (1.0ME)/4 since sqrt3 is not exact, for a total of 5.25ME. - -- - -- In test 2 there is the error for pi plus an additional error - -- of (3/4)(1.0ME) since sqrt3 is not exact, for a total of 5.75ME. - - - type Data_Point is - record - Degrees, - Radians, - Tangent, - Allowed_Error : Real; - end record; - - type Test_Data_Type is array (Positive range <>) of Data_Point; - - -- the values in the following table only involve static - -- expressions so no additional loss of precision occurs. - Test_Data : constant Test_Data_Type := ( - -- degrees radians tangent error test # - ( 0.0, 0.0, 0.0, 4.0 ), -- 1 - ( 30.0, Pi/6.0, Sqrt3/3.0, 5.75), -- 2 - ( 60.0, Pi/3.0, Sqrt3, 5.25), -- 3 - ( 45.0, Pi/4.0, 1.0, 5.0 ), -- 4 - (-45.0, -Pi/4.0, -1.0, 5.0 ) ); -- 5 - - begin - for I in Test_Data'Range loop - Check (Arctan (Test_Data (I).Tangent), - Test_Data (I).Radians, - "special value test" & Integer'Image (I) & - " arctan(" & - Real'Image (Test_Data (I).Tangent) & - ")", - Test_Data (I).Allowed_Error); - Check (Arctan (Test_Data (I).Tangent, Cycle => 360.0), - Test_Data (I).Degrees, - "special value test" & Integer'Image (I) & - " arctan(" & - Real'Image (Test_Data (I).Tangent) & - ", cycle=>360)", - Test_Data (I).Allowed_Error); - end loop; - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in special value test"); - when others => - Report.Failed ("exception in special value test"); - end Special_Value_Test; - - - - procedure Check_Exact (Actual, Expected_Low, Expected_High : Real; - Test_Name : String) is - -- If the expected result is not a model number, then Expected_Low is - -- the first machine number less than the (exact) expected - -- result, and Expected_High is the first machine number greater than - -- the (exact) expected result. If the expected result is a model - -- number, Expected_Low = Expected_High = the result. - Model_Expected_Low : Real := Expected_Low; - Model_Expected_High : Real := Expected_High; - begin - -- Calculate the first model number nearest to, but below (or equal) - -- to the expected result: - while Real'Model (Model_Expected_Low) /= Model_Expected_Low loop - -- Try the next machine number lower: - Model_Expected_Low := Real'Adjacent(Model_Expected_Low, 0.0); - end loop; - -- Calculate the first model number nearest to, but above (or equal) - -- to the expected result: - while Real'Model (Model_Expected_High) /= Model_Expected_High loop - -- Try the next machine number higher: - Model_Expected_High := Real'Adjacent(Model_Expected_High, 100.0); - end loop; - - if Actual < Model_Expected_Low or Actual > Model_Expected_High then - Accuracy_Error_Reported := True; - if Actual < Model_Expected_Low then - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected low: " & Real'Image (Model_Expected_Low) & - " expected high: " & Real'Image (Model_Expected_High) & - " difference: " & Real'Image (Actual - Expected_Low)); - else - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected low: " & Real'Image (Model_Expected_Low) & - " expected high: " & Real'Image (Model_Expected_High) & - " difference: " & Real'Image (Expected_High - Actual)); - end if; - elsif Verbose then - Report.Comment (Test_Name & " passed"); - end if; - end Check_Exact; - - - procedure Exact_Result_Test is - begin - -- A.5.1(40);6.0 - Check_Exact (Arctan (0.0, 1.0), 0.0, 0.0, "arctan(0,1)"); - Check_Exact (Arctan (0.0, 1.0, 27.0), 0.0, 0.0, "arctan(0,1,27)"); - - -- G.2.4(11-13);6.0 - - Check_Exact (Arctan (1.0, 0.0), Half_PI_Low, Half_PI_High, - "arctan(1,0)"); - Check_Exact (Arctan (1.0, 0.0, 360.0), 90.0, 90.0, "arctan(1,0,360)"); - - Check_Exact (Arctan (-1.0, 0.0), -Half_PI_High, -Half_PI_Low, - "arctan(-1,0)"); - Check_Exact (Arctan (-1.0, 0.0, 360.0), -90.0, -90.0, - "arctan(-1,0,360)"); - - if Real'Signed_Zeros then - Check_Exact (Arctan (0.0, -1.0), PI_Low, PI_High, "arctan(+0,-1)"); - Check_Exact (Arctan (0.0, -1.0, 360.0), 180.0, 180.0, - "arctan(+0,-1,360)"); - Check_Exact (Arctan ( Real ( ImpDef.Annex_G.Negative_Zero ), -1.0), - -PI_High, -PI_Low, "arctan(-0,-1)"); - Check_Exact (Arctan ( Real ( ImpDef.Annex_G.Negative_Zero ), -1.0, - 360.0), -180.0, -180.0, "arctan(-0,-1,360)"); - else - Check_Exact (Arctan (0.0, -1.0), PI_Low, PI_High, "arctan(0,-1)"); - Check_Exact (Arctan (0.0, -1.0, 360.0), 180.0, 180.0, - "arctan(0,-1,360)"); - end if; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Exact_Result Test"); - when others => - Report.Failed ("Exception in Exact_Result Test"); - end Exact_Result_Test; - - - procedure Taylor_Series_Test is - -- This test checks the Arctan by using a taylor series expansion that - -- will produce a result accurate to 19 decimal digits for - -- the range under test. - -- - -- The maximum relative error bound for this test is - -- 4 for the arctan operation and 2 for the Taylor series - -- for a total of 6 * Model_Epsilon - - A : constant := -1.0/16.0; - B : constant := 1.0/16.0; - X : Real; - Actual, Expected : Real; - Sum, Em, X_Squared : Real; - begin - if Real'Digits > 19 then - -- Taylor series calculation produces result accurate to 19 - -- digits. If type being tested has more digits then set - -- the error low bound to account for this. - -- The error low bound is conservatively set to 6*10**-19 - Error_Low_Bound := 0.00000_00000_00000_0006; - Report.Comment ("arctan accuracy checked to 19 digits"); - end if; - - Accuracy_Error_Reported := False; -- reset - for I in 0..Max_Samples loop - X := (B - A) * Real (I) / Real (Max_Samples) + A; - X_Squared := X * X; - Em := 17.0; - Sum := X_Squared / Em; - - for II in 1 .. 7 loop - Em := Em - 2.0; - Sum := (1.0 / Em - Sum) * X_Squared; - end loop; - Sum := -X * Sum; - Expected := X + Sum; - Sum := (X - Expected) + Sum; - if not Real'Machine_Rounds then - Expected := Expected + (Sum + Sum); - end if; - - Actual := Arctan (X); - - Check (Actual, Expected, - "Taylor_Series_Test " & Integer'Image (I) & ": arctan(" & - Real'Image (X) & ") ", - 6.0); - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - - end loop; - Error_Low_Bound := 0.0; -- reset - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Taylor_Series_Test"); - when others => - Report.Failed ("exception in Taylor_Series_Test"); - end Taylor_Series_Test; - - - procedure Exception_Test is - X1, X2, X3 : Real := 0.0; - begin - - begin -- A.5.1(20);6.0 - X1 := Arctan(0.0, Cycle => 0.0); - Report.Failed ("no exception for cycle = 0.0"); - exception - when Ada.Numerics.Argument_Error => null; - when others => - Report.Failed ("wrong exception for cycle = 0.0"); - end; - - begin -- A.5.1(20);6.0 - X2 := Arctan (0.0, Cycle => -1.0); - Report.Failed ("no exception for cycle < 0.0"); - exception - when Ada.Numerics.Argument_Error => null; - when others => - Report.Failed ("wrong exception for cycle < 0.0"); - end; - - begin -- A.5.1(25);6.0 - X3 := Arctan (0.0, 0.0); - Report.Failed ("no exception for arctan(0,0)"); - exception - when Ada.Numerics.Argument_Error => null; - when others => - Report.Failed ("wrong exception for arctan(0,0)"); - end; - - -- optimizer thwarting - if Report.Ident_Bool (False) then - Report.Comment (Real'Image (X1 + X2 + X3)); - end if; - end Exception_Test; - - - procedure Do_Test is - begin - Special_Value_Test; - Exact_Result_Test; - Taylor_Series_Test; - Exception_Test; - end Do_Test; - end Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - -- These expressions must be truly static, which is why we have to do them - -- outside of the generic, and we use the named numbers. Note that we know - -- that PI is not a machine number (it is irrational), and it should be - -- represented to more digits than supported by the target machine. - Float_Half_PI_Low : constant := Float'Adjacent(PI/2.0, 0.0); - Float_Half_PI_High : constant := Float'Adjacent(PI/2.0, 10.0); - Float_PI_Low : constant := Float'Adjacent(PI, 0.0); - Float_PI_High : constant := Float'Adjacent(PI, 10.0); - package Float_Check is new Generic_Check (Float, - Half_PI_Low => Float_Half_PI_Low, - Half_PI_High => Float_Half_PI_High, - PI_Low => Float_PI_Low, - PI_High => Float_PI_High); - - -- check the Floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - A_Long_Float_Half_PI_Low : constant := A_Long_Float'Adjacent(PI/2.0, 0.0); - A_Long_Float_Half_PI_High : constant := A_Long_Float'Adjacent(PI/2.0, 10.0); - A_Long_Float_PI_Low : constant := A_Long_Float'Adjacent(PI, 0.0); - A_Long_Float_PI_High : constant := A_Long_Float'Adjacent(PI, 10.0); - package A_Long_Float_Check is new Generic_Check (A_Long_Float, - Half_PI_Low => A_Long_Float_Half_PI_Low, - Half_PI_High => A_Long_Float_Half_PI_High, - PI_Low => A_Long_Float_PI_Low, - PI_High => A_Long_Float_PI_High); - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - -begin - Report.Test ("CXG2016", - "Check the accuracy of the ARCTAN function"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - - Report.Result; -end CXG2016; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a deleted file mode 100644 index 50add975f7f..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a +++ /dev/null @@ -1,296 +0,0 @@ --- CXG2017.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 TANH function returns --- a result that is within the error bound allowed. --- --- TEST DESCRIPTION: --- This test consists of a generic package that is --- instantiated to check both Float and a long float type. --- The test for each floating point type is divided into --- several parts: --- Special value checks where the result is a known constant. --- Checks that use an identity for determining the result. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 20 Mar 96 SAIC Initial release for 2.1 --- 17 Aug 96 SAIC Incorporated reviewer comments. --- 03 Jun 98 EDS Add parens to remove the potential for overflow. --- Remove the invocation of Identity_Test that checks --- Tanh values that are too close to zero for the --- test's error bounds. ---! - --- --- References: --- --- Software Manual for the Elementary Functions --- William J. Cody, Jr. and William Waite --- Prentice-Hall, 1980 --- --- CRC Standard Mathematical Tables --- 23rd Edition --- --- Implementation and Testing of Function Software --- W. J. Cody --- Problems and Methodologies in Mathematical Software Production --- editors P. C. Messina and A. Murli --- Lecture Notes in Computer Science Volume 142 --- Springer Verlag, 1982 --- - -with System; -with Report; -with Ada.Numerics.Generic_Elementary_Functions; -procedure CXG2017 is - Verbose : constant Boolean := False; - Max_Samples : constant := 1000; - - E : constant := Ada.Numerics.E; - - generic - type Real is digits <>; - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Elementary_Functions is new - Ada.Numerics.Generic_Elementary_Functions (Real); - - function Tanh (X : Real) return Real renames - Elementary_Functions.Tanh; - - function Log (X : Real) return Real renames - Elementary_Functions.Log; - - -- flag used to terminate some tests early - Accuracy_Error_Reported : Boolean := False; - - - -- The following value is a lower bound on the accuracy - -- required. It is normally 0.0 so that the lower bound - -- is computed from Model_Epsilon. However, for tests - -- where the expected result is only known to a certain - -- amount of precision this bound takes on a non-zero - -- value to account for that level of precision. - Error_Low_Bound : Real := 0.0; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Small instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Small; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - -- take into account the low bound on the error - if Max_Error < Error_Low_Bound then - Max_Error := Error_Low_Bound; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Special_Value_Test is - -- In the following tests the expected result is accurate - -- to the machine precision so the minimum guaranteed error - -- bound can be used. - Minimum_Error : constant := 8.0; - E2 : constant := E * E; - begin - Check (Tanh (1.0), - (E - 1.0 / E) / (E + 1.0 / E), - "tanh(1)", - Minimum_Error); - Check (Tanh (2.0), - (E2 - 1.0 / E2) / (E2 + 1.0 / E2), - "tanh(2)", - Minimum_Error); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in special value test"); - when others => - Report.Failed ("exception in special value test"); - end Special_Value_Test; - - - - procedure Exact_Result_Test is - No_Error : constant := 0.0; - begin - -- A.5.1(38);6.0 - Check (Tanh (0.0), 0.0, "tanh(0)", No_Error); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Exact_Result Test"); - when others => - Report.Failed ("exception in Exact_Result Test"); - end Exact_Result_Test; - - - procedure Identity_Test (A, B : Real) is - -- For this test we use the identity - -- TANH(u+v) = [TANH(u) + TANH(v)] / [1 + TANH(u)*TANH(v)] - -- which is transformed to - -- TANH(x) = [TANH(y)+C] / [1 + TANH(y) * C] - -- where C = TANH(1/8) and y = x - 1/8 - -- - -- see Cody pg 248-249 for details on the error analysis. - -- The net result is a relative error bound of 16 * Model_Epsilon. - -- - -- The second part of this test checks the identity - -- TANH(-x) = -TANH(X) - - X, Y : Real; - Actual1, Actual2 : Real; - C : constant := 1.2435300177159620805e-1; - begin - if Real'Digits > 20 then - -- constant C is accurate to 20 digits. Set the low bound - -- on the error to 16*10**-20 - Error_Low_Bound := 0.00000_00000_00000_00016; - Report.Comment ("tanh accuracy checked to 20 digits"); - end if; - - Accuracy_Error_Reported := False; -- reset - for I in 1..Max_Samples loop - X := (B - A) * (Real (I) / Real (Max_Samples)) + A; - Actual1 := Tanh(X); - - -- TANH(x) = [TANH(y)+C] / [1 + TANH(y) * C] - Y := X - (1.0 / 8.0); - Actual2 := (Tanh (Y) + C) / (1.0 + Tanh(Y) * C); - - Check (Actual1, Actual2, - "Identity_1_Test " & Integer'Image (I) & ": tanh(" & - Real'Image (X) & ") ", - 16.0); - - -- TANH(-x) = -TANH(X) - Actual2 := Tanh(-X); - Check (-Actual1, Actual2, - "Identity_2_Test " & Integer'Image (I) & ": tanh(" & - Real'Image (X) & ") ", - 16.0); - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - - end loop; - Error_Low_Bound := 0.0; -- reset - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Identity_Test" & - " for X=" & Real'Image (X)); - when others => - Report.Failed ("exception in Identity_Test" & - " for X=" & Real'Image (X)); - end Identity_Test; - - - - procedure Do_Test is - begin - Special_Value_Test; - Exact_Result_Test; - -- cover a large range - Identity_Test (1.0, Real'Safe_Last); - end Do_Test; - end Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - package Float_Check is new Generic_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package A_Long_Float_Check is new Generic_Check (A_Long_Float); - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - -begin - Report.Test ("CXG2017", - "Check the accuracy of the TANH function"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - - Report.Result; -end CXG2017; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a deleted file mode 100644 index be4f1a82faf..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a +++ /dev/null @@ -1,355 +0,0 @@ --- CXG2018.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 complex EXP function returns --- a result that is within the error bound allowed. --- --- TEST DESCRIPTION: --- This test consists of a generic package that is --- instantiated to check complex numbers based upon --- both Float and a long float type. --- The test for each floating point type is divided into --- several parts: --- Special value checks where the result is a known constant. --- Checks that use an identity for determining the result. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 21 Mar 96 SAIC Initial release for 2.1 --- 17 Aug 96 SAIC Incorporated reviewer comments. --- 27 Aug 99 RLB Repair on the error result of checks. --- 02 Apr 03 RLB Added code to discard excess precision in the --- construction of the test value for the --- Identity_Test. --- ---! - --- --- References: --- --- W. J. Cody --- CELEFUNT: A Portable Test Package for Complex Elementary Functions --- Algorithm 714, Collected Algorithms from ACM. --- Published in Transactions On Mathematical Software, --- Vol. 19, No. 1, March, 1993, pp. 1-21. --- --- CRC Standard Mathematical Tables --- 23rd Edition --- - -with System; -with Report; -with Ada.Numerics.Generic_Complex_Types; -with Ada.Numerics.Generic_Complex_Elementary_Functions; -procedure CXG2018 is - Verbose : constant Boolean := False; - -- Note that Max_Samples is the number of samples taken in - -- both the real and imaginary directions. Thus, for Max_Samples - -- of 100 the number of values checked is 10000. - Max_Samples : constant := 100; - - E : constant := Ada.Numerics.E; - Pi : constant := Ada.Numerics.Pi; - - generic - type Real is digits <>; - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Complex_Type is new - Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Type; - - package CEF is new - Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type); - - function Exp (X : Complex) return Complex renames CEF.Exp; - function Exp (X : Imaginary) return Complex renames CEF.Exp; - - -- flag used to terminate some tests early - Accuracy_Error_Reported : Boolean := False; - - - -- The following value is a lower bound on the accuracy - -- required. It is normally 0.0 so that the lower bound - -- is computed from Model_Epsilon. However, for tests - -- where the expected result is only known to a certain - -- amount of precision this bound takes on a non-zero - -- value to account for that level of precision. - Error_Low_Bound : Real := 0.0; - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Small instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Small; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - -- take into account the low bound on the error - if Max_Error < Error_Low_Bound then - Max_Error := Error_Low_Bound; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Check (Actual, Expected : Complex; - Test_Name : String; - MRE : Real) is - begin - Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE); - Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE); - end Check; - - - procedure Special_Value_Test is - -- In the following tests the expected result is accurate - -- to the machine precision so the minimum guaranteed error - -- bound can be used. - -- - -- The error bounds given assumed z is exact. When using - -- pi there is an extra error of 1.0ME. - -- The pi inside the exp call requires that the complex - -- component have an extra error allowance of 1.0*angle*ME. - -- Thus for pi/2,the Minimum_Error_I is - -- (2.0 + 1.0(pi/2))ME <= 3.6ME. - -- For pi, it is (2.0 + 1.0*pi)ME <= 5.2ME, - -- and for 2pi, it is (2.0 + 1.0(2pi))ME <= 8.3ME. - - -- The addition of 1 or i to a result is so that neither of - -- the components of an expected result is 0. This is so - -- that a reasonable relative error is allowed. - Minimum_Error_C : constant := 7.0; -- for exp(Complex) - Minimum_Error_I : constant := 2.0; -- for exp(Imaginary) - begin - Check (Exp (1.0 + 0.0*i) + i, - E + i, - "exp(1+0i)", - Minimum_Error_C); - Check (Exp ((Pi / 2.0) * i) + 1.0, - 1.0 + 1.0*i, - "exp(pi/2*i)", - 3.6); - Check (Exp (Pi * i) + i, - -1.0 + 1.0*i, - "exp(pi*i)", - 5.2); - Check (Exp (Pi * 2.0 * i) + i, - 1.0 + i, - "exp(2pi*i)", - 8.3); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in special value test"); - when others => - Report.Failed ("exception in special value test"); - end Special_Value_Test; - - - - procedure Exact_Result_Test is - No_Error : constant := 0.0; - begin - -- G.1.2(36);6.0 - Check (Exp(0.0 + 0.0*i), 1.0 + 0.0 * i, "exp(0+0i)", No_Error); - Check (Exp( 0.0*i), 1.0 + 0.0 * i, "exp(0i)", No_Error); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Exact_Result Test"); - when others => - Report.Failed ("exception in Exact_Result Test"); - end Exact_Result_Test; - - - procedure Identity_Test (A, B : Real) is - -- For this test we use the identity - -- Exp(Z) = Exp(Z-W) * Exp (W) - -- where W = (1+i)/16 - -- - -- The second part of this test checks the identity - -- Exp(Z) * Exp(-Z) = 1 - -- - - X, Y : Complex; - Actual1, Actual2 : Complex; - W : constant Complex := (0.0625, 0.0625); - -- the following constant was taken from the CELEFUNC EXP test. - -- This is the value EXP(W) - 1 - C : constant Complex := (6.2416044877018563681e-2, - 6.6487597751003112768e-2); - begin - if Real'Digits > 20 then - -- constant ExpW is accurate to 20 digits. - -- The low bound is 19 * 10**-20 - Error_Low_Bound := 0.00000_00000_00019; - Report.Comment ("complex exp accuracy checked to 20 digits"); - end if; - - Accuracy_Error_Reported := False; -- reset - for II in 1..Max_Samples loop - X.Re := Real'Machine ((B - A) * Real (II) / Real (Max_Samples) - + A); - for J in 1..Max_Samples loop - X.Im := Real'Machine ((B - A) * Real (J) / Real (Max_Samples) - + A); - - Actual1 := Exp(X); - - -- Exp(X) = Exp(X-W) * Exp (W) - -- = Exp(X-W) * (1 - (1-Exp(W)) - -- = Exp(X-W) * (1 + (Exp(W) - 1)) - -- = Exp(X-W) * (1 + C) - Y := X - W; - Actual2 := Exp(Y); - Actual2 := Actual2 + Actual2 * C; - - Check (Actual1, Actual2, - "Identity_1_Test " & Integer'Image (II) & - Integer'Image (J) & ": Exp((" & - Real'Image (X.Re) & ", " & - Real'Image (X.Im) & ")) ", - 20.0); -- 2 exp and 1 multiply and 1 add = 2*7+1*5+1 - -- Note: The above is not strictly correct, as multiply - -- has a box error, rather than a relative error. - -- Supposedly, the interval is chosen to avoid the need - -- to worry about this. - - -- Exp(X) * Exp(-X) + i = 1 + i - -- The addition of i is to allow a reasonable relative - -- error in the imaginary part - Actual2 := (Actual1 * Exp(-X)) + i; - Check (Actual2, (1.0, 1.0), - "Identity_2_Test " & Integer'Image (II) & - Integer'Image (J) & ": Exp((" & - Real'Image (X.Re) & ", " & - Real'Image (X.Im) & ")) ", - 20.0); -- 2 exp and 1 multiply and one add = 2*7+1*5+1 - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - end loop; - end loop; - Error_Low_Bound := 0.0; - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Identity_Test" & - " for X=(" & Real'Image (X.Re) & - ", " & Real'Image (X.Im) & ")"); - when others => - Report.Failed ("exception in Identity_Test" & - " for X=(" & Real'Image (X.Re) & - ", " & Real'Image (X.Im) & ")"); - end Identity_Test; - - - - procedure Do_Test is - begin - Special_Value_Test; - Exact_Result_Test; - -- test regions where we can avoid cancellation error problems - -- See Cody page 10. - Identity_Test (0.0625, 1.0); - Identity_Test (15.0, 17.0); - Identity_Test (1.625, 3.0); - end Do_Test; - end Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - package Float_Check is new Generic_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package A_Long_Float_Check is new Generic_Check (A_Long_Float); - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - -begin - Report.Test ("CXG2018", - "Check the accuracy of the complex EXP function"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - - Report.Result; -end CXG2018; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a deleted file mode 100644 index 0a4dddcc906..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a +++ /dev/null @@ -1,338 +0,0 @@ --- CXG2019.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 complex LOG function returns --- a result that is within the error bound allowed. --- --- TEST DESCRIPTION: --- This test consists of a generic package that is --- instantiated to check complex numbers based upon --- both Float and a long float type. --- The test for each floating point type is divided into --- several parts: --- Special value checks where the result is a known constant. --- Checks that use an identity for determining the result. --- Exception conditions. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 22 Mar 96 SAIC Initial release for 2.1 --- ---! - --- --- References: --- --- W. J. Cody --- CELEFUNT: A Portable Test Package for Complex Elementary Functions --- Algorithm 714, Collected Algorithms from ACM. --- Published in Transactions On Mathematical Software, --- Vol. 19, No. 1, March, 1993, pp. 1-21. --- --- CRC Standard Mathematical Tables --- 23rd Edition --- - -with System; -with Report; -with Ada.Numerics.Generic_Complex_Types; -with Ada.Numerics.Generic_Complex_Elementary_Functions; -procedure CXG2019 is - Verbose : constant Boolean := False; - -- Note that Max_Samples is the number of samples taken in - -- both the real and imaginary directions. Thus, for Max_Samples - -- of 100 the number of values checked is 10000. - Max_Samples : constant := 100; - - E : constant := Ada.Numerics.E; - Pi : constant := Ada.Numerics.Pi; - - generic - type Real is digits <>; - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Complex_Type is new - Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Type; - - package CEF is new - Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type); - - function Log (X : Complex) return Complex renames CEF.Log; - - -- flag used to terminate some tests early - Accuracy_Error_Reported : Boolean := False; - - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Small instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * abs Expected * Real'Model_Epsilon; - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Check (Actual, Expected : Complex; - Test_Name : String; - MRE : Real) is - begin - Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE); - Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE); - end Check; - - - procedure Special_Value_Test is - -- In the following tests the expected result is accurate - -- to the machine precision so the minimum guaranteed error - -- bound can be used if the argument is exact. - -- - -- When using pi there is an extra error of 1.0ME. - -- Although the real component has an error bound of 13.0, - -- the complex component must take into account this error - -- in the value for Pi. - -- - -- One or i is added to the actual and expected results in - -- order to prevent the expected result from having a - -- real or imaginary part of 0. This is to allow a reasonable - -- relative error for that component. - Minimum_Error : constant := 13.0; - begin - Check (1.0 + Log (0.0 + i), - 1.0 + Pi / 2.0 * i, - "1+log(0+i)", - Minimum_Error + 1.0); - Check (1.0 + Log ((-1.0, 0.0)), - 1.0 + (Pi * i), - "log(-1+0i)+1 ", - Minimum_Error + 1.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in special value test"); - when others => - Report.Failed ("exception in special value test"); - end Special_Value_Test; - - - - procedure Exact_Result_Test is - No_Error : constant := 0.0; - begin - -- G.1.2(37);6.0 - Check (Log(1.0 + 0.0*i), 0.0 + 0.0 * i, "log(1+0i)", No_Error); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Exact_Result Test"); - when others => - Report.Failed ("exception in Exact_Result Test"); - end Exact_Result_Test; - - - procedure Identity_Test (RA, RB, IA, IB : Real) is - -- Tests an identity over a range of values specified - -- by the 4 parameters. RA and RB denote the range for the - -- real part while IA and IB denote the range for the - -- imaginary part. - -- - -- For this test we use the identity - -- Log(Z*Z) = 2 * Log(Z) - -- - - Scale : Real := Real (Real'Machine_Radix) ** (Real'Mantissa / 2 + 4); - W, X, Y, Z : Real; - CX, CY : Complex; - Actual1, Actual2 : Complex; - begin - Accuracy_Error_Reported := False; -- reset - for II in 1..Max_Samples loop - X := (RB - RA) * Real (II) / Real (Max_Samples) + RA; - for J in 1..Max_Samples loop - Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA; - - -- purify the arguments to minimize roundoff error. - -- We construct the values so that the products X*X, - -- Y*Y, and X*Y are all exact machine numbers. - -- See Cody page 7 and CELEFUNT code. - Z := X * Scale; - W := Z + X; - X := W - Z; - Z := Y * Scale; - W := Z + Y; - Y := W - Z; - CX := Compose_From_Cartesian(X,Y); - Z := X*X - Y*Y; - W := X*Y; - CY := Compose_From_Cartesian(Z,W+W); - - -- The arguments are now ready so on with the - -- identity computation. - Actual1 := Log(CX); - - Actual2 := Log(CY) * 0.5; - - Check (Actual1, Actual2, - "Identity_1_Test " & Integer'Image (II) & - Integer'Image (J) & ": Log((" & - Real'Image (CX.Re) & ", " & - Real'Image (CX.Im) & ")) ", - 26.0); -- 2 logs = 2*13. no error from this multiply - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - end loop; - end loop; - - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Identity_Test" & - " for X=(" & Real'Image (X) & - ", " & Real'Image (X) & ")"); - when others => - Report.Failed ("exception in Identity_Test" & - " for X=(" & Real'Image (X) & - ", " & Real'Image (X) & ")"); - end Identity_Test; - - - procedure Exception_Test is - -- Check that log((0,0)) causes constraint_error. - -- G.1.2(29); - - X : Complex := (0.0, 0.0); - begin - if not Real'Machine_Overflows then - -- not applicable: G.1.2(28);6.0 - return; - end if; - - begin - X := Log ((0.0, 0.0)); - Report.Failed ("exception not raised for log(0,0)"); - exception - when Constraint_Error => null; -- ok - when others => - Report.Failed ("wrong exception raised for log(0,0)"); - end; - - -- optimizer thwarting - if Report.Ident_Bool(False) then - Report.Comment (Real'Image (X.Re + X.Im)); - end if; - end Exception_Test; - - - procedure Do_Test is - begin - Special_Value_Test; - Exact_Result_Test; - -- test regions that do not include the unit circle so that - -- the real part of LOG(Z) does not vanish - -- See Cody page 9. - Identity_Test ( 2.0, 10.0, 0.0, 10.0); - Identity_Test (1000.0, 2000.0, -4000.0, -1000.0); - Identity_Test (Real'Model_Epsilon, 0.25, - -0.25, -Real'Model_Epsilon); - Exception_Test; - end Do_Test; - end Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - package Float_Check is new Generic_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package A_Long_Float_Check is new Generic_Check (A_Long_Float); - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - -begin - Report.Test ("CXG2019", - "Check the accuracy of the complex LOG function"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - - Report.Result; -end CXG2019; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a deleted file mode 100644 index 1aed4ca5735..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a +++ /dev/null @@ -1,351 +0,0 @@ --- CXG2020.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 complex SQRT function returns --- a result that is within the error bound allowed. --- --- TEST DESCRIPTION: --- This test consists of a generic package that is --- instantiated to check complex numbers based upon --- both Float and a long float type. --- The test for each floating point type is divided into --- several parts: --- Special value checks where the result is a known constant. --- Checks that use an identity for determining the result. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 24 Mar 96 SAIC Initial release for 2.1 --- 17 Aug 96 SAIC Incorporated reviewer comments. --- 03 Jun 98 EDS Added parens to ensure that the expression is not --- evaluated by multiplying its two large terms --- together and overflowing. ---! - --- --- References: --- --- W. J. Cody --- CELEFUNT: A Portable Test Package for Complex Elementary Functions --- Algorithm 714, Collected Algorithms from ACM. --- Published in Transactions On Mathematical Software, --- Vol. 19, No. 1, March, 1993, pp. 1-21. --- --- CRC Standard Mathematical Tables --- 23rd Edition --- - -with System; -with Report; -with Ada.Numerics.Generic_Complex_Types; -with Ada.Numerics.Generic_Complex_Elementary_Functions; -procedure CXG2020 is - Verbose : constant Boolean := False; - -- Note that Max_Samples is the number of samples taken in - -- both the real and imaginary directions. Thus, for Max_Samples - -- of 100 the number of values checked is 10000. - Max_Samples : constant := 100; - - E : constant := Ada.Numerics.E; - Pi : constant := Ada.Numerics.Pi; - - -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 - Sqrt2 : constant := - 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; - Sqrt3 : constant := - 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; - - generic - type Real is digits <>; - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Complex_Type is new - Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Type; - - package CEF is new - Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type); - - function Sqrt (X : Complex) return Complex renames CEF.Sqrt; - - -- flag used to terminate some tests early - Accuracy_Error_Reported : Boolean := False; - - - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon - -- instead of Model_Epsilon and Expected. - Rel_Error := MRE * (abs Expected * Real'Model_Epsilon); - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed"); - end if; - end if; - end Check; - - - procedure Check (Actual, Expected : Complex; - Test_Name : String; - MRE : Real) is - begin - Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE); - Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE); - end Check; - - - procedure Special_Value_Test is - -- In the following tests the expected result is accurate - -- to the machine precision so the minimum guaranteed error - -- bound can be used if the argument is exact. - -- - -- One or i is added to the actual and expected results in - -- order to prevent the expected result from having a - -- real or imaginary part of 0. This is to allow a reasonable - -- relative error for that component. - Minimum_Error : constant := 6.0; - Z1, Z2 : Complex; - begin - Check (Sqrt(9.0+0.0*i) + i, - 3.0+1.0*i, - "sqrt(9+0i)+i", - Minimum_Error); - Check (Sqrt (-2.0 + 0.0 * i) + 1.0, - 1.0 + Sqrt2 * i, - "sqrt(-2)+1 ", - Minimum_Error); - - -- make sure no exception occurs when taking the sqrt of - -- very large and very small values. - - Z1 := (Real'Safe_Last * 0.9, Real'Safe_Last * 0.9); - Z2 := Sqrt (Z1); - begin - Check (Z2 * Z2, - Z1, - "sqrt((big,big))", - Minimum_Error + 5.0); -- +5 for multiply - exception - when others => - Report.Failed ("unexpected exception in sqrt((big,big))"); - end; - - Z1 := (Real'Model_Epsilon * 10.0, Real'Model_Epsilon * 10.0); - Z2 := Sqrt (Z1); - begin - Check (Z2 * Z2, - Z1, - "sqrt((little,little))", - Minimum_Error + 5.0); -- +5 for multiply - exception - when others => - Report.Failed ("unexpected exception in " & - "sqrt((little,little))"); - end; - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in special value test"); - when others => - Report.Failed ("exception in special value test"); - end Special_Value_Test; - - - - procedure Exact_Result_Test is - No_Error : constant := 0.0; - begin - -- G.1.2(36);6.0 - Check (Sqrt(0.0 + 0.0*i), 0.0 + 0.0 * i, "sqrt(0+0i)", No_Error); - - -- G.1.2(37);6.0 - Check (Sqrt(1.0 + 0.0*i), 1.0 + 0.0 * i, "sqrt(1+0i)", No_Error); - - -- G.1.2(38-39);6.0 - Check (Sqrt(-1.0 + 0.0*i), 0.0 + 1.0 * i, "sqrt(-1+0i)", No_Error); - - -- G.1.2(40);6.0 - if Real'Signed_Zeros then - Check (Sqrt(-1.0-0.0*i), 0.0 - 1.0 * i, "sqrt(-1-0i)", No_Error); - end if; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Exact_Result Test"); - when others => - Report.Failed ("exception in Exact_Result Test"); - end Exact_Result_Test; - - - procedure Identity_Test (RA, RB, IA, IB : Real) is - -- Tests an identity over a range of values specified - -- by the 4 parameters. RA and RB denote the range for the - -- real part while IA and IB denote the range for the - -- imaginary part of the result. - -- - -- For this test we use the identity - -- Sqrt(Z*Z) = Z - -- - - Scale : Real := Real (Real'Machine_Radix) ** (Real'Mantissa / 2 + 4); - W, X, Y, Z : Real; - CX : Complex; - Actual, Expected : Complex; - begin - Accuracy_Error_Reported := False; -- reset - for II in 1..Max_Samples loop - X := (RB - RA) * Real (II) / Real (Max_Samples) + RA; - for J in 1..Max_Samples loop - Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA; - - -- purify the arguments to minimize roundoff error. - -- We construct the values so that the products X*X, - -- Y*Y, and X*Y are all exact machine numbers. - -- See Cody page 7 and CELEFUNT code. - Z := X * Scale; - W := Z + X; - X := W - Z; - Z := Y * Scale; - W := Z + Y; - Y := W - Z; - -- G.1.2(21);6.0 - real part of result is non-negative - Expected := Compose_From_Cartesian( abs X,Y); - Z := X*X - Y*Y; - W := X*Y; - CX := Compose_From_Cartesian(Z,W+W); - - -- The arguments are now ready so on with the - -- identity computation. - Actual := Sqrt(CX); - - Check (Actual, Expected, - "Identity_1_Test " & Integer'Image (II) & - Integer'Image (J) & ": Sqrt((" & - Real'Image (CX.Re) & ", " & - Real'Image (CX.Im) & ")) ", - 8.5); -- 6.0 from sqrt, 2.5 from argument. - -- See Cody pg 7-8 for analysis of additional error amount. - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - return; - end if; - end loop; - end loop; - - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Identity_Test" & - " for X=(" & Real'Image (X) & - ", " & Real'Image (X) & ")"); - when others => - Report.Failed ("exception in Identity_Test" & - " for X=(" & Real'Image (X) & - ", " & Real'Image (X) & ")"); - end Identity_Test; - - - procedure Do_Test is - begin - Special_Value_Test; - Exact_Result_Test; - -- ranges where the sign is the same and where it - -- differs. - Identity_Test ( 0.0, 10.0, 0.0, 10.0); - Identity_Test ( 0.0, 100.0, -100.0, 0.0); - end Do_Test; - end Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - package Float_Check is new Generic_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package A_Long_Float_Check is new Generic_Check (A_Long_Float); - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - -begin - Report.Test ("CXG2020", - "Check the accuracy of the complex SQRT function"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - - Report.Result; -end CXG2020; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a deleted file mode 100644 index db49fc845f2..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a +++ /dev/null @@ -1,386 +0,0 @@ --- CXG2021.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 complex SIN and COS functions return --- a result that is within the error bound allowed. --- --- TEST DESCRIPTION: --- This test consists of a generic package that is --- instantiated to check complex numbers based upon --- both Float and a long float type. --- The test for each floating point type is divided into --- several parts: --- Special value checks where the result is a known constant. --- Checks that use an identity for determining the result. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 27 Mar 96 SAIC Initial release for 2.1 --- 22 Aug 96 SAIC No longer skips test for systems with --- more than 20 digits of precision. --- ---! - --- --- References: --- --- W. J. Cody --- CELEFUNT: A Portable Test Package for Complex Elementary Functions --- Algorithm 714, Collected Algorithms from ACM. --- Published in Transactions On Mathematical Software, --- Vol. 19, No. 1, March, 1993, pp. 1-21. --- --- CRC Standard Mathematical Tables --- 23rd Edition --- - -with System; -with Report; -with Ada.Numerics.Generic_Complex_Types; -with Ada.Numerics.Generic_Complex_Elementary_Functions; -procedure CXG2021 is - Verbose : constant Boolean := False; - -- Note that Max_Samples is the number of samples taken in - -- both the real and imaginary directions. Thus, for Max_Samples - -- of 100 the number of values checked is 10000. - Max_Samples : constant := 100; - - E : constant := Ada.Numerics.E; - Pi : constant := Ada.Numerics.Pi; - - generic - type Real is digits <>; - package Generic_Check is - procedure Do_Test; - end Generic_Check; - - package body Generic_Check is - package Complex_Type is new - Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Type; - - package CEF is new - Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type); - - function Sin (X : Complex) return Complex renames CEF.Sin; - function Cos (X : Complex) return Complex renames CEF.Cos; - - -- flag used to terminate some tests early - Accuracy_Error_Reported : Boolean := False; - - -- The following value is a lower bound on the accuracy - -- required. It is normally 0.0 so that the lower bound - -- is computed from Model_Epsilon. However, for tests - -- where the expected result is only known to a certain - -- amount of precision this bound takes on a non-zero - -- value to account for that level of precision. - Error_Low_Bound : Real := 0.0; - - -- the E_Factor is an additional amount added to the Expected - -- value prior to computing the maximum relative error. - -- This is needed because the error analysis (Cody pg 17-20) - -- requires this additional allowance. - procedure Check (Actual, Expected : Real; - Test_Name : String; - MRE : Real; - E_Factor : Real := 0.0) is - Max_Error : Real; - Rel_Error : Real; - Abs_Error : Real; - begin - -- In the case where the expected result is very small or 0 - -- we compute the maximum error as a multiple of Model_Epsilon instead - -- of Model_Epsilon and Expected. - Rel_Error := MRE * Real'Model_Epsilon * (abs Expected + E_Factor); - Abs_Error := MRE * Real'Model_Epsilon; - if Rel_Error > Abs_Error then - Max_Error := Rel_Error; - else - Max_Error := Abs_Error; - end if; - - -- take into account the low bound on the error - if Max_Error < Error_Low_Bound then - Max_Error := Error_Low_Bound; - end if; - - if abs (Actual - Expected) > Max_Error then - Accuracy_Error_Reported := True; - Report.Failed (Test_Name & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) & - " efactor:" & Real'Image (E_Factor) ); - elsif Verbose then - if Actual = Expected then - Report.Comment (Test_Name & " exact result"); - else - Report.Comment (Test_Name & " passed" & - " actual: " & Real'Image (Actual) & - " expected: " & Real'Image (Expected) & - " difference: " & Real'Image (Actual - Expected) & - " max err:" & Real'Image (Max_Error) & - " efactor:" & Real'Image (E_Factor) ); - end if; - end if; - end Check; - - - procedure Check (Actual, Expected : Complex; - Test_Name : String; - MRE : Real; - R_Factor, I_Factor : Real := 0.0) is - begin - Check (Actual.Re, Expected.Re, Test_Name & " real part", - MRE, R_Factor); - Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", - MRE, I_Factor); - end Check; - - - procedure Special_Value_Test is - -- In the following tests the expected result is accurate - -- to the machine precision so the minimum guaranteed error - -- bound can be used if the argument is exact. - -- Since the argument involves Pi, we must allow for this - -- inexact argument. - Minimum_Error : constant := 11.0; - begin - Check (Sin (Pi/2.0 + 0.0*i), - 1.0 + 0.0*i, - "sin(pi/2+0i)", - Minimum_Error + 1.0); - Check (Cos (Pi/2.0 + 0.0*i), - 0.0 + 0.0*i, - "cos(pi/2+0i)", - Minimum_Error + 1.0); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in special value test"); - when others => - Report.Failed ("exception in special value test"); - end Special_Value_Test; - - - - procedure Exact_Result_Test is - No_Error : constant := 0.0; - begin - -- G.1.2(36);6.0 - Check (Sin(0.0 + 0.0*i), 0.0 + 0.0 * i, "sin(0+0i)", No_Error); - Check (Cos(0.0 + 0.0*i), 1.0 + 0.0 * i, "cos(0+0i)", No_Error); - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Exact_Result Test"); - when others => - Report.Failed ("exception in Exact_Result Test"); - end Exact_Result_Test; - - - procedure Identity_Test (RA, RB, IA, IB : Real) is - -- Tests an identity over a range of values specified - -- by the 4 parameters. RA and RB denote the range for the - -- real part while IA and IB denote the range for the - -- imaginary part. - -- - -- For this test we use the identity - -- Sin(Z) = Sin(Z-W) * Cos(W) + Cos(Z-W) * Sin(W) - -- and - -- Cos(Z) = Cos(Z-W) * Cos(W) - Sin(Z-W) * Sin(W) - -- - - X, Y : Real; - Z : Complex; - W : constant Complex := Compose_From_Cartesian(0.0625, 0.0625); - ZmW : Complex; -- Z - W - Sin_ZmW, - Cos_ZmW : Complex; - Actual1, Actual2 : Complex; - R_Factor : Real; -- additional real error factor - I_Factor : Real; -- additional imaginary error factor - Sin_W : constant Complex := (6.2581348413276935585E-2, - 6.2418588008436587236E-2); - -- numeric stability is enhanced by using Cos(W) - 1.0 instead of - -- Cos(W) in the computation. - Cos_W_m_1 : constant Complex := (-2.5431314180235545803E-6, - -3.9062493377261771826E-3); - - - begin - if Real'Digits > 20 then - -- constants used here accurate to 20 digits. Allow 1 - -- additional digit of error for computation. - Error_Low_Bound := 0.00000_00000_00000_0001; - Report.Comment ("accuracy checked to 19 digits"); - end if; - - Accuracy_Error_Reported := False; -- reset - for II in 0..Max_Samples loop - X := (RB - RA) * Real (II) / Real (Max_Samples) + RA; - for J in 0..Max_Samples loop - Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA; - - Z := Compose_From_Cartesian(X,Y); - ZmW := Z - W; - Sin_ZmW := Sin (ZmW); - Cos_ZmW := Cos (ZmW); - - -- now for the first identity - -- Sin(Z) = Sin(Z-W) * Cos(W) + Cos(Z-W) * Sin(W) - -- = Sin(Z-W) * (1+(Cos(W)-1)) + Cos(Z-W) * Sin(W) - -- = Sin(Z-W) + Sin(Z-W)*(Cos(W)-1) + Cos(Z-W)*Sin(W) - - - Actual1 := Sin (Z); - Actual2 := Sin_ZmW + (Sin_ZmW * Cos_W_m_1 + Cos_ZmW * Sin_W); - - -- The computation of the additional error factors are taken - -- from Cody pages 17-20. - - R_Factor := abs (Re (Sin_ZmW) * Re (1.0 - Cos_W_m_1)) + - abs (Im (Sin_ZmW) * Im (1.0 - Cos_W_m_1)) + - abs (Re (Cos_ZmW) * Re (Sin_W)) + - abs (Re (Cos_ZmW) * Re (1.0 - Cos_W_m_1)); - - I_Factor := abs (Re (Sin_ZmW) * Im (1.0 - Cos_W_m_1)) + - abs (Im (Sin_ZmW) * Re (1.0 - Cos_W_m_1)) + - abs (Re (Cos_ZmW) * Im (Sin_W)) + - abs (Im (Cos_ZmW) * Re (1.0 - Cos_W_m_1)); - - Check (Actual1, Actual2, - "Identity_1_Test " & Integer'Image (II) & - Integer'Image (J) & ": Sin((" & - Real'Image (Z.Re) & ", " & - Real'Image (Z.Im) & ")) ", - 11.0, R_Factor, I_Factor); - - -- now for the second identity - -- Cos(Z) = Cos(Z-W) * Cos(W) - Sin(Z-W) * Sin(W) - -- = Cos(Z-W) * (1+(Cos(W)-1) - Sin(Z-W) * Sin(W) - Actual1 := Cos (Z); - Actual2 := Cos_ZmW + (Cos_ZmW * Cos_W_m_1 - Sin_ZmW * Sin_W); - - -- The computation of the additional error factors are taken - -- from Cody pages 17-20. - - R_Factor := abs (Re (Sin_ZmW) * Re (Sin_W)) + - abs (Im (Sin_ZmW) * Im (Sin_W)) + - abs (Re (Cos_ZmW) * Re (1.0 - Cos_W_m_1)) + - abs (Im (Cos_ZmW) * Im (1.0 - Cos_W_m_1)); - - I_Factor := abs (Re (Sin_ZmW) * Im (Sin_W)) + - abs (Im (Sin_ZmW) * Re (Sin_W)) + - abs (Re (Cos_ZmW) * Im (1.0 - Cos_W_m_1)) + - abs (Im (Cos_ZmW) * Re (1.0 - Cos_W_m_1)); - - Check (Actual1, Actual2, - "Identity_2_Test " & Integer'Image (II) & - Integer'Image (J) & ": Cos((" & - Real'Image (Z.Re) & ", " & - Real'Image (Z.Im) & ")) ", - 11.0, R_Factor, I_Factor); - - if Accuracy_Error_Reported then - -- only report the first error in this test in order to keep - -- lots of failures from producing a huge error log - Error_Low_Bound := 0.0; -- reset - return; - end if; - end loop; - end loop; - - Error_Low_Bound := 0.0; -- reset - exception - when Constraint_Error => - Report.Failed - ("Constraint_Error raised in Identity_Test" & - " for Z=(" & Real'Image (X) & - ", " & Real'Image (Y) & ")"); - when others => - Report.Failed ("exception in Identity_Test" & - " for Z=(" & Real'Image (X) & - ", " & Real'Image (Y) & ")"); - end Identity_Test; - - - procedure Do_Test is - begin - Special_Value_Test; - Exact_Result_Test; - -- test regions where sin and cos have the same sign and - -- about the same magnitude. This will minimize subtraction - -- errors in the identities. - -- See Cody page 17. - Identity_Test (0.0625, 10.0, 0.0625, 10.0); - Identity_Test ( 16.0, 17.0, 16.0, 17.0); - end Do_Test; - end Generic_Check; - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - package Float_Check is new Generic_Check (Float); - - -- check the floating point type with the most digits - type A_Long_Float is digits System.Max_Digits; - package A_Long_Float_Check is new Generic_Check (A_Long_Float); - - ----------------------------------------------------------------------- - ----------------------------------------------------------------------- - - -begin - Report.Test ("CXG2021", - "Check the accuracy of the complex SIN and COS functions"); - - if Verbose then - Report.Comment ("checking Standard.Float"); - end if; - - Float_Check.Do_Test; - - if Verbose then - Report.Comment ("checking a digits" & - Integer'Image (System.Max_Digits) & - " floating point type"); - end if; - - A_Long_Float_Check.Do_Test; - - - Report.Result; -end CXG2021; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a deleted file mode 100644 index f9e4d1cae33..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a +++ /dev/null @@ -1,309 +0,0 @@ --- CXG2022.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 multiplication and division of binary fixed point --- numbers with compatible 'small values produce exact results. --- --- TEST DESCRIPTION: --- Signed, unsigned, and a mixture of signed and unsigned --- binary fixed point values are multiplied and divided. --- The result is checked against the expected "perfect result set" --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- --- --- CHANGE HISTORY: --- 1 Apr 96 SAIC Initial release for 2.1 --- 29 Jan 1998 EDS Repaired fixed point errors ("**" and --- assumptions about 'Small) ---! - -with System; -with Report; -procedure CXG2022 is - Verbose : constant Boolean := False; - -procedure Check_Signed is - type Pairs is delta 2.0 range -2.0 ** (System.Max_Mantissa) .. - 2.0 ** (System.Max_Mantissa) - 1.0; - type Halves is delta 0.5 range -2.0 ** (System.Max_Mantissa-2) .. - 2.0 ** (System.Max_Mantissa-2) - 1.0; - P1, P2, P3, P4 : Pairs; - H1, H2, H3, H4 : Halves; - - procedure Dont_Opt is - -- keep optimizer from knowing the constant value of expressions - begin - if Report.Ident_Bool (False) then - P1 := 2.0; P2 := 4.0; P3 := 6.0; - H1 := -2.0; H2 := 9.0; H3 := 3.0; - end if; - end Dont_Opt; - -begin - H1 := -0.5; - H2 := Halves'First; - H3 := 1.0; - P1 := 12.0; - P2 := Pairs'First; - P3 := Pairs'Last; - Dont_Opt; - - P4 := Pairs (P1 * H1); -- 12.0 * -0.5 - if P4 /= -6.0 then - Report.Failed ("12.0 * -0.5 = " & Pairs'Image (P4)); - end if; - - H4 := Halves (P1 / H1); -- 12.0 / -0.5 - if H4 /= -24.0 then - Report.Failed ("12.0 / -0.5 = " & Halves'Image (H4)); - end if; - - P4 := P3 * H3; -- Pairs'Last * 1.0 - if P4 /= Pairs'Last then - Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4)); - end if; - - P4 := P3 / H3; -- Pairs'Last / 1.0 - if P4 /= Pairs'Last then - Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4)); - end if; - - P4 := P2 * 0.25; -- Pairs'First * 0.25 - if P4 /= Pairs (-2.0 ** (System.Max_Mantissa - 2)) then - Report.Failed ("Pairs'First * 0.25 = " & Pairs'Image (P4)); - end if; - - P4 := 100.5 / H1; -- 100.5 / -0.5 - if P4 = -201.0 then - null; -- Perfect result - elsif Pairs'Small = 2.0 and ( P4 = -200.0 or P4 = -202.0 ) then - null; -- Allowed variation - else - Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) & - " and 100.5/-0.5 = " & Pairs'Image (P4) ); - end if; - - H4 := H1 * H2; -- -0.5 * Halves'First - if H4 /= Halves (2.0 ** (System.Max_Mantissa-3)) then - Report.Failed ("-0.5 * Halves'First =" & Halves'Image (H4) & - " instead of " & - Halves'Image( Halves(2.0 ** (System.Max_Mantissa-3)))); - end if; - -exception - when others => - Report.Failed ("unexpected exception in Check_Signed"); -end Check_Signed; - - - -procedure Check_Unsigned is - type Pairs is delta 2.0 range 0.0 .. 2.0 ** (System.Max_Mantissa+1) - 1.0; - type Halves is delta 0.5 range 0.0 .. 2.0 ** (System.Max_Mantissa-1) - 1.0; - P1, P2, P3, P4 : Pairs; - H1, H2, H3, H4 : Halves; - - procedure Dont_Opt is - -- keep optimizer from knowing the constant value of expressions - begin - if Report.Ident_Bool (False) then - P1 := 2.0; P2 := 4.0; P3 := 6.0; - H1 := 2.0; H2 := 9.0; H3 := 3.0; - end if; - end Dont_Opt; - -begin - H1 := 10.5; - H2 := Halves(2.0 ** (System.Max_Mantissa - 6)); - H3 := 1.0; - P1 := 12.0; - P2 := Pairs'Last / 2; - P3 := Pairs'Last; - Dont_Opt; - - P4 := Pairs (P1 * H1); -- 12.0 * 10.5 - if P4 /= 126.0 then - Report.Failed ("12.0 * 10.5 = " & Pairs'Image (P4)); - end if; - - H4 := Halves (P1 / H1); -- 12.0 / 10.5 - if H4 /= 1.0 and H4 /= 1.5 then - Report.Failed ("12.0 / 10.5 = " & Halves'Image (H4)); - end if; - - P4 := P3 * H3; -- Pairs'Last * 1.0 - if P4 /= Pairs'Last then - Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4)); - end if; - - P4 := P3 / H3; -- Pairs'Last / 1.0 - if P4 /= Pairs'Last then - Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4)); - end if; - - P4 := P1 * 0.25; -- 12.0 * 0.25 - if P4 /= 2.0 and P4 /= 4.0 then - Report.Failed ("12.0 * 0.25 = " & Pairs'Image (P4)); - end if; - - P4 := 100.5 / H1; -- 100.5 / 10.5 = 9.571... - if P4 /= 8.0 and P4 /= 10.0 then - Report.Failed ("100.5/10.5 = " & Pairs'Image (P4)); - end if; - - H4 := H2 * 2; -- 2**(max_mantissa-6) * 2 - if H4 /= Halves(2.0 ** (System.Max_Mantissa-5)) then - Report.Failed ("2**(System.Max_Mantissa-6) * 2=" & Halves'Image (H4) & - " instead of " & - Halves'Image( Halves(2.0 ** (System.Max_Mantissa-5)))); - end if; - -exception - when others => - Report.Failed ("unexpected exception in Check_Unsigned"); -end Check_Unsigned; - - - -procedure Check_Mixed is - type Pairs is delta 2.0 range -2.0 ** (System.Max_Mantissa) .. - 2.0 ** (System.Max_Mantissa) - 1.0; - type Halves is delta 0.5 range 0.0 .. 2.0 ** (System.Max_Mantissa-1) - 1.0; - P1, P2, P3, P4 : Pairs; - H1, H2, H3, H4 : Halves; - - procedure Dont_Opt is - -- keep optimizer from knowing the constant value of expressions - begin - if Report.Ident_Bool (False) then - P1 := 2.0; P2 := 4.0; P3 := 6.0; - H1 := 2.0; H2 := 9.0; H3 := 3.0; - end if; - end Dont_Opt; - -begin - H1 := 10.5; - H2 := Halves(2.0 ** (System.Max_Mantissa - 6)); - H3 := 1.0; - P1 := 12.0; - P2 := -4.0; - P3 := Pairs'Last; - Dont_Opt; - - P4 := Pairs (P1 * H1); -- 12.0 * 10.5 - if P4 /= 126.0 then - Report.Failed ("12.0 * 10.5 = " & Pairs'Image (P4)); - end if; - - H4 := Halves (P1 / H1); -- 12.0 / 10.5 - if H4 /= 1.0 and H4 /= 1.5 then - Report.Failed ("12.0 / 10.5 = " & Halves'Image (H4)); - end if; - - P4 := P3 * H3; -- Pairs'Last * 1.0 - if P4 /= Pairs'Last then - Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4)); - end if; - - P4 := P3 / H3; -- Pairs'Last / 1.0 - if P4 /= Pairs'Last then - Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4)); - end if; - - P4 := P1 * 0.25; -- 12.0 * 0.25 - if P4 = 3.0 then - null; -- Perfect result - elsif Pairs'Small = 2.0 and then ( P4 = 2.0 or P4 = 4.0 ) then - null; -- Allowed deviation - else - Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) & - "and 12.0 * 0.25 = " & Pairs'Image (P4) ); - end if; - - P4 := 100.5 / H1; -- 100.5 / 10.5 = 9.571... - if P4 = 9.0 then - null; -- Perfect result - elsif Pairs'Small = 2.0 and then ( P4 = 8.0 or P4 = 10.0 ) then - null; -- Allowed values - else - Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) & - "and 100.5/10.5 = " & Pairs'Image (P4) ); - end if; - - H4 := H2 * 2; -- 2**(max_mantissa-6) * 2 - if H4 /= Halves(2.0 ** (System.Max_Mantissa-5)) then - Report.Failed ("2**(System.Max_Mantissa-6) * 2=" & Halves'Image (H4) & - " instead of " & - Halves'Image( Halves(2.0 ** (System.Max_Mantissa-5)))); - end if; - - P4 := Pairs(P1 * 6) / P2; -- 12 * 6 / -4 - if (P4 /= -18.0) then - Report.Failed ("12*6/-4 = " & Pairs'Image(P4)); - end if; - - P4 := Halves(P1 * 6.0) / P2; -- 12 * 6 / -4 - if (P4 /= -18.0) then - Report.Failed ("Halves(12*6)/-4 = " & Pairs'Image(P4)); - end if; - -exception - when others => - Report.Failed ("unexpected exception in Check_Mixed"); -end Check_Mixed; - - -begin -- main - Report.Test ("CXG2022", - "Check the accuracy of multiplication and division" & - " of binary fixed point numbers"); - if Verbose then - Report.Comment ("starting signed test"); - end if; - Check_Signed; - - if Verbose then - Report.Comment ("starting unsigned test"); - end if; - Check_Unsigned; - - if Verbose then - Report.Comment ("starting mixed sign test"); - end if; - Check_Mixed; - - Report.Result; -end CXG2022; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a deleted file mode 100644 index 0cdd5574e09..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a +++ /dev/null @@ -1,351 +0,0 @@ --- CXG2023.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 multiplication and division of decimal fixed point --- numbers produce exact results. --- --- TEST DESCRIPTION: --- Check that multiplication and division of decimal fixed point --- numbers produce exact results. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- This test applies only to implementations supporting --- decimal fixed point types of at least 9 digits. --- --- --- CHANGE HISTORY: --- 3 Apr 96 SAIC Initial release for 2.1 --- ---! - -with System; -with Report; -procedure CXG2023 is - Verbose : constant Boolean := False; - -procedure Check_1 is - Num_Digits : constant := 6; - type Pennies is delta 0.01 digits Num_Digits; - type Franklins is delta 100.0 digits Num_Digits; - type Dollars is delta 1.0 digits Num_Digits; - - P1 : Pennies; - F1 : Franklins; - D1 : Dollars; - - -- optimization thwarting functions - - function P (X : Pennies) return Pennies is - begin - if Report.Ident_Bool (True) then - return X; - else - return 3.21; -- never executed - end if; - end P; - - - function F (X : Franklins) return Franklins is - begin - if Report.Ident_Bool (True) then - return X; - else - return 32100.0; -- never executed - end if; - end F; - - - function D (X : Dollars) return Dollars is - begin - if Report.Ident_Bool (True) then - return X; - else - return 321.0; -- never executed - end if; - end D; - - -begin - -- multiplication where one operand is universal real - - P1 := P(0.05) * 200.0; - if P1 /= 10.00 then - Report.Failed ("1 - expected 10.00 got " & Pennies'Image (P1)); - end if; - - D1 := P(0.05) * 100.0; - if D1 /= 5.00 then - Report.Failed ("2 - expected 5.00 got " & Dollars'Image (D1)); - end if; - - F1 := P(0.05) * 50_000.0; - if F1 /= 2500.00 then - Report.Failed ("3 - expected 2500.0 got " & Franklins'Image (F1)); - end if; - - -- multiplication where both operands are decimal fixed - - P1 := P(0.05) * D(-200.0); - if P1 /= -10.00 then - Report.Failed ("4 - expected -10.00 got " & Pennies'Image (P1)); - end if; - - D1 := P(0.05) * P(-100.0); - if D1 /= -5.00 then - Report.Failed ("5 - expected -5.00 got " & Dollars'Image (D1)); - end if; - - F1 := P(-0.05) * F(50_000.0); - if F1 /= -2500.00 then - Report.Failed ("6 - expected -2500.0 got " & Franklins'Image (F1)); - end if; - - -- division where one operand is universal real - - P1 := P(0.05) / 0.001; - if P1 /= 50.00 then - Report.Failed ("7 - expected 50.00 got " & Pennies'Image (P1)); - end if; - - D1 := D(1000.0) / 3.0; - if D1 /= 333.00 then - Report.Failed ("8 - expected 333.00 got " & Dollars'Image (D1)); - end if; - - F1 := P(1234.56) / 0.0001; - if F1 /= 12345600.00 then - Report.Failed ("9 - expected 12345600.0 got " & Franklins'Image (F1)); - end if; - - - -- division where both operands are decimal fixed - - P1 := P(0.05) / D(1.0); - if P1 /= 0.05 then - Report.Failed ("10 - expected 0.05 got " & Pennies'Image (P1)); - end if; - - -- check for truncation toward 0 - D1 := P(-101.00) / P(2.0); - if D1 /= -50.00 then - Report.Failed ("11 - expected -50.00 got " & Dollars'Image (D1)); - end if; - - P1 := P(-102.03) / P(-0.5); - if P1 /= 204.06 then - Report.Failed ("12 - expected 204.06 got " & Pennies'Image (P1)); - end if; - - F1 := P(876.54) / P(0.03); - if F1 /= 29200.00 then - Report.Failed ("13 - expected 29200.0 got " & Franklins'Image (F1)); - end if; - -exception - when others => - Report.Failed ("unexpected exception in Check_1"); -end Check_1; - -generic - type Pennies is delta<> digits<>; - type Dollars is delta<> digits<>; - type Franklins is delta<> digits<>; -procedure Generic_Check; -procedure Generic_Check is - - -- the following code is copied directly from the - -- above procedure Check_1 - - P1 : Pennies; - F1 : Franklins; - D1 : Dollars; - - -- optimization thwarting functions - - function P (X : Pennies) return Pennies is - begin - if Report.Ident_Bool (True) then - return X; - else - return 3.21; -- never executed - end if; - end P; - - - function F (X : Franklins) return Franklins is - begin - if Report.Ident_Bool (True) then - return X; - else - return 32100.0; -- never executed - end if; - end F; - - - function D (X : Dollars) return Dollars is - begin - if Report.Ident_Bool (True) then - return X; - else - return 321.0; -- never executed - end if; - end D; - - -begin - -- multiplication where one operand is universal real - - P1 := P(0.05) * 200.0; - if P1 /= 10.00 then - Report.Failed ("1 - expected 10.00 got " & Pennies'Image (P1)); - end if; - - D1 := P(0.05) * 100.0; - if D1 /= 5.00 then - Report.Failed ("2 - expected 5.00 got " & Dollars'Image (D1)); - end if; - - F1 := P(0.05) * 50_000.0; - if F1 /= 2500.00 then - Report.Failed ("3 - expected 2500.0 got " & Franklins'Image (F1)); - end if; - - -- multiplication where both operands are decimal fixed - - P1 := P(0.05) * D(-200.0); - if P1 /= -10.00 then - Report.Failed ("4 - expected -10.00 got " & Pennies'Image (P1)); - end if; - - D1 := P(0.05) * P(-100.0); - if D1 /= -5.00 then - Report.Failed ("5 - expected -5.00 got " & Dollars'Image (D1)); - end if; - - F1 := P(-0.05) * F(50_000.0); - if F1 /= -2500.00 then - Report.Failed ("6 - expected -2500.0 got " & Franklins'Image (F1)); - end if; - - -- division where one operand is universal real - - P1 := P(0.05) / 0.001; - if P1 /= 50.00 then - Report.Failed ("7 - expected 50.00 got " & Pennies'Image (P1)); - end if; - - D1 := D(1000.0) / 3.0; - if D1 /= 333.00 then - Report.Failed ("8 - expected 333.00 got " & Dollars'Image (D1)); - end if; - - F1 := P(1234.56) / 0.0001; - if F1 /= 12345600.00 then - Report.Failed ("9 - expected 12345600.0 got " & Franklins'Image (F1)); - end if; - - - -- division where both operands are decimal fixed - - P1 := P(0.05) / D(1.0); - if P1 /= 0.05 then - Report.Failed ("10 - expected 0.05 got " & Pennies'Image (P1)); - end if; - - -- check for truncation toward 0 - D1 := P(-101.00) / P(2.0); - if D1 /= -50.00 then - Report.Failed ("11 - expected -50.00 got " & Dollars'Image (D1)); - end if; - - P1 := P(-102.03) / P(-0.5); - if P1 /= 204.06 then - Report.Failed ("12 - expected 204.06 got " & Pennies'Image (P1)); - end if; - - F1 := P(876.54) / P(0.03); - if F1 /= 29200.00 then - Report.Failed ("13 - expected 29200.0 got " & Franklins'Image (F1)); - end if; - -end Generic_Check; - - -procedure Check_G6 is - Num_Digits : constant := 6; - type Pennies is delta 0.01 digits Num_Digits; - type Franklins is delta 100.0 digits Num_Digits; - type Dollars is delta 1.0 digits Num_Digits; - - procedure G is new Generic_Check (Pennies, Dollars, Franklins); -begin - G; -end Check_G6; - - -procedure Check_G9 is - Num_Digits : constant := 9; - type Pennies is delta 0.01 digits Num_Digits; - type Franklins is delta 100.0 digits Num_Digits; - type Dollars is delta 1.0 digits Num_Digits; - - procedure G is new Generic_Check (Pennies, Dollars, Franklins); -begin - G; -end Check_G9; - - -begin -- main - Report.Test ("CXG2023", - "Check the accuracy of multiplication and division" & - " of decimal fixed point numbers"); - - if Verbose then - Report.Comment ("starting Check_1"); - end if; - Check_1; - - if Verbose then - Report.Comment ("starting Check_G6"); - end if; - Check_G6; - - if Verbose then - Report.Comment ("starting Check_G9"); - end if; - Check_G9; - - Report.Result; -end CXG2023; diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a deleted file mode 100644 index 55648283eba..00000000000 --- a/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a +++ /dev/null @@ -1,191 +0,0 @@ --- CXG2024.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 multiplication and division of decimal --- and binary fixed point numbers that result in a --- decimal fixed point type produce acceptable results. --- --- TEST DESCRIPTION: --- Multiplication and division of mixed binary and decimal --- values are performed. Identity functions are used so --- that the operands of the expressions will not be seen --- as static by the compiler. --- --- SPECIAL REQUIREMENTS --- The Strict Mode for the numerical accuracy must be --- selected. The method by which this mode is selected --- is implementation dependent. --- --- APPLICABILITY CRITERIA: --- This test applies only to implementations supporting the --- Numerics Annex. --- This test only applies to the Strict Mode for numerical --- accuracy. --- This test applies only to implementations supporting --- decimal fixed point types of at least 9 digits. --- --- --- CHANGE HISTORY: --- 4 Apr 96 SAIC Initial release for 2.1 --- 17 Aug 96 SAIC Removed checks for close results --- ---! - -with System; -with Report; -procedure CXG2024 is - -procedure Do_Check is - Num_Digits : constant := 9; - type Pennies is delta 0.01 digits Num_Digits; - type Dollars is delta 1.0 digits Num_Digits; - - type Signed_Sixteenths is delta 0.0625 - range -2.0 ** (System.Max_Mantissa-5) .. - 2.0 ** (System.Max_Mantissa-5) - 1.0; - type Unsigned_Sixteenths is delta 0.0625 - range 0.0 .. 2.0 ** (System.Max_Mantissa-4) - 1.0; - - P1 : Pennies; - D1 : Dollars; - - -- optimization thwarting functions - - function P (X : Pennies) return Pennies is - begin - if Report.Ident_Bool (True) then - return X; - else - return 3.21; -- never executed - end if; - end P; - - - function D (X : Dollars) return Dollars is - begin - if Report.Ident_Bool (True) then - return X; - else - return 321.0; -- never executed - end if; - end D; - - - function US (X : Unsigned_Sixteenths) return Unsigned_Sixteenths is - begin - if Report.Ident_Bool (True) then - return X; - else - return 321.0; -- never executed - end if; - end US; - - - function SS (X : Signed_Sixteenths) return Signed_Sixteenths is - begin - if Report.Ident_Bool (True) then - return X; - else - return 321.0; -- never executed - end if; - end SS; - - -begin - - P1 := P(0.05) * SS(-200.0); - if P1 /= -10.00 then - Report.Failed ("1 - expected -10.00 got " & Pennies'Image (P1)); - end if; - - D1 := P(0.05) * SS(-100.0); - if D1 /= -5.00 then - Report.Failed ("2 - expected -5.00 got " & Dollars'Image (D1)); - end if; - - P1 := P(0.05) * US(200.0); - if P1 /= 10.00 then - Report.Failed ("3 - expected 10.00 got " & Pennies'Image (P1)); - end if; - - D1 := P(-0.05) * US(100.0); - if D1 /= -5.00 then - Report.Failed ("4 - expected -5.00 got " & Dollars'Image (D1)); - end if; - - - - P1 := P(0.05) / US(1.0); - if P1 /= 0.05 then - Report.Failed ("6 - expected 0.05 got " & Pennies'Image (P1)); - end if; - - - -- check rounding - - D1 := Dollars'Round (Pennies (P(-101.00) / US(2.0))); - if D1 /= -51.00 then - Report.Failed ("11 - expected -51.00 got " & Dollars'Image (D1)); - end if; - - D1 := Dollars'Round (Pennies (P(101.00) / US(2.0))); - if D1 /= 51.00 then - Report.Failed ("12 - expected 51.00 got " & Dollars'Image (D1)); - end if; - - D1 := Dollars'Round (Pennies (SS(-101.00) / P(2.0))); - if D1 /= -51.00 then - Report.Failed ("13 - expected -51.00 got " & Dollars'Image (D1)); - end if; - - D1 := Dollars'Round (Pennies (US(101.00) / P(2.0))); - if D1 /= 51.00 then - Report.Failed ("14 - expected 51.00 got " & Dollars'Image (D1)); - end if; - - - - P1 := P(-102.03) / SS(-0.5); - if P1 /= 204.06 then - Report.Failed ("15 - expected 204.06 got " & Pennies'Image (P1)); - end if; - - -exception - when others => - Report.Failed ("unexpected exception in Do_Check"); -end Do_Check; - - -begin -- main - Report.Test ("CXG2024", - "Check the accuracy of multiplication and division" & - " of mixed decimal and binary fixed point numbers"); - - Do_Check; - - Report.Result; -end CXG2024; diff --git a/gcc/testsuite/g++.dg/abi/layout2.C b/gcc/testsuite/g++.dg/abi/layout2.C index fb4e1e5d9ff..d9ccda8a074 100644 --- a/gcc/testsuite/g++.dg/abi/layout2.C +++ b/gcc/testsuite/g++.dg/abi/layout2.C @@ -1,5 +1,7 @@ // Red Hat bugzilla 65210 // { dg-do run } +// APPLE LOCAL Apple has specific long double warning message then FSF +// { dg-options "-Wno-long-double" { target *-apple-darwin* } } struct A { int a; diff --git a/gcc/testsuite/g++.dg/align-test-1.C b/gcc/testsuite/g++.dg/align-test-1.C new file mode 100644 index 00000000000..e3df21d6d3b --- /dev/null +++ b/gcc/testsuite/g++.dg/align-test-1.C @@ -0,0 +1,347 @@ +/* APPLE LOCAL file Macintosh alignment */ + +/* { dg-do run } */ +/* { dg-options "-Wno-long-long" } */ + +/* + * Macintosh compiler alignment test for C++. + * Fred Forsman + * Apple Computer, Inc. + * (C) 2000-2001. + * Last modified 2002-5-24. + */ + + /* Check whether we are testing GCC 3 or later. If so, it has a + different scheme for laying out classes: members of a derived + class can be laid out starting in the padding at the end of the + base class. */ +#ifdef __GNUC__ +#if __GNUC__ >= 3 + #define GCC3 1 +#endif +#endif + +#include <stdio.h> +#include <stddef.h> +#include <string.h> + +extern "C" void abort (void); + +#define Q(x) #x, x + +typedef unsigned char UINT8; +typedef unsigned short UINT16; +typedef unsigned long UINT32; + +static int bad_option = 0; +static int flag_verbose = 0; +static int nbr_failures = 0; + +/* === classes === */ + +class C1 { + static const int f1 = 1; + UINT8 f2; +}; + +class C2 { + static int f1; + UINT8 f2; +}; + +class C3 { + public: + enum E1 { + f1 = 1 + }; + protected: + UINT8 f2; +}; + +class C4 { + UINT8 f1; + static const int f2 = 1; +}; + +class C5 { + UINT8 f2; + static int f1; +}; + +class C6 { + UINT8 f1; + enum E1 { + f2 = 1 + }; +}; + +class C7 { + /* empty base class */ +}; + +#pragma options align=mac68k + +class C8 { + /* empty base class */ +}; + +class C9: public C8 { + public: + UINT8 f1; +}; + +#pragma options align=reset + +/* What is offset of first field after an empty base class? */ +class C10: public C7 { + public: + UINT8 f1; +}; + +/* GCC3 starts layout of derived class in padding at end of base class. */ +class C11 { + public: + UINT32 f1; + UINT8 f2; +}; + +class C12: public C11 { + public: + UINT8 f3; +}; + +/* Check whether compiler will reorder members to take advantage of + padding. If the compiler did this (which it does not appear to + do), f3 and f4 in C14 would be reordered to take advantage of the + padding at the end of the base class. */ +class C13 { + public: + UINT32 f1; + UINT16 f2; +}; + +class C14: public C13 { + public: + UINT32 f3; + UINT16 f4; +}; + +/* Tests for double aligned base class */ + +class C15 { + public: + double f1; + long f2; +}; + +class C16: public C15 { +}; + +class C17: public C15 { + public: + long f3; +}; + +class C18: public C16 { + public: + char f3; +}; + +class C19: public C17 { + public: + char f4; +}; + +/* Tests for alignment in class with v-table pointer */ + +class C20 { + public: + double f1; + virtual void func1(void); +}; + +/* === vectors === */ + +#ifdef __VEC__ +class VC1 { + public: + vector signed short f1; + UINT8 f2; +}; + +typedef struct VS1 { + VC1 f1; + UINT8 f2; +} VS1; + +class VC2: public VC1 { + public: + UINT8 f1; +}; + +typedef struct VS2 { + UINT8 f1; + VC2 f2; + UINT8 f3; +} VS2; + +class VC3 { + public: + vector signed short f1; + virtual void func1(void); +}; + +#endif + +/* === bools === */ + +typedef struct B1 { + bool f1; + UINT8 f2; +} B1; + +typedef struct B2 { + UINT8 f1; + bool f2; +} B2; + + +static void check(char * rec_name, int actual, int expected, char * comment) +{ + if (flag_verbose || (actual != expected)) { + printf("%-20s = %2d (%2d) ", rec_name, actual, expected); + if (actual != expected) { + printf("*** FAIL"); + nbr_failures++; + } else + printf(" PASS"); + printf(": %s\n", comment); + } +} + +static void check_option(char *option) +{ + if (*option == '-') { + if (strcmp(option, "-v") == 0) + flag_verbose = 1; + else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } + } else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } +} + +int main(int argc, char *argv[]) +{ + int i; + + for (i = 1; i < argc; i++) + check_option(argv[i]); + + if (bad_option) + return 1; + + check(Q(sizeof(C1)), 1, "const as 1st field"); + check(Q(sizeof(C2)), 1, "static as 1st field"); + check(Q(sizeof(C3)), 1, "enum as 1st field"); + check(Q(sizeof(C4)), 1, "const as 2nd field"); + check(Q(sizeof(C5)), 1, "static as 2nd field"); + check(Q(sizeof(C6)), 1, "enum as 2nd field"); + check(Q(sizeof(C7)), 1, "empty class, power mode"); + check(Q(sizeof(C8)), 2, "empty class, mac68k mode"); + check(Q(sizeof(C9)), 2, "class with empty base class and one char, mac68k"); + check(Q(offsetof(C9, f1)), 0, "offset of 1st field after empty base class"); /* { dg-warning "invalid access" "" } */ + /* { dg-warning "macro was used incorrectly" "" { target *-*-* } 256 } */ + check(Q(sizeof(C10)), 1, "class based on an empty class, power mode"); + check(Q(sizeof(C11)), 8, "class with long, char"); +#ifdef GCC3 + check(Q(sizeof(C12)), 8, "class with base class with long, char and its own char"); +#else + check(Q(sizeof(C12)), 12, "class with base class with long, char and its own char"); +#endif +#ifdef GCC3 + check(Q(offsetof(C12, f3)), 5, "offset of 1st field in class with a base class with a long, char"); /* { dg-warning "invalid access" "" } */ + /* { dg-warning "macro was used incorrectly" "" { target *-*-* } 266 } */ +#else + check(Q(offsetof(C12, f3)), 8, "offset of 1st field in class with a base class with a long, char"); +#endif + check(Q(sizeof(C13)), 8, "class with long, short"); + check(Q(sizeof(C14)), 16, "derived class with short, long"); + check(Q(offsetof(C14, f3)), 8, "offset of 1st field after base class with padding"); /* { dg-warning "invalid access" "" } */ + /* { dg-warning "macro was used incorrectly" "" { target *-*-* } 273 } */ + check(Q(offsetof(C14, f4)), 12, "offset of 2nd field after base class with padding"); /* { dg-warning "invalid access" "" } */ + /* { dg-warning "macro was used incorrectly" "" { target *-*-* } 275 } */ + + check(Q(sizeof(C15)), 16, "base class with double, long"); + check(Q(sizeof(C16)), 16, "empty derived class with base with double, long"); +#ifdef GCC3 + check(Q(sizeof(C17)), 16, "derived class with base with double, long and its own long"); +#else + check(Q(sizeof(C17)), 24, "derived class with base with double, long and its own long"); +#endif +#ifdef GCC3 + check(Q(sizeof(C18)), 16, "derived class based on empty derived class with base with double, long"); +#else + check(Q(sizeof(C18)), 24, "derived class based on empty derived class with base with double, long"); +#endif +#ifdef GCC3 + check(Q(sizeof(C19)), 24, "derived class based on derived class with base with double, long and its own long"); +#else + check(Q(sizeof(C19)), 32, "derived class based on derived class with base with double, long and its own long"); +#endif +#ifdef GCC3 + check(Q(sizeof(C20)), 16, "class with double and v-table ptr"); + check(Q(offsetof(C20, f1)), 8, "offset of double 1st field in class with v-table ptr"); /* { dg-warning "invalid access" "" } */ + /* { dg-warning "macro was used incorrectly" "" { target *-*-* } 297 } */ +#else + check(Q(sizeof(C20)), 16, "class with double and v-table ptr"); + check(Q(offsetof(C20, f1)), 0, "offset of 1st field in class with v-table ptr"); +#endif + + /* Vector tests */ +#ifdef __VEC__ + check(Q(sizeof(VC1)), 32, "class with vector as 1st field"); + check(Q(sizeof(VS1)), 48, "struct with a class with a vector as 1st field"); +#ifdef GCC3 + check(Q(sizeof(VC2)), 32, "class with base class containing a vector"); +#else + check(Q(sizeof(VC2)), 48, "class with base class containing a vector"); +#endif +#ifdef GCC3 + check(Q(offsetof(VC2, f1)), 17, "offset of 1st field after base class with vector, char, and padding"); +#else + check(Q(offsetof(VC2, f1)), 32, "offset of 1st field after base class with vector, char, and padding"); +#endif +#ifdef GCC3 + check(Q(sizeof(VS2)), 64, "struct with a char, class with a vector, char"); +#else + check(Q(sizeof(VS2)), 80, "struct with a char, class with a vector, char"); +#endif + check(Q(offsetof(VS2, f2)), 16, "offset of class with a vector in a struct with char, class..."); +#ifdef GCC3 + check(Q(offsetof(VS2, f3)), 48, "offset of 2nd char in a struct with char, class, char"); +#else + check(Q(offsetof(VS2, f3)), 64, "offset of 2nd char in a struct with char, class, char"); +#endif +#ifdef GCC3 + check(Q(sizeof(VC3)), 32, "class with a vector and v-table ptr"); + check(Q(offsetof(VC3, f1)), 16, "offset vector in class with a vector and v-table ptr"); +#else + check(Q(sizeof(VC3)), 32, "class with a vector and v-table ptr"); + check(Q(offsetof(VC3, f1)), 0, "offset vector in class with a vector and v-table ptr"); +#endif +#endif + + /* bool tests */ + check(Q(sizeof(bool)), 4, "bool data type"); + check(Q(sizeof(B1)), 8, "struct with bool, char"); + check(Q(sizeof(B2)), 8, "struct with char, bool"); + + if (nbr_failures > 0) + return 1; + else + return 0; +} diff --git a/gcc/testsuite/g++.dg/altivec-1.C b/gcc/testsuite/g++.dg/altivec-1.C new file mode 100644 index 00000000000..6bda7094db0 --- /dev/null +++ b/gcc/testsuite/g++.dg/altivec-1.C @@ -0,0 +1,12 @@ +/* APPLE LOCAL file AltiVec */ +/* Test for static_cast<...> among AltiVec types. */ +/* { dg-do compile { target powerpc*-*-* } } */ +/* { dg-options "-faltivec" } */ + +struct Foo2 { + vector unsigned int vui; + vector signed int As_vsi() { + return static_cast<vector signed int>(vui); /* { dg-bogus "invalid static_cast" } */ + } +}; + diff --git a/gcc/testsuite/g++.dg/altivec-2.C b/gcc/testsuite/g++.dg/altivec-2.C new file mode 100644 index 00000000000..0b2f3751a24 --- /dev/null +++ b/gcc/testsuite/g++.dg/altivec-2.C @@ -0,0 +1,15 @@ +/* APPLE LOCAL file AltiVec */ +/* Test for distinguishing 'vector bool ...' from 'vector unsigned ...' + types by the front-end. */ +/* { dg-do compile { target powerpc*-*-* } } */ +/* { dg-options "-faltivec" } */ + +struct Foo1 { + void foo(vector unsigned char) { } + void foo(vector bool char) { } /* { dg-bogus "has already been declared" } */ + void bar(vector unsigned short) { } + void bar(vector bool short) { } /* { dg-bogus "has already been declared" } */ + void baz(vector unsigned int) { } + void baz(vector bool int) { } /* { dg-bogus "has already been declared" } */ +}; + diff --git a/gcc/testsuite/g++.dg/altivec-3.C b/gcc/testsuite/g++.dg/altivec-3.C new file mode 100644 index 00000000000..77084a1d824 --- /dev/null +++ b/gcc/testsuite/g++.dg/altivec-3.C @@ -0,0 +1,21 @@ +/* APPLE LOCAL file AltiVec */ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-options "-faltivec -Wall" } */ + +/* This test checks if AltiVec builtins accept const-qualified + arguments. */ + +int main (int argc, const char * argv[]) +{ + int i; + const float cf = 1.0; + vector float v; + const vector float cv = (vector float)(1.0, 2.0, 3.0, 4.0); + + vec_dst(&cv, i, 0); + v = vec_ld(0, &cv); + v = vec_lde(0, &cf); + vec_lvsl(0, &cf); + + return 0; +} diff --git a/gcc/testsuite/g++.dg/altivec-4.C b/gcc/testsuite/g++.dg/altivec-4.C new file mode 100644 index 00000000000..1b33365408b --- /dev/null +++ b/gcc/testsuite/g++.dg/altivec-4.C @@ -0,0 +1,129 @@ +/* APPLE LOCAL file AltiVec */ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-options "-faltivec -Wno-long-double" } */ + +/* Test for correct handling of AltiVec constants passed + through '...' (va_arg). */ + +#include <stdarg.h> +#include <stdio.h> +#include <stdlib.h> + +#define CHECK_INVARIANT(expr) \ + if (!(expr)) { \ + printf ("ASSERT FAILED: %d: %s\n", __LINE__, #expr); \ + abort (); \ + } + +struct foo { int x; int y; }; +struct vfoo { int x; __vector signed int v; int y; }; +union u { __vector signed int v; signed int i[4]; }; + +struct foo x_g = { 3, 4}; +struct vfoo vx_g = { 10, (vector signed int)(11, 12, 13, 14), 15 }; +__vector signed int v_g = (vector signed int) (22, 23, 24, 25); +struct vfoo vx2_g = { 30, (vector signed int)(31, 32, 33, 34), 35 }; +__vector signed int v2_g = (vector signed int)(40, 41, 42, 43); +int i_1 = 99, i_2 = 33; +double d_2 = 1.5, d_3 = 1.75; +long double ld_1 = 1.25; + +void bar (int i, ... ) +{ + struct foo xi; + double d; + long double ld; + float f; + char c; + short s; + va_list ap; + va_start(ap, i); + xi = va_arg(ap, struct foo); + s = (short)va_arg(ap, int); + f = (float)va_arg(ap, double); + ld = va_arg(ap, long double); + c = (char)va_arg(ap, int); + d = va_arg(ap, double); + va_end(ap); + + CHECK_INVARIANT (xi.x == x_g.x && xi.y == x_g.y); + CHECK_INVARIANT (s == (short)i_2); + CHECK_INVARIANT (f == (float)d_2); + CHECK_INVARIANT (ld == ld_1); + CHECK_INVARIANT (c == (char)i_1); + CHECK_INVARIANT (d == d_3); +} + +void baz (int i, ... ) +{ + struct vfoo vx, vx2; + __vector signed int v_i, v2_i; + int j, k, l; + va_list ap; + va_start(ap, i); + v_i = va_arg(ap, __vector signed int); /* { dg-bogus "non-POD type" } */ + j = va_arg(ap, int); + vx = va_arg(ap, struct vfoo); /* { dg-bogus "non-POD type" } */ + k = va_arg(ap, int); + v2_i = va_arg(ap, __vector signed int); /* { dg-bogus "non-POD type" } */ + l = va_arg(ap, int); + vx2 = va_arg(ap, struct vfoo); /* { dg-bogus "non-POD type" } */ + va_end(ap); + + CHECK_INVARIANT (vec_all_eq (v_i, v_g)); + CHECK_INVARIANT (j == i_1); + CHECK_INVARIANT (vx.x == vx_g.x && vec_all_eq(vx.v, vx_g.v) && vx.y == vx_g.y); + CHECK_INVARIANT (k == i_1); + CHECK_INVARIANT (vec_all_eq (v2_i, v2_g)); + CHECK_INVARIANT (l == i_1); + CHECK_INVARIANT (vx2.x == vx2_g.x && vec_all_eq(vx2.v, vx2_g.v) && vx2.y == vx2_g.y); +} + +void quux (int i, ... ) +{ + __vector signed int v_i, v2_i; + union u vi, v2i; + va_list ap; + va_start(ap, i); + v_i = va_arg(ap, __vector signed int); + v2_i = va_arg(ap, __vector signed int); + va_end(ap); + vi.v = v_i; + v2i.v = v2_i; + + CHECK_INVARIANT (vec_all_eq (v_i, v_g)); + CHECK_INVARIANT (vec_all_eq (v2_i, v_g)); + CHECK_INVARIANT (vec_all_eq (vi.v, v_g)); + CHECK_INVARIANT (vec_all_eq (v2i.v, v_g)); +} + +void baz2 (int i, ... ) +{ + struct vfoo vx; + union u vxi; + va_list ap; + va_start(ap, i); + vx = va_arg(ap, struct vfoo); + va_end(ap); + vxi.v = vx.v; + + CHECK_INVARIANT (vx.x == vx_g.x && vec_all_eq(vx.v, vx_g.v) && vx.y == vx_g.y); + CHECK_INVARIANT (vec_all_eq (vxi.v, vx_g.v)); +} + +int main(void) +{ + CHECK_INVARIANT (sizeof(struct foo) == 8 && sizeof(struct vfoo) == 48); + + bar(i_1, x_g, (short)i_2, (float)d_2, ld_1, (char)i_1, d_3); + baz(i_1, v_g, /* { dg-bogus "non-POD type" "" { target *-*-* } 122 } */ + i_1, vx_g, /* { dg-bogus "non-POD type" "" { target *-*-* } 122 } */ + i_1, v2_g, /* { dg-bogus "non-POD type" "" { target *-*-* } 122 } */ + i_1, vx2_g); /* { dg-bogus "non-POD type" } */ + quux(i_1, v_g, /* { dg-bogus "non-POD type" "" { target *-*-* } 124 } */ + v_g); /* { dg-bogus "non-POD type" } */ + baz2(i_1, vx_g); /* { dg-bogus "non-POD type" } */ + + return 0; +} + diff --git a/gcc/testsuite/g++.dg/altivec-5.C b/gcc/testsuite/g++.dg/altivec-5.C new file mode 100644 index 00000000000..4c5a21ad46f --- /dev/null +++ b/gcc/testsuite/g++.dg/altivec-5.C @@ -0,0 +1,19 @@ +/* APPLE LOCAL file AltiVec */ +/* Test for AltiVec type overloading. */ +/* { dg-do compile { target powerpc*-*-* } } */ +/* { dg-options "-faltivec" } */ + void foo(vector unsigned char) { } + void foo(vector signed char) { } + void foo(vector bool char) { } + void foo(vector unsigned short) { } + void foo(vector signed short) { } + void foo(vector bool short) { } + void foo(vector unsigned long) { } + void foo(vector signed long) { } + void foo(vector bool long) { } + void foo(vector float) { } + void foo(vector pixel) { } + void foo(int) { } + void foo(unsigned int) { } + void foo(float) { } + void foo(bool) { } diff --git a/gcc/testsuite/g++.dg/apple-altivec-1.C b/gcc/testsuite/g++.dg/apple-altivec-1.C new file mode 100644 index 00000000000..c070de43f6c --- /dev/null +++ b/gcc/testsuite/g++.dg/apple-altivec-1.C @@ -0,0 +1,9 @@ +/* APPLE LOCAL file AltiVec */ +/* { dg-do compile { target powerpc*-*-* } } */ +/* { dg-options "-faltivec" } */ + +void foo() { + vector bool int boolVector = (vector bool int) vec_splat_u32(3); + boolVector = vec_sld( boolVector, boolVector, + 1 ); /* { dg-bogus "no instance of overloaded" } */ +} diff --git a/gcc/testsuite/g++.dg/charset/asm1.c b/gcc/testsuite/g++.dg/charset/asm1.c deleted file mode 100644 index 9c0ff2866b0..00000000000 --- a/gcc/testsuite/g++.dg/charset/asm1.c +++ /dev/null @@ -1,14 +0,0 @@ -/* { dg-do compile { target *-*-* } } - { dg-require-iconv "IBM-1047" } - { dg-final { scan-assembler ".ascii bar" } } - { dg-final { scan-assembler ".ascii foo" } } - */ -extern int x, y; - -asm (".ascii bar"); - -int foo (void) -{ - __asm__ (".ascii foo"); - return 0; -} diff --git a/gcc/testsuite/g++.dg/charset/asm2.c b/gcc/testsuite/g++.dg/charset/asm2.c deleted file mode 100644 index 8d8dbbb524d..00000000000 --- a/gcc/testsuite/g++.dg/charset/asm2.c +++ /dev/null @@ -1,33 +0,0 @@ -/* Test for complex asm statements. Make sure it compiles - then test for some of the asm statements not being translated. */ -/* { dg-do compile { target i?86-*-* } } - { dg-require-iconv "IBM-1047" } - { dg-final { scan-assembler "std" } } - { dg-final { scan-assembler "cld" } } - { dg-final { scan-assembler "rep" } } - { dg-final { scan-assembler "movsb" } } */ -#define size_t int -void * -memmove (void *__dest, __const void *__src, size_t __n) -{ - register unsigned long int __d0, __d1, __d2; - if (__dest < __src) - __asm__ __volatile__ - ("cld\n\t" - "rep\n\t" - "movsb" - : "=&c" (__d0), "=&S" (__d1), "=&D" (__d2) - : "0" (__n), "1" (__src), "2" (__dest) - : "memory"); - else - __asm__ __volatile__ - ("std\n\t" - "rep\n\t" - "movsb\n\t" - "cld" - : "=&c" (__d0), "=&S" (__d1), "=&D" (__d2) - : "0" (__n), "1" (__n - 1 + (const char *) __src), - "2" (__n - 1 + (char *) __dest) - : "memory"); - return __dest; -} diff --git a/gcc/testsuite/g++.dg/charset/asm3.c b/gcc/testsuite/g++.dg/charset/asm3.c deleted file mode 100644 index cd850c3e81f..00000000000 --- a/gcc/testsuite/g++.dg/charset/asm3.c +++ /dev/null @@ -1,10 +0,0 @@ -/* Simple asm test. */ -/* { dg-do compile } - { dg-require-iconv "IBM-1047" } - { dg-final { scan-assembler "foo" } } */ -extern int bar; - -int main (void) -{ - asm ("foo %0" : "=r" (bar)); -} diff --git a/gcc/testsuite/g++.dg/charset/asm4.c b/gcc/testsuite/g++.dg/charset/asm4.c deleted file mode 100644 index fa93f40fdaf..00000000000 --- a/gcc/testsuite/g++.dg/charset/asm4.c +++ /dev/null @@ -1,8 +0,0 @@ -/* Test for string translation. */ -/* { dg-do compile } - { dg-require-iconv "IBM-1047" } - { dg-final { scan-assembler-not "translate" } } */ -void foo (void) -{ - asm ("xx" : : "r"("translate") : "cc"); -} diff --git a/gcc/testsuite/g++.dg/charset/attribute1.c b/gcc/testsuite/g++.dg/charset/attribute1.c deleted file mode 100644 index 993c7934c80..00000000000 --- a/gcc/testsuite/g++.dg/charset/attribute1.c +++ /dev/null @@ -1,10 +0,0 @@ -/* Test for attribute non-translation. */ -/* { dg-do compile } - { dg-require-iconv "IBM-1047" } - { dg-final { scan-assembler "foo" } } */ -int walrus __attribute__ ((section (".foo"))); - -int main (void) -{ - return 0; -} diff --git a/gcc/testsuite/g++.dg/charset/attribute2.c b/gcc/testsuite/g++.dg/charset/attribute2.c deleted file mode 100644 index 3cb766aa63a..00000000000 --- a/gcc/testsuite/g++.dg/charset/attribute2.c +++ /dev/null @@ -1,8 +0,0 @@ -/* Test to make sure that invalid attributes aren't translated. - If error recovery is ever testable then "foobar" should be - translated. */ -/* { dg-do compile } - { dg-require-iconv "IBM-1047" } -*/ -int foo __attribute__ ((walrus)); /* { dg-error "walrus" "ignored" } */ -char x[] = "foobar"; diff --git a/gcc/testsuite/g++.dg/charset/extern1.cc b/gcc/testsuite/g++.dg/charset/extern1.cc deleted file mode 100644 index 2a68ab7cf78..00000000000 --- a/gcc/testsuite/g++.dg/charset/extern1.cc +++ /dev/null @@ -1,15 +0,0 @@ -/* Test extern statments not being translated. */ -/* { dg-do compile } - { dg-require-iconv "IBM-1047" } -*/ - -extern "C" { - - -int testbug (void) { - - return 0; - -} - -} //extern block diff --git a/gcc/testsuite/g++.dg/charset/extern2.cc b/gcc/testsuite/g++.dg/charset/extern2.cc deleted file mode 100644 index 82157a6fea4..00000000000 --- a/gcc/testsuite/g++.dg/charset/extern2.cc +++ /dev/null @@ -1,5 +0,0 @@ -/* Check that we push the declaration and then continue translation. */ -/* { dg-do compile } - { dg-require-iconv "IBM-1047" } - { dg-final { scan-assembler-not "foobar" } } */ -extern "C" { char *foo = "foobar"; } diff --git a/gcc/testsuite/g++.dg/charset/string.c b/gcc/testsuite/g++.dg/charset/string.c deleted file mode 100644 index 375e28a2ed6..00000000000 --- a/gcc/testsuite/g++.dg/charset/string.c +++ /dev/null @@ -1,5 +0,0 @@ -/* Simple character translation test. */ -/* { dg-do compile } - { dg-require-iconv "IBM-1047" } - { dg-final { scan-assembler-not "string foobar" } } */ -char *foo = "string foobar"; diff --git a/gcc/testsuite/g++.dg/const-cfstring-1.C b/gcc/testsuite/g++.dg/const-cfstring-1.C new file mode 100644 index 00000000000..23bfb0e4ee7 --- /dev/null +++ b/gcc/testsuite/g++.dg/const-cfstring-1.C @@ -0,0 +1,26 @@ +/* APPLE LOCAL file constant cfstrings */ +/* Test whether the __builtin__CFStringMakeConstantString + "function" fails gracefully when handed a non-constant + argument. This will only work on MacOS X 10.1.2 and later. */ +/* Developed by Ziemowit Laski <zlaski@apple.com>. */ + +/* { dg-do compile { target *-*-darwin* } } */ +/* { dg-options "-fconstant-cfstrings" } */ + +#import <CoreFoundation/CFString.h> + +#ifdef __CONSTANT_CFSTRINGS__ +#undef CFSTR +#define CFSTR(STR) ((CFStringRef) __builtin___CFStringMakeConstantString (STR)) +#endif + +extern int cond; +extern const char *func(void); + +int main(void) { + CFStringRef s1 = CFSTR("Str1"); + CFStringRef s2 = CFSTR(cond? "Str2": "Str3"); /* { dg-error "CFString literal expression is not constant" } */ + CFStringRef s3 = CFSTR(func()); /* { dg-error "CFString literal expression is not constant" } */ + + return 0; +} diff --git a/gcc/testsuite/g++.dg/debug/debug8.C b/gcc/testsuite/g++.dg/debug/debug8.C index 1f8a18ac8ac..4a4b55a190d 100644 --- a/gcc/testsuite/g++.dg/debug/debug8.C +++ b/gcc/testsuite/g++.dg/debug/debug8.C @@ -1,2 +1,27 @@ -struct t{}; -struct g : public t{}; +// Check -gstabs +// Contributed by Devang Patel dpatel@apple.com +// { dg-do compile } +class LcBase +{ +public: + virtual ~LcBase(); +protected: + LcBase(); +}; + +class LcDerive : public LcBase +{ +public: + LcDerive(); + ~LcDerive(); +}; + +LcDerive::LcDerive() +: LcBase() +{ +} + +LcDerive::~LcDerive() +{ +} + diff --git a/gcc/testsuite/g++.dg/eh/spec7.C b/gcc/testsuite/g++.dg/eh/spec7.C deleted file mode 100644 index 08586a2af75..00000000000 --- a/gcc/testsuite/g++.dg/eh/spec7.C +++ /dev/null @@ -1,35 +0,0 @@ -// PR 14535 -// { dg-do run } -// { dg-options "-O -finline" } -// -// Original test case failure required that Raiser constructor be inlined. - -extern "C" void abort(); -bool destructor_called = false; - -struct B { - virtual void Run(){}; -}; - -struct D : public B { - virtual void Run() - { - struct O { - ~O() { destructor_called = true; }; - } o; - - struct Raiser { - Raiser() throw( int ) {throw 1;}; - } raiser; - }; -}; - -int main() { - try { - D d; - static_cast<B&>(d).Run(); - } catch (...) {} - - if (!destructor_called) - abort (); -} diff --git a/gcc/testsuite/g++.dg/expr/align68k-1.C b/gcc/testsuite/g++.dg/expr/align68k-1.C new file mode 100644 index 00000000000..80ce93039f2 --- /dev/null +++ b/gcc/testsuite/g++.dg/expr/align68k-1.C @@ -0,0 +1,46 @@ +// APPLE LOCAL file test of -mdynamic-no-pic combined with 68k alignment +// Radar 3242139: Positive C++ test case +// Origin: Matt Austern <austern@apple.com> +// { dg-do run } +// { dg-options "-mdynamic-no-pic" } + +const long val1 = 0xa0b0; +const long val2 = 0x1234; + +#pragma options align=mac68k +struct X { + long x1; + long x2; +}; + +#pragma options align=reset + +void setX(X* x) { + x->x1 = val1; + x->x2 = val2; +} + +struct Y +{ + X field; + void set_vals(); +}; + +void Y::set_vals() +{ + ::setX(&field); +} + +int main() +{ + Y y; + bool ok = true; + + y.field.x1 = y.field.x2 = 0; + ok = ok && y.field.x1 == 0 && y.field.x2 == 0; + + y.set_vals(); + ok = ok && y.field.x1 == val1 && y.field.x2 == val2; + + return !ok; +} diff --git a/gcc/testsuite/g++.dg/expr/align68k-2.C b/gcc/testsuite/g++.dg/expr/align68k-2.C new file mode 100644 index 00000000000..4070bcdc0ff --- /dev/null +++ b/gcc/testsuite/g++.dg/expr/align68k-2.C @@ -0,0 +1,38 @@ +// APPLE LOCAL file test 68k alignment +// Radar 3313261: Positive C++ test case +// Origin: Matt Austern <austern@apple.com> +// { dg-do run } + +#pragma options align=mac68k + +typedef struct PMR { + double x; + double y; +}PMR; + +#pragma options align=reset + +static void GetDouble(double *doubleP) +{ + *doubleP = 1.; +} + +static void GetPMR(PMR *p) +{ + GetDouble(&p->x); + GetDouble(&p->y); +} + +int main(void) +{ + PMR tmp; + bool ok = true; + + tmp.x = tmp.y = 0; + ok = ok && tmp.x == 0.0 && tmp.y == 0.0; + + GetPMR(&tmp); + ok = ok && tmp.x == 1.0 && tmp.y == 1.0; + + return !ok; +} diff --git a/gcc/testsuite/g++.dg/expr/cast-ptr-1.C b/gcc/testsuite/g++.dg/expr/cast-ptr-1.C new file mode 100644 index 00000000000..cb42d13ac48 --- /dev/null +++ b/gcc/testsuite/g++.dg/expr/cast-ptr-1.C @@ -0,0 +1,15 @@ +/* APPLE LOCAL file pointer casts */ +/* Test that casts of pointer to unsigned long long aren't sign extended */ +/* Author: Matt Austern <austern@apple.com> */ +/* { dg-do run } */ +/* { dg-options "-Wno-error -w" } */ + +int main () { + /* Note: test assumes sizeof(long long) >= sizeof(void*) */ + + unsigned long x1 = 0x80000000ul; + void* p = (void*) x1; + unsigned long long x2 = (unsigned long long) p; + + return !(x1 == x2); +} diff --git a/gcc/testsuite/g++.dg/expr/fieldref1.C b/gcc/testsuite/g++.dg/expr/fieldref1.C new file mode 100644 index 00000000000..b04ed137548 --- /dev/null +++ b/gcc/testsuite/g++.dg/expr/fieldref1.C @@ -0,0 +1,23 @@ +// APPLE LOCAL file - test of access to 8-byte struct field +// Radar 3309305: positive C++ test case +// Origin: Matt Austern <austern@apple.com> +// { dg-do run } + +struct X { + char array[8]; +}; + +char* get_array(X* p) { + char* p2 = p->array; + return p2; +} + +int main() +{ + X t; + X* p = &t; + char* p2 = get_array(p); + + bool ok = (void*)p == (void*)p2; + return !ok; +} diff --git a/gcc/testsuite/g++.dg/ext/altivec-8.C b/gcc/testsuite/g++.dg/ext/altivec-8.C new file mode 100644 index 00000000000..298e6100559 --- /dev/null +++ b/gcc/testsuite/g++.dg/ext/altivec-8.C @@ -0,0 +1,16 @@ +/* { dg-do compile { target powerpc*-*-* } } */ +/* { dg-options "-faltivec" } */ +/* Author: Ziemowit Laski <zlaski@apple.com> */ + +/* This test case exercises intrinsic/argument combinations that, + while not in the Motorola AltiVec PIM, have nevertheless crept + into the AltiVec vernacular over the years. */ + +void foo() { + vector bool int boolVec1 = (vector bool int) vec_splat_u32(3); + vector bool short boolVec2 = (vector bool short) vec_splat_u16(3); + vector bool char boolVec3 = (vector bool char) vec_splat_u8(3); + boolVec1 = vec_sld( boolVec1, boolVec1, 4 ); + boolVec2 = vec_sld( boolVec2, boolVec2, 2 ); + boolVec3 = vec_sld( boolVec3, boolVec3, 1 ); +} diff --git a/gcc/testsuite/g++.dg/ext/anon-struct4.C b/gcc/testsuite/g++.dg/ext/anon-struct4.C deleted file mode 100644 index f0b3b57f70d..00000000000 --- a/gcc/testsuite/g++.dg/ext/anon-struct4.C +++ /dev/null @@ -1,3 +0,0 @@ -// PR c++/14401 - -struct { struct { int& i ; } bar ; } foo ; // { dg-error "" } diff --git a/gcc/testsuite/g++.dg/ext/attrib14.C b/gcc/testsuite/g++.dg/ext/attrib14.C deleted file mode 100644 index 3a819e01d82..00000000000 --- a/gcc/testsuite/g++.dg/ext/attrib14.C +++ /dev/null @@ -1,13 +0,0 @@ -// PR c++/13170 -// The bogus attribute is ignored, but was in TYPE_ATTRIBUTES during -// parsing of the class, causing some variants to have it and some not. - -struct __attribute__((bogus)) A -{ - virtual ~A(); - void foo(const A&); - void bar(const A&); -}; // { dg-warning "ignored" "" } - -void A::foo(const A&) {} -void A::bar(const A& a) { foo(a); } diff --git a/gcc/testsuite/g++.dg/init/ctor3.C b/gcc/testsuite/g++.dg/init/ctor3.C deleted file mode 100644 index 1678aaf2c4d..00000000000 --- a/gcc/testsuite/g++.dg/init/ctor3.C +++ /dev/null @@ -1,6 +0,0 @@ -// PR c++/14401 - -struct S { - S() {} // { dg-error "" } - const int i; -}; diff --git a/gcc/testsuite/g++.dg/init/ref11.C b/gcc/testsuite/g++.dg/init/ref11.C deleted file mode 100644 index b283e3a69be..00000000000 --- a/gcc/testsuite/g++.dg/init/ref11.C +++ /dev/null @@ -1,13 +0,0 @@ -// PR c++/14230 - -struct A { - A (); - A (const A&); - A& operator= (const A&); -}; - -struct D { - A a; -}; - -const A& z = D().a; diff --git a/gcc/testsuite/g++.dg/init/union1.C b/gcc/testsuite/g++.dg/init/union1.C deleted file mode 100644 index 0049f442916..00000000000 --- a/gcc/testsuite/g++.dg/init/union1.C +++ /dev/null @@ -1,5 +0,0 @@ -// PR c++/14401 - -union U { - int& i; // { dg-error "" } -}; diff --git a/gcc/testsuite/g++.dg/kext1.C b/gcc/testsuite/g++.dg/kext1.C new file mode 100644 index 00000000000..174ec027259 --- /dev/null +++ b/gcc/testsuite/g++.dg/kext1.C @@ -0,0 +1,11 @@ +/* APPLE LOCAL file -findirect-virtual-calls 15 Oct 2002 */ +/* Radar 3008388: Positive C++ test case. */ +/* Origin: Matt Austern <austern@apple.com> */ +/* { dg-do compile } */ +/* { dg-options "-fapple-kext" } */ + +struct B1 { }; /* ok */ +struct B2 { }; /* ok */ +struct D1 : B1 { }; /* ok */ +struct D2 : B1, B2 { }; /* ok */ +struct D3 : virtual B1 { }; /* ok */ diff --git a/gcc/testsuite/g++.dg/kext2.C b/gcc/testsuite/g++.dg/kext2.C new file mode 100644 index 00000000000..f2f2a9514bd --- /dev/null +++ b/gcc/testsuite/g++.dg/kext2.C @@ -0,0 +1,13 @@ +/* APPLE LOCAL file -findirect-virtual-calls 15 Oct 2002 */ +/* Radar 3008388: Positive C++ test case. */ +/* Origin: Matt Austern <austern@apple.com> */ +/* { dg-do compile } */ +/* { dg-options "-fapple-kext" } */ + +struct B1 { virtual ~B1(); virtual void f(); }; /* ok */ +struct D1 : B1 { }; /* ok */ +struct X1 : D1 { virtual void f(); }; /* ok */ + +void X1::f() { D1::f(); } /* ok */ + + diff --git a/gcc/testsuite/g++.dg/kext3.C b/gcc/testsuite/g++.dg/kext3.C new file mode 100644 index 00000000000..7d9efbd8cf1 --- /dev/null +++ b/gcc/testsuite/g++.dg/kext3.C @@ -0,0 +1,18 @@ +/* APPLE LOCAL file -findirect-virtual-calls 15 Oct 2002 */ +/* Radar 3008388: Negative C++ test case. */ +/* Origin: Matt Austern <austern@apple.com> */ +/* { dg-do compile } */ +/* { dg-options "-fapple-kext" } */ + +struct B1 { virtual ~B1(); virtual void f(); }; /* ok */ +struct D1 : B1 { }; /* ok */ +struct D2 { }; /* ok */ + +struct X1 : D1, D2 { }; /* ok */ +struct X2 : virtual D1 { }; /* ok */ + +struct Y1 : X1 { virtual void f(); }; /* ok */ +struct Y2 : X2 { virtual void f(); }; /* ok */ + +void Y1::f() { X1::f(); } /* { dg-error "indirect virtual" } */ +void Y2::f() { X2::f(); } /* { dg-error "indirect virtual" } */ diff --git a/gcc/testsuite/g++.dg/lookup/enum1.C b/gcc/testsuite/g++.dg/lookup/enum1.C deleted file mode 100644 index 9422814e271..00000000000 --- a/gcc/testsuite/g++.dg/lookup/enum1.C +++ /dev/null @@ -1,5 +0,0 @@ -// PR c++/14476 - -struct tree_common { - enum tree_code code : 8; // { dg-error "" } -}; diff --git a/gcc/testsuite/g++.dg/lookup/struct2.C b/gcc/testsuite/g++.dg/lookup/struct2.C deleted file mode 100644 index a66f403c291..00000000000 --- a/gcc/testsuite/g++.dg/lookup/struct2.C +++ /dev/null @@ -1,7 +0,0 @@ -// PR c++/14510 - -struct c {}; -namespace A { - int c(struct c*req); -} -int A::c(struct c*req) {} diff --git a/gcc/testsuite/g++.dg/opt/eh1.C b/gcc/testsuite/g++.dg/opt/eh1.C deleted file mode 100644 index 63a4d2ef35f..00000000000 --- a/gcc/testsuite/g++.dg/opt/eh1.C +++ /dev/null @@ -1,21 +0,0 @@ -// PR middle-end/14477 -// { dg-do compile } -// { dg-options "-O2 -fno-default-inline" } - -struct A -{ - A(); -}; - -struct B -{ - B(const A*); -}; - -struct C -{ - B b; - C(int) : b(new A) {} -}; - -C c(0); diff --git a/gcc/testsuite/g++.dg/overload/ref1.C b/gcc/testsuite/g++.dg/overload/ref1.C deleted file mode 100644 index e239d88a438..00000000000 --- a/gcc/testsuite/g++.dg/overload/ref1.C +++ /dev/null @@ -1,21 +0,0 @@ -// Copyright (C) 2004 Free Software Foundation, Inc. -// Contributed by Nathan Sidwell 5 Mar 2004 <nathan@codesourcery.com> - -// Origin: schmid@snake.iap.physik.tu-darmstadt.de -// Bug 14397: Bogus access error. - -struct S { - S (int); - S(S const&); - private: - S(S&); -}; - -S foo() -{ - int result = 0; - - S s ((0,S (result))); - - return S (result); -} diff --git a/gcc/testsuite/g++.dg/parse/builtin2.C b/gcc/testsuite/g++.dg/parse/builtin2.C deleted file mode 100644 index c524ea68416..00000000000 --- a/gcc/testsuite/g++.dg/parse/builtin2.C +++ /dev/null @@ -1,5 +0,0 @@ -// PR c++/14432 -// { dg-options "" } - -struct Y {}; -Y y1; diff --git a/gcc/testsuite/g++.dg/parse/crash14.C b/gcc/testsuite/g++.dg/parse/crash14.C deleted file mode 100644 index b4cf49a9921..00000000000 --- a/gcc/testsuite/g++.dg/parse/crash14.C +++ /dev/null @@ -1,20 +0,0 @@ -// { dg-do compile } -// Contributed by: Giovanni Bajo <giovannibajo at libero dot it> -// PR c++/14448: Fold constant initializers in templates - -template <int> struct A -{ - A(); -}; - - -template<typename T> void foo(T) -{ - static const int n=1+1; - A<n+1> a; -} - -void bar() -{ - foo(0); -} diff --git a/gcc/testsuite/g++.dg/parse/non-dependent3.C b/gcc/testsuite/g++.dg/parse/non-dependent3.C deleted file mode 100644 index 9dfb99636a8..00000000000 --- a/gcc/testsuite/g++.dg/parse/non-dependent3.C +++ /dev/null @@ -1,17 +0,0 @@ -// PR c++/14586 - -enum E { e }; - -E & operator |= (E &f1, const E &f2); - -E operator | (const E &f1, const E &f2) { - E result = f1; - result |= f2; - return result; -} - -template <typename> void foo () { - const E flags = e | e; -} - -template void foo<double> (); diff --git a/gcc/testsuite/g++.dg/parse/template14.C b/gcc/testsuite/g++.dg/parse/template14.C deleted file mode 100644 index ada87524352..00000000000 --- a/gcc/testsuite/g++.dg/parse/template14.C +++ /dev/null @@ -1,17 +0,0 @@ -// PR c++/14550 - -struct A { - A(); -}; - -template <int> void foo() -{ - A *p = new A; -} - -void bar() -{ - foo<0>(); -} - - diff --git a/gcc/testsuite/g++.dg/pascal-strings-1.C b/gcc/testsuite/g++.dg/pascal-strings-1.C new file mode 100644 index 00000000000..50c52015ec4 --- /dev/null +++ b/gcc/testsuite/g++.dg/pascal-strings-1.C @@ -0,0 +1,44 @@ +/* APPLE LOCAL file pascal strings */ +/* Positive C++ test cases. */ +/* Origin: Ziemowit Laski <zlaski@apple.com> */ +/* { dg-do run } */ +/* { dg-options "-fpascal-strings" } */ + +typedef __SIZE_TYPE__ size_t; +extern "C" void abort (void); +extern "C" size_t strlen (const char *s); + +const unsigned char *pascalStr1 = "\pHello, World!"; +const unsigned char *concat1 = "\pConcatenated" "string" "\pliteral"; + +const unsigned char msg1[] = "\pHello"; /* ok */ +const unsigned char *msg2 = "\pHello"; /* ok */ +const signed char msg3[] = "\pHello"; /* ok */ +const char msg4[] = "\pHello"; /* ok */ +unsigned char msg5[] = "\pHello"; /* ok */ +signed char msg7[] = "\pHello"; /* ok */ +char msg8[] = "\pHello"; /* ok */ + +int +main (void) +{ + const unsigned char *pascalStr2 = "\pGood-bye!"; + + if (strlen ((const char *)pascalStr1) != 14) + abort (); + if (*pascalStr1 != 13) + abort (); /* the length byte does not include trailing null */ + + if (strlen ((const char *)pascalStr2) != 10) + abort (); + if (*pascalStr2 != 9) + abort (); + + if (strlen ((const char *)concat1) != 26) + abort (); + if (*concat1 != 25) + abort (); + + return 0; +} + diff --git a/gcc/testsuite/g++.dg/pascal-strings-2.C b/gcc/testsuite/g++.dg/pascal-strings-2.C new file mode 100644 index 00000000000..e74c67f89c7 --- /dev/null +++ b/gcc/testsuite/g++.dg/pascal-strings-2.C @@ -0,0 +1,43 @@ +/* APPLE LOCAL file pascal strings */ +/* Negative C++ test cases. */ +/* Origin: Ziemowit Laski <zlaski@apple.com> */ +/* { dg-do compile } */ +/* { dg-options "-fpascal-strings" } */ + +const wchar_t *pascalStr1 = L"\pHi!"; /* { dg-warning "unknown escape sequence" } */ +const wchar_t *pascalStr2 = L"Bye\p!"; /* { dg-warning "unknown escape sequence" } */ + +const wchar_t *initErr0 = "\pHi"; /* { dg-error "cannot convert" } */ +const wchar_t initErr0a[] = "\pHi"; /* { dg-error "initialized from non-wide string" } */ +const wchar_t *initErr1 = "Bye"; /* { dg-error "cannot convert" } */ +const wchar_t initErr1a[] = "Bye"; /* { dg-error "initialized from non-wide string" } */ + +const char *initErr2 = L"Hi"; /* { dg-error "cannot convert" } */ +const char initErr2a[] = L"Hi"; /* { dg-error "initialized from wide string" } */ +const signed char *initErr3 = L"Hi"; /* { dg-error "cannot convert" } */ +const signed char initErr3a[] = L"Hi"; /* { dg-error "initialized from wide string" } */ +const unsigned char *initErr4 = L"Hi"; /* { dg-error "cannot convert" } */ +const unsigned char initErr4a[] = L"Hi"; /* { dg-error "initialized from wide string" } */ + +const char *pascalStr3 = "Hello\p, World!"; /* { dg-warning "unknown escape sequence" } */ + +const char *concat2 = "Hi" "\pthere"; /* { dg-warning "unknown escape sequence" } */ +const char *concat3 = "Hi" "there\p"; /* { dg-warning "unknown escape sequence" } */ + +const char *s2 = "\pGoodbye!"; /* { dg-error "invalid conversion" } */ +unsigned char *s3 = "\pHi!"; /* { dg-error "invalid conversion" } */ +char *s4 = "\pHi"; /* { dg-error "invalid conversion" } */ +signed char *s5 = "\pHi"; /* { dg-error "invalid conversion" } */ +const signed char *s6 = "\pHi"; /* { dg-error "invalid conversion" } */ + +/* the maximum length of a Pascal literal is 255. */ +const unsigned char *almostTooLong = + "\p12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "123456789012345"; /* ok */ +const unsigned char *definitelyTooLong = + "\p12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "1234567890123456"; /* { dg-error "too long" } */ diff --git a/gcc/testsuite/g++.dg/preserve-PPC-CR.C b/gcc/testsuite/g++.dg/preserve-PPC-CR.C new file mode 100644 index 00000000000..55409ba0111 --- /dev/null +++ b/gcc/testsuite/g++.dg/preserve-PPC-CR.C @@ -0,0 +1,41 @@ +// APPLE LOCAL preserve CR2 for save_world prologues +// This testcase failed at -O2 due to a missing EH note describing the PowerPC Condition Register. +// Thanks to Dale Johannesen. + +// { dg-do run } +// { dg-options "-fpascal-strings" } +#include <stdlib.h> +#include <stdio.h> +int tick = 1; +int caught_x = 1; +int h() { return 2; } +void f() +{ throw(3); } +extern int h(); +void ff() { + bool xx = h() == 0; + if ( !xx ) { + try { + f(); + } catch (float f) { + if (!xx) printf("%f\n", f); + } + } +} +int g(int y) +{ + bool x = h() != 0; + if ( x) { + try { + ff(); + } catch (int ex) { + // if (x) printf("%d\n", ex); + if (x) { tick++; caught_x = ex; } + }} +} +main() +{ + g(3); + if (tick != 2 || caught_x != 3) + abort(); +} diff --git a/gcc/testsuite/g++.dg/template/spec12.C b/gcc/testsuite/g++.dg/template/spec12.C deleted file mode 100644 index 7cf2e2f0aa2..00000000000 --- a/gcc/testsuite/g++.dg/template/spec12.C +++ /dev/null @@ -1,18 +0,0 @@ -// { dg-do compile } -// Contributed by: Wolfgang Bangerth <bangerth at dealii dot org> -// PR c++/14409: Accepts invalid function signature for explicit instantiation - -struct X -{ - template <typename U> - void foo (U) {} - - template <typename U> - void foo_const (U) const {} -}; - -template void X::foo (int); -template void X::foo_const (int) const; - -template void X::foo (int) const; // { dg-error "" } -template void X::foo_const (int); // { dg-error "" } diff --git a/gcc/testsuite/g++.dg/warn/Wunused-7.C b/gcc/testsuite/g++.dg/warn/Wunused-7.C deleted file mode 100644 index 4281bc81569..00000000000 --- a/gcc/testsuite/g++.dg/warn/Wunused-7.C +++ /dev/null @@ -1,12 +0,0 @@ -// PR c++/14481 -// { dg-options "-Wunused" } - -void func() -{ - struct mybitfields { - unsigned int s_field:8; - }; - struct mybitfields s; - s.s_field = 255; -}; - diff --git a/gcc/testsuite/g++.old-deja/g++.pt/static3.C b/gcc/testsuite/g++.old-deja/g++.pt/static3.C index 6688d23cda5..650b7c02cf1 100644 --- a/gcc/testsuite/g++.old-deja/g++.pt/static3.C +++ b/gcc/testsuite/g++.old-deja/g++.pt/static3.C @@ -1,4 +1,4 @@ -// { dg-do run { xfail *-*-aout *-*-coff *-*-hpux* *-*-hms } } +// { dg-do run { xfail *-*-aout *-*-coff *-*-hpux* *-*-hms *-*-darwin* } } // On targets that don't support weak symbols, we require an explicit // instantiation of arr. diff --git a/gcc/testsuite/gcc.apple/Wextra-tokens.c b/gcc/testsuite/gcc.apple/Wextra-tokens.c new file mode 100644 index 00000000000..08b3cb7745c --- /dev/null +++ b/gcc/testsuite/gcc.apple/Wextra-tokens.c @@ -0,0 +1,21 @@ +/* APPLE LOCAL file -Wextra-tokens */ +/* Lifted from gcc.dg/cpp/extratokens2.c. */ +/* Copyright (C) 2002 Free Software Foundation, Inc. */ + +/* { dg-do preprocess } */ +/* { dg-options "-fno-show-column -Wextra-tokens" } */ + +/* Tests that -Wextra-tokens correctly enables the checks + that are disabled by default. */ + +#if 1 +#if 0 +#else foo /* { dg-warning "extra tokens" "bad warning" } */ +#endif / /* { dg-warning "extra tokens" "bad warning" } */ +#endif + +# 36 "file.c" 3 + +/* ... but in a system header, it's acceptable. */ +#ifdef KERNEL +#endif KERNEL /* { dg-bogus "extra tokens" "bad warning" } */ diff --git a/gcc/testsuite/gcc.apple/Wfour-char-constants-1.c b/gcc/testsuite/gcc.apple/Wfour-char-constants-1.c new file mode 100644 index 00000000000..536396454b7 --- /dev/null +++ b/gcc/testsuite/gcc.apple/Wfour-char-constants-1.c @@ -0,0 +1,12 @@ +/* APPLE LOCAL file -Wfour-char-constants */ +/* We warn by default on Darwin, so no specific option needed. */ + +/* { dg-do compile { target "*-*-darwin*" } } */ +/* { dg-options "" } */ + +int glob1 = 'a'; +int glob2 = 'ab'; /* { dg-warning "multi-character character constant" } */ +int glob3 = 'abc'; /* { dg-warning "multi-character character constant" } */ +int glob4 = 'abcd'; /* say nothing */ +int glob5 = 'abcde'; /* { dg-warning "character constant too long" } */ + diff --git a/gcc/testsuite/gcc.apple/Wfour-char-constants-2.c b/gcc/testsuite/gcc.apple/Wfour-char-constants-2.c new file mode 100644 index 00000000000..14115ba6fea --- /dev/null +++ b/gcc/testsuite/gcc.apple/Wfour-char-constants-2.c @@ -0,0 +1,12 @@ +/* APPLE LOCAL file -Wfour-char-constants */ +/* Explicitly enable the warning. */ + +/* { dg-do compile } */ +/* { dg-options "-Wfour-char-constants" } */ + +int glob1 = 'a'; +int glob2 = 'ab'; /* { dg-warning "multi-character character constant" } */ +int glob3 = 'abc'; /* { dg-warning "multi-character character constant" } */ +int glob4 = 'abcd'; /* { dg-warning "multi-character character constant" } */ +int glob5 = 'abcde'; /* { dg-warning "character constant too long" } */ + diff --git a/gcc/testsuite/gcc.apple/Wlong-double.c b/gcc/testsuite/gcc.apple/Wlong-double.c new file mode 100644 index 00000000000..2a42912b660 --- /dev/null +++ b/gcc/testsuite/gcc.apple/Wlong-double.c @@ -0,0 +1,11 @@ +/* APPLE LOCAL file -Wlong-double */ + +/* We warn by default, so no specific option needed. */ + +/* { dg-do compile { target "*-*-darwin*" } } */ +/* { dg-options "" } */ + +long double ld; /* { dg-warning "use of `long double' type" } */ +/* { dg-warning "is reported only once" "" { target *-*-* } 8 } */ +/* { dg-warning "disable this warning" "" { target *-*-* } 8 } */ + diff --git a/gcc/testsuite/gcc.apple/Wmost.c b/gcc/testsuite/gcc.apple/Wmost.c new file mode 100644 index 00000000000..6e1d3342539 --- /dev/null +++ b/gcc/testsuite/gcc.apple/Wmost.c @@ -0,0 +1,19 @@ +/* APPLE LOCAL file -Wmost */ + +/* { dg-do compile } */ +/* { dg-options "-Wmost" } */ + +int baz (void); + +int +foo () +{ + int loc; + + bar (); /* { dg-warning "implicit declaration" } */ + + if (loc = baz ()) /* be quiet about this */ + return 1; + return 0; +} + diff --git a/gcc/testsuite/gcc.apple/align-test-1.c b/gcc/testsuite/gcc.apple/align-test-1.c new file mode 100644 index 00000000000..f9bdb7b2c21 --- /dev/null +++ b/gcc/testsuite/gcc.apple/align-test-1.c @@ -0,0 +1,605 @@ +/* APPLE LOCAL file Macintosh alignment */ + +/* { dg-do run } */ +/* { dg-options "-Wno-long-long" } */ + +/* + * Macintosh compiler alignment test for C. + * Fred Forsman + * Apple Computer, Inc. + * (C) 2000-2002. + * Last modified 2002-4-29 + */ + +#include <stdio.h> +#include <stddef.h> +#include <string.h> + +#define Q(x) #x, x + +typedef unsigned char UINT8; + +static int bad_option = 0; +static int flag_verbose = 0; +static int nbr_failures = 0; + +/* === basic types === */ + +typedef struct B1 { + char f1; + UINT8 f2; +} B1; + +typedef struct B2 { + short f1; + UINT8 f2; +} B2; + +typedef struct B3 { + long f1; + UINT8 f2; +} B3; + +typedef struct B4 { + int f1; + UINT8 f2; +} B4; + +typedef struct B5 { + float f1; + UINT8 f2; +} B5; + +/* doubles, long longs, and vectors are treated separately below. */ + +/* === enums === */ + +typedef enum E1 { + e1_b = 0, + e1_e = 255 +} E1; + +typedef enum E2 { + e2_b = -256, + e2_e = 255 +} E2; + +typedef enum E3 { + e3_b = 0, + e3_e = 32767 +} E3; + +typedef enum E4 { + e4_b = 0, + e4_e = 65536 +} E4; + +/* === pointers === */ + +typedef struct P1 { + char * f1; + UINT8 f2; +} P1; + +typedef struct P2 { + long * f1; + UINT8 f2; +} P2; + +typedef struct P3 { + double * f1; + UINT8 f2; +} P3; + +typedef struct P4 { + long long * f1; + UINT8 f2; +} P4; + +typedef struct P5 { + void (* f1) (void); + UINT8 f2; +} P5; + +#ifdef __VEC__ +typedef struct P61 { + vector signed short * f1; + UINT8 f2; +} P6; +#endif + +/* === vectors === */ + +#ifdef __VEC__ +typedef struct V1 { + vector signed short f1; + UINT8 f2; +} V1; + +typedef struct V2 { + V1 f1; + UINT8 f2; +} V2; + +typedef struct V3 { + UINT8 f1; + vector signed short f2; +} V3; + +typedef struct V4 { + V3 f1; + UINT8 f2; +} V4; +#endif + +/* === doubles === */ + +typedef struct D1 { + double f1; + UINT8 f2; +} D1; + +typedef struct D2 { + D1 f1; + UINT8 f2; +} D2; + +typedef struct D3 { + UINT8 f1; + double f2; +} D3; + +typedef struct D4 { + D3 f1; + UINT8 f2; +} D4; + +typedef struct D5 { + UINT8 f1; + D3 f2; +} D5; + +typedef struct D6 { + double f1; + UINT8 f2; + double f3; +} D6; + +typedef struct D7 { + UINT8 f1; + D1 f2; +} D7; + +/* === long longs === */ + +typedef struct LL1 { + long long f1; + UINT8 f2; +} LL1; + +typedef struct LL2 { + LL1 f1; + UINT8 f2; +} LL2; + +typedef struct LL3 { + UINT8 f1; + long long f2; +} LL3; + +typedef struct LL4 { + LL3 f1; + UINT8 f2; +} LL4; + +typedef struct LL5 { + UINT8 f1; + LL3 f2; +} LL5; + +/* === arrays === */ + +typedef struct A1 { + short f1[4]; + UINT8 f2; +} A1; + +typedef struct A2 { + A1 f1; + UINT8 f2; +} A2; + +typedef struct A3 { + double f1[4]; + UINT8 f2; +} A3; + +typedef struct A4 { + A3 f1; + UINT8 f2; +} A4; + +typedef struct A5 { + long long f1[4]; + UINT8 f2; +} A5; + +typedef struct A6 { + A5 f1; + UINT8 f2; +} A6; + +#ifdef __VEC__ +typedef struct A7 { + vector signed short f1[4]; + UINT8 f2; +} A7; + +typedef struct A8 { + A7 f1; + UINT8 f2; +} A8; +#endif + +typedef struct A9 { + D1 f1[4]; + UINT8 f2; +} A9; + +typedef struct A10 { + A9 f1; + UINT8 f2; +} A10; + +/* === unions === */ + +typedef union U1 { + UINT8 f1; + double f2; +} U1; + +typedef struct U2 { + U1 f1; + UINT8 f2; +} U2; + +typedef union U3 { + UINT8 f1; + long long f2; +} U3; + +typedef struct U4 { + U3 f1; + UINT8 f2; +} U4; + +#ifdef __VEC__ +typedef union U5 { + UINT8 f1; + vector signed short f2; +} U5; + +typedef struct U6 { + U5 f1; + UINT8 f2; +} U6; +#endif + +typedef union U7 { + UINT8 f1; + short f2[4]; +} U7; + +typedef struct U8 { + U7 f1; + UINT8 f2; +} U8; + +/* === misc === */ + +typedef struct { /* unnamed struct */ + long long f1; + UINT8 f2; +} M0; + +typedef struct M1 { + UINT8 f1[8]; +} M1; + +typedef struct M2 { + M1 f1; + UINT8 f2; +} M2; + +typedef struct M3 { + UINT8 f1; + M1 f2; +} M3; + +typedef struct M4 { /* M4 & M5: see corresponding mac68k tests (M68K11 & M68K12) */ + UINT8 f1[9]; +} M4; + +typedef struct M5 { + UINT8 f1; + M4 f2; +} M5; + +/* === mac68k === */ + +#pragma options align=mac68k + +typedef struct M68K0 { + long f1; + UINT8 f2; +} M68K0; + +typedef struct M68K1 { + double f1; + UINT8 f2; +} M68K1; + +#pragma options align=reset + +typedef struct M68K2 { + M68K1 f1; + UINT8 f2; +} M68K2; + +#ifdef __VEC__ +#pragma options align=mac68k + +typedef struct M68K3 { + vector signed short f1; + UINT8 f2; +} M68K3; + +typedef struct M68K4 { + M68K3 f1; + UINT8 f2; +} M68K4; + +#pragma options align=reset + +typedef struct M68K5 { + M68K3 f1; + UINT8 f2; +} M68K5; + +#pragma options align=mac68k + +typedef struct M68K6 { + UINT8 f1; + vector signed short f2; +} M68K6; + +#pragma options align=reset +#endif + +#pragma options align=mac68k + +typedef struct M68K7 { + UINT8 f1; +} M68K7; + +typedef union M68K8 { + UINT8 f1; +} M68K8; + +typedef struct M68K9 { + UINT8 f1; + int f2; + UINT8 f3; +} M68K9; + +#pragma options align=reset + +typedef struct M68K10 { + UINT8 f1; + M68K9 f2; +} M68K10; + +#pragma options align=mac68k + +typedef struct M68K11 { /* M68K11 & M68K12: see corresponding power tests (M4 & M5) */ + UINT8 f1[9]; +} M68K11; + +typedef struct M68K12 { + UINT8 f1; + M68K11 f2; +} M68K12; + +typedef struct M68K13 { + UINT8 f1; + UINT8 f2[5]; +} M68K13; + +#pragma options align=reset + + +static void check(char * rec_name, int actual, int expected, char * comment) +{ + if (flag_verbose || (actual != expected)) { + printf("%-20s = %2d (%2d) ", rec_name, actual, expected); + if (actual != expected) { + printf("*** FAIL"); + nbr_failures++; + } else + printf(" PASS"); + printf(": %s\n", comment); + } +} + +static void check_option(char *option) +{ + if (*option == '-') { + if (strcmp(option, "-v") == 0) + flag_verbose = 1; + else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } + } else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } +} + +int main(int argc, char *argv[]) +{ + int i; + + for (i = 1; i < argc; i++) + check_option(argv[i]); + + if (bad_option) + return 1; + + /* === basic data types === */ + + check(Q(sizeof(char)), 1, "char data type"); + check(Q(sizeof(signed char)), 1, "signed char data type"); + check(Q(sizeof(unsigned char)), 1, "unsigned char data type"); + check(Q(sizeof(short)), 2, "short data type"); + check(Q(sizeof(signed short)), 2, "signed short data type"); + check(Q(sizeof(unsigned short)), 2, "unsigned short data type"); + check(Q(sizeof(long)), 4, "short long type"); + check(Q(sizeof(signed long)), 4, "signed long data type"); + check(Q(sizeof(unsigned long)), 4, "unsigned long data type"); + check(Q(sizeof(int)), 4, "short int type"); + check(Q(sizeof(signed int)), 4, "signed int data type"); + check(Q(sizeof(unsigned int)), 4, "unsigned int data type"); + check(Q(sizeof(float)), 4, "float type"); + check(Q(sizeof(double)), 8, "double data type"); + check(Q(sizeof(long long)), 8, "long long data type"); + check(Q(sizeof(signed long long)), 8, "signed long long data type"); + check(Q(sizeof(unsigned long long)), 8, "unsigned long long data type"); + + check(Q(sizeof(B1)), 2, "char as 1st field"); + check(Q(sizeof(B2)), 4, "short as 1st field"); + check(Q(sizeof(B3)), 8, "long as 1st field"); + check(Q(sizeof(B4)), 8, "int as 1st field"); + check(Q(sizeof(B5)), 8, "float as 1st field"); + + /* === enums === */ + + check(Q(sizeof(E1)), 4, "enum with range 0..255"); + check(Q(sizeof(E2)), 4, "enum with range -256..255"); + check(Q(sizeof(E3)), 4, "enum with range 0..32767"); + check(Q(sizeof(E4)), 4, "enum with range 0..65536"); + + /* === pointers === */ + + check(Q(sizeof(P1)), 8, "char * as 1st field"); + check(Q(sizeof(P2)), 8, "long * as 1st field"); + check(Q(sizeof(P3)), 8, "double * as 1st field"); + check(Q(sizeof(P4)), 8, "long long * as 1st field"); + check(Q(sizeof(P5)), 8, "function * as 1st field"); + +#ifdef __VEC__ + check(Q(sizeof(P6)), 8, "vector signed short * as 1st field"); +#endif + +#ifdef __VEC__ + /* === vectors === */ + + /* ??? Do we want to test all the possible vector data types? ??? */ + check(Q(sizeof(vector signed short)), 16, "vector signed short data type"); + + check(Q(sizeof(V1)), 32, "vector as 1st field"); + check(Q(sizeof(V2)), 48, "embedding struct with vector as 1st field"); + check(Q(sizeof(V3)), 32, "vector as 2nd field"); + check(Q(offsetof(V3, f2)), 16, "offset of vector as 2nd field"); + check(Q(sizeof(V4)), 48, "embedding struct with vector as 2nd field"); +#endif + + /* === doubles === */ + + check(Q(sizeof(D1)), 16, "double as 1st field"); + check(Q(sizeof(D2)), 24, "embedding struct with double as 1st field"); + check(Q(sizeof(D3)), 12, "double as 2nd field"); + check(Q(offsetof(D3, f2)), 4, "offset of double as 2nd field"); + check(Q(sizeof(D4)), 16, "embedding struct with double as 2nd field"); + check(Q(sizeof(D5)), 16, "struct with double as 2nd field"); + check(Q(offsetof(D5, f2)), 4, "offset of struct with double as 2nd field"); + check(Q(sizeof(D6)), 24, "struct with double, char, double"); + check(Q(offsetof(D6, f3)), 12, "offset of 2nd double in struct with double, char, double"); + check(Q(sizeof(D7)), 20, "struct with double as 2nd field of another struct"); + check(Q(offsetof(D7, f2)), 4, "offset of struct with double as 2nd field of another struct"); + + /* === long longs === */ + + check(Q(sizeof(LL1)), 16, "long long as 1st field"); + check(Q(sizeof(LL2)), 24, "embedding struct with long long as 1st field"); + check(Q(sizeof(LL3)), 12, "long long as 2nd field"); + check(Q(offsetof(LL3, f2)), 4, "offset of long long as 2nd field"); + check(Q(sizeof(LL4)), 16, "embedding struct with long long as 2nd field"); + check(Q(sizeof(LL5)), 16, "struct with long long as 2nd field"); + check(Q(offsetof(LL5, f2)), 4, "offset of struct with long long as 2nd field"); + + /* === arrays === */ + + check(Q(sizeof(A1)), 10, "array of shorts as 1st field"); + check(Q(sizeof(A2)), 12, "embedding struct with array of shorts as 1st field"); + check(Q(sizeof(A3)), 40, "array of doubles as 1st field"); + check(Q(sizeof(A4)), 48, "embedding struct with array of doubles as 1st field"); + check(Q(sizeof(A5)), 40, "array of long longs as 1st field"); + check(Q(sizeof(A6)), 48, "embedding struct with array of long longs as 1st field"); +#ifdef __VEC__ + check(Q(sizeof(A7)), 80, "array of vectors as 1st field"); + check(Q(sizeof(A8)), 96, "embedding struct with array of vectors as 1st field"); +#endif + check(Q(sizeof(A9)), 72, "array of structs as 1st field"); + check(Q(sizeof(A10)), 80, "embedding struct with array of structs as 1st field"); + + /* === unions === */ + + check(Q(sizeof(U1)), 8, "union with double"); + check(Q(sizeof(U2)), 16, "embedding union with double"); + check(Q(sizeof(U3)), 8, "union with long long"); + check(Q(sizeof(U4)), 16, "embedding union with long long"); +#if __VEC__ + check(Q(sizeof(U5)), 16, "union with vector"); + check(Q(sizeof(U6)), 32, "embedding union with vector"); +#endif + check(Q(sizeof(U7)), 8, "union with array of shorts"); + check(Q(sizeof(U8)), 10, "embedding union with array of shorts"); + + /* === misc === */ + + check(Q(sizeof(M0)), 16, "untagged struct with long long as 1st field"); + check(Q(sizeof(M1)), 8, "array[8] of char"); + check(Q(sizeof(M2)), 9, "embedding struct with array[8] of char as 1st field"); + check(Q(sizeof(M3)), 9, "embedding struct with array[8] of char as 2nd field"); + check(Q(offsetof(M3, f2)), 1, "offset of struct with array[8] of char as 2nd field"); + check(Q(sizeof(M4)), 9, "odd size struct: array[9] of char"); + check(Q(sizeof(M5)), 10, "embedding odd size struct"); + + /* === mac68k mode === */ + + check(Q(sizeof(M68K0)), 6, "mac68k struct with long"); + check(Q(sizeof(M68K1)), 10, "mac68k struct with double as 1st field"); + check(Q(sizeof(M68K2)), 12, "embedding mac68k struct with double as 1st field"); +#ifdef __VEC__ + check(Q(sizeof(M68K3)), 32, "mac68k struct with vector as 1st field"); + check(Q(sizeof(M68K4)), 48, "embedding mac68k struct with vector as 1st field in a mac68k struct"); + check(Q(sizeof(M68K5)), 48, "embedding mac68k struct with vector as 1st field in a power struct"); + check(Q(offsetof(M68K6, f2)), 16, "offset of vector as 2nd field in a mac68k struct"); +#endif + check(Q(sizeof(M68K7)), 2, "padding of mac68k struct with one char"); + check(Q(sizeof(M68K8)), 2, "padding of mac68k union with one char"); + check(Q(sizeof(M68K9)), 8, "padding of mac68k struct"); + check(Q(offsetof(M68K9, f2)), 2, "offset of int as 2nd field in a mac68k struct"); + check(Q(sizeof(M68K10)), 10, "power struct with embedded mac68k struct"); + check(Q(offsetof(M68K10, f2)), 2, "offset of mac68k struct as 2nd field in a power struct"); + check(Q(sizeof(M68K11)), 10, "odd size struct (before padding): array[9] of char"); + check(Q(sizeof(M68K12)), 12, "embedding odd size struct (before padding)"); + check(Q(sizeof(M68K13)), 6, "array of char at odd addr in mac68k struct"); + check(Q(offsetof(M68K13, f2)), 1, "offset of array of char at odd addr in mac68k struct"); + + if (nbr_failures > 0) + return 1; + else + return 0; +} diff --git a/gcc/testsuite/gcc.apple/align-test-2.c b/gcc/testsuite/gcc.apple/align-test-2.c new file mode 100644 index 00000000000..1e0ecc819c1 --- /dev/null +++ b/gcc/testsuite/gcc.apple/align-test-2.c @@ -0,0 +1,152 @@ +/* APPLE LOCAL file Macintosh alignment */ + +/* { dg-do run } */ +/* { dg-options "-Wno-long-long" } */ + +/* + * Macintosh compiler alignment test for alignment extensions in GCC 3. + * Fred Forsman + * Apple Computer, Inc. + * (C) 2000-2002. + * Last modified 2002-1-22. + */ + + /* Check whether we are testing GCC 3 or later. */ +#ifdef __GNUC__ +#if __GNUC__ >= 3 + #define GCC3 1 +#endif +#endif + +#include <stdio.h> +#include <stddef.h> +#include <string.h> + +#define Q(x) #x, x + +typedef unsigned char UINT8; +typedef unsigned long UINT32; + +static int bad_option = 0; +static int flag_verbose = 0; +static int nbr_failures = 0; + +/* === alignment modes === */ + +typedef struct S1 { + UINT8 f1; +} S1; + +#pragma options align=mac68k + +typedef struct S2 { + UINT8 f1; +} S2; + +#pragma options align=native + +typedef struct S3 { + UINT8 f1; +} S3; + +#pragma options align=reset +/* Should be mac68k mode here. */ + +#pragma options align=reset +/* Should be power mode here. */ + +typedef struct S4 { + UINT8 f1; + double f2; +} S4; + +#pragma options align=natural + +typedef struct S5 { + UINT8 f1; + double f2; +} S5; + +typedef struct S6 { + UINT8 f1; + double f2; + UINT8 f3; +} S6; + +#pragma options align=reset +/* Should be power mode here. */ + +#pragma options align=packed + +typedef struct S7 { + UINT8 f1; + UINT32 f2; +} S7; + +#pragma options align=reset +/* Should be power mode here. */ + +typedef struct S8 { + UINT8 f1; + UINT32 f2; +} S8; + +static void check(char * rec_name, int actual, int expected, char * comment) +{ + if (flag_verbose || (actual != expected)) { + printf("%-20s = %2d (%2d) ", rec_name, actual, expected); + if (actual != expected) { + printf("*** FAIL"); + nbr_failures++; + } else + printf(" PASS"); + printf(": %s\n", comment); + } +} + +static void check_option(char *option) +{ + if (*option == '-') { + if (strcmp(option, "-v") == 0) + flag_verbose = 1; + else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } + } else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } +} + +int main(int argc, char *argv[]) +{ + int i; + + for (i = 1; i < argc; i++) + check_option(argv[i]); + + if (bad_option) + return 1; + +#ifndef GCC3 + printf("This test requires GCC 3"); + return 1; +#endif + + check(Q(sizeof(S1)), 1, "struct with 1 char; power mode"); + check(Q(sizeof(S2)), 2, "struct with 1 char; mac68k mode"); + check(Q(sizeof(S3)), 1, "struct with 1 char; native mode"); + check(Q(sizeof(S4)), 12, "struct with char, double; power mode"); + check(Q(offsetof(S4, f2)), 4, "offset of double in a struct with char, double; power mode"); + check(Q(sizeof(S5)), 16, "struct with char, double; natural mode"); + check(Q(offsetof(S5, f2)), 8, "offset of double in a struct with char, double; natural mode"); + check(Q(sizeof(S6)), 24, "struct with char, double, char; natural mode"); + check(Q(sizeof(S7)), 5, "struct with char, long; packed mode"); + check(Q(sizeof(S8)), 8, "struct with char, long; power mode"); + + if (nbr_failures > 0) + return 1; + else + return 0; +} diff --git a/gcc/testsuite/gcc.apple/align-test-3.c b/gcc/testsuite/gcc.apple/align-test-3.c new file mode 100644 index 00000000000..1351031bec3 --- /dev/null +++ b/gcc/testsuite/gcc.apple/align-test-3.c @@ -0,0 +1,123 @@ +/* APPLE LOCAL file Macintosh alignment */ + +/* { dg-do run } */ +/* { dg-options "-Wno-long-long" } */ + +/* + * GCC alignment test for alignment problems due to interactions + * between FSF and Macintosh alignment modes. + * Fred Forsman + * Apple Computer, Inc. + * (C) 2000-2002. + * Last modified 2002-1-22. + */ + + /* Check whether we are testing GCC 3 or later. */ +#ifdef __GNUC__ +#if __GNUC__ >= 3 +#define GCC3 1 +#else +#define GCC3 0 +#endif +#endif + +#include <stdio.h> +#include <stddef.h> +#include <string.h> + +#define Q(x) #x, x + +typedef unsigned char UINT8; +typedef unsigned long UINT32; + +static int bad_option = 0; +static int flag_verbose = 0; +static int nbr_failures = 0; + +/* === alignment modes === */ + +#pragma options align=power +#pragma options align=mac68k +#pragma pack(1) + +typedef struct S0 { + UINT32 f1; + UINT8 f2; +} S0; + +#pragma options align=reset + +/* We should be back in mac68k alignment, if #pragma option align=reset + can rest a #pragma pack(n). So check for mac68k alignment. */ + +typedef struct S1 { + UINT32 f1; + UINT8 f2; +} S1; + +#if GCC3 +#pragma options align=power +#pragma options align=mac68k +//#pragma pack(push, 1) +//#pragma pack(pop) +#pragma pack(1) +#pragma pack() + +/* We should be back in mac68k alignment, if #pragma pack() + can reset a #pragma pack(n). So check for mac68k alignment. */ + +typedef struct S2 { + UINT32 f1; + UINT8 f2; +} S2; +#endif /* GCC3 */ + +static void check(char * rec_name, int actual, int expected, char * comment) +{ + if (flag_verbose || (actual != expected)) { + printf("%-20s = %2d (%2d) ", rec_name, actual, expected); + if (actual != expected) { + printf("*** FAIL"); + nbr_failures++; + } else + printf(" PASS"); + printf(": %s\n", comment); + } +} + +static void check_option(char *option) +{ + if (*option == '-') { + if (strcmp(option, "-v") == 0) + flag_verbose = 1; + else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } + } else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } +} + +int main(int argc, char *argv[]) +{ + int i; + + for (i = 1; i < argc; i++) + check_option(argv[i]); + + if (bad_option) + return 1; + + check(Q(sizeof(S0)), 5, "struct with 1 long, 1 char; pack(1) mode"); + check(Q(sizeof(S1)), 6, "struct with 1 long, 1 char; should be mac68k mode"); +#if GCC3 + check(Q(sizeof(S2)), 6, "struct with 1 long, 1 char; should be mac68k mode"); +#endif + + if (nbr_failures > 0) + return 1; + else + return 0; +} diff --git a/gcc/testsuite/gcc.apple/align-test-4.c b/gcc/testsuite/gcc.apple/align-test-4.c new file mode 100644 index 00000000000..f07a10911f9 --- /dev/null +++ b/gcc/testsuite/gcc.apple/align-test-4.c @@ -0,0 +1,224 @@ +/* APPLE LOCAL file Macintosh alignment */ + +/* { dg-do run } */ +/* { dg-options "-Wno-long-long" } */ + +/* + * GCC alignment test for bit-fields. + * This came up initially as an alignment problem in the kernel. + * Fred Forsman + * Apple Computer, Inc. + * (C) 2000-2002. + * Last modified 2002-2-18. + */ + + /* Check whether we are testing GCC 3 or later. */ +#ifdef __GNUC__ +#if __GNUC__ >= 3 +#define GCC3 1 +#else +#define GCC3 0 +#endif +#endif + +#include <stdio.h> +#include <stddef.h> +#include <string.h> + +/* + * The following defined determines whether we should compare against + * the values produced by GCC 2.95 or against the values I expect given + * my understanding of the alignment rules. + */ +#define USE_GCC2_VALUES 1 + +#define NAME2(name,mode) mode##_##name +#define NAME(name,mode) NAME2(name,mode) + +#define STR(s) #s +#define SIZEOF3(name) STR(sizeof(name)), sizeof(name) +#define SIZEOF2(name,mode) SIZEOF3(mode##_##name) +#define SIZEOF(name,mode) SIZEOF2(name,mode) + +#define OFFSETOF3(name,field) STR(offsetof(name,field)), offsetof(name,field) +#define OFFSETOF2(name,mode,field) OFFSETOF3(mode##_##name,field) +#define OFFSETOF(name,mode,field) OFFSETOF2(name,mode,field) + +typedef unsigned char UINT8; +typedef unsigned long UINT32; + +static int bad_option = 0; +static int flag_verbose = 0; +static int nbr_failures = 0; + +/* === mac68k alignment problem in kernel === */ + +typedef unsigned PEF_UBits32, ByteCount; +typedef short SInt16; + +/* === power === */ +#pragma options align=power +#define MODE power +#include "align-test-4.h" + +/* === mac68k === */ +#pragma options align=mac68k +#undef MODE +#define MODE mac68k +#include "align-test-4.h" + +/* === pack(2) === */ +#pragma pack(2) +#undef MODE +#define MODE pack2 +#include "align-test-4.h" + + +static void check(char * rec_name, int actual, int expected, char * comment) +{ + if (flag_verbose || (actual != expected)) { + printf("%-30s = %2d (%2d) ", rec_name, actual, expected); + if (actual != expected) { + printf("*** FAIL"); + nbr_failures++; + } else + printf(" PASS"); + printf(": %s\n", comment); + } +} + +static void check_option(char *option) +{ + if (*option == '-') { + if (strcmp(option, "-v") == 0) + flag_verbose = 1; + else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } + } else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } +} + +int main(int argc, char *argv[]) +{ + int i; + + for (i = 1; i < argc; i++) + check_option(argv[i]); + + if (bad_option) + return 1; + +#undef MODE +#define MODE power + +#if USE_GCC2_VALUES + check(SIZEOF(LoaderExport, MODE), 12, "kernel struct"); + check(OFFSETOF(LoaderExport, MODE, offset), 4, "offset of offset"); + check(OFFSETOF(LoaderExport, MODE, sectionNumber), 8, "offset of sectionNumber"); + check(SIZEOF(S1, MODE), 8, "bitfields & char"); + check(SIZEOF(S2, MODE), 8, "int & char"); + check(SIZEOF(S3, MODE), 12, "char, bitfields(32), char"); + check(OFFSETOF(S3, MODE, f3), 8, "offset of 2nd char"); + check(SIZEOF(S4, MODE), 8, "char, bitfields(32), char"); + check(OFFSETOF(S4, MODE, f3), 7, "offset of 2nd char"); + check(SIZEOF(S5, MODE), 4, "char, bitfields(16), char"); + check(OFFSETOF(S5, MODE, f3), 3, "offset of 2nd char"); + check(SIZEOF(S6, MODE), 4, "char, bitfields(8), char"); + check(OFFSETOF(S6, MODE, f3), 2, "offset of 2nd char"); +#else + check(SIZEOF(LoaderExport, MODE), 12, "kernel struct"); + check(OFFSETOF(LoaderExport, MODE, offset), 4, "offset of offset"); + check(OFFSETOF(LoaderExport, MODE, sectionNumber), 8, "offset of sectionNumber"); + check(SIZEOF(S1, MODE), 8, "bitfields & char"); + check(SIZEOF(S2, MODE), 8, "int & char"); + check(SIZEOF(S3, MODE), 12, "char, bitfields(32), char"); + check(OFFSETOF(S3, MODE, f3), 8, "offset of 2nd char"); + check(SIZEOF(S4, MODE), 12, "char, bitfields(32), char"); + check(OFFSETOF(S4, MODE, f3), 8, "offset of 2nd char"); + check(SIZEOF(S5, MODE), 12, "char, bitfields(16), char"); + check(OFFSETOF(S5, MODE, f3), 8, "offset of 2nd char"); + check(SIZEOF(S6, MODE), 12, "char, bitfields(8), char"); + check(OFFSETOF(S6, MODE, f3), 8, "offset of 2nd char"); +#endif + +#undef MODE +#define MODE mac68k + +#if USE_GCC2_VALUES + check(SIZEOF(LoaderExport, MODE), 10, "kernel struct"); + check(OFFSETOF(LoaderExport, MODE, offset), 4, "offset of offset"); + check(OFFSETOF(LoaderExport, MODE, sectionNumber), 8, "offset of sectionNumber"); +#if 1 + // GCC 2 is wrong on the following. + check(SIZEOF(S1, MODE), 6, "bitfields & char"); +#else + check(SIZEOF(S1, MODE), 8, "bitfields & char"); +#endif + check(SIZEOF(S2, MODE), 6, "int & char"); + check(SIZEOF(S3, MODE), 6, "char, bitfields(32), char"); + check(OFFSETOF(S3, MODE, f3), 5, "offset of 2nd char"); + check(SIZEOF(S4, MODE), 6, "char, bitfields(32), char"); + check(OFFSETOF(S4, MODE, f3), 5, "offset of 2nd char"); + check(SIZEOF(S5, MODE), 4, "char, bitfields(16), char"); + check(OFFSETOF(S5, MODE, f3), 3, "offset of 2nd char"); + check(SIZEOF(S6, MODE), 4, "char, bitfields(8), char"); + check(OFFSETOF(S6, MODE, f3), 2, "offset of 2nd char"); +#else + check(SIZEOF(LoaderExport, MODE), 10, "kernel struct"); + check(OFFSETOF(LoaderExport, MODE, offset), 4, "offset of offset"); + check(OFFSETOF(LoaderExport, MODE, sectionNumber), 8, "offset of sectionNumber"); + check(SIZEOF(S1, MODE), 6, "bitfields & char"); + check(SIZEOF(S2, MODE), 6, "int & char"); + check(SIZEOF(S3, MODE), 8, "char, bitfields(32), char"); + check(OFFSETOF(S3, MODE, f3), 6, "offset of 2nd char"); + check(SIZEOF(S4, MODE), 8, "char, bitfields(32), char"); + check(OFFSETOF(S4, MODE, f3), 6, "offset of 2nd char"); + check(SIZEOF(S5, MODE), 6, "char, bitfields(16), char"); + check(OFFSETOF(S5, MODE, f3), 4, "offset of 2nd char"); + check(SIZEOF(S6, MODE), 4, "char, bitfields(8), char"); + check(OFFSETOF(S6, MODE, f3), 2, "offset of 2nd char"); +#endif + +#undef MODE +#define MODE pack2 + +#if USE_GCC2_VALUES + check(SIZEOF(LoaderExport, MODE), 10, "kernel struct"); + check(OFFSETOF(LoaderExport, MODE, offset), 4, "offset of offset"); + check(OFFSETOF(LoaderExport, MODE, sectionNumber), 8, "offset of sectionNumber"); + /* GCC2 used to have this as '8', but it should really be 6. */ + check(SIZEOF(S1, MODE), 6, "bitfields & char"); + check(SIZEOF(S2, MODE), 6, "int & char"); + check(SIZEOF(S3, MODE), 6, "char, bitfields(32), char"); + check(OFFSETOF(S3, MODE, f3), 5, "offset of 2nd char"); + check(SIZEOF(S4, MODE), 6, "char, bitfields(32), char"); + check(OFFSETOF(S4, MODE, f3), 5, "offset of 2nd char"); + check(SIZEOF(S5, MODE), 4, "char, bitfields(16), char"); + check(OFFSETOF(S5, MODE, f3), 3, "offset of 2nd char"); + check(SIZEOF(S6, MODE), 4, "char, bitfields(8), char"); + check(OFFSETOF(S6, MODE, f3), 2, "offset of 2nd char"); +#else + check(SIZEOF(LoaderExport, MODE), 10, "kernel struct"); + check(OFFSETOF(LoaderExport, MODE, offset), 4, "offset of offset"); + check(OFFSETOF(LoaderExport, MODE, sectionNumber), 8, "offset of sectionNumber"); + check(SIZEOF(S1, MODE), 6, "bitfields & char"); + check(SIZEOF(S2, MODE), 6, "int & char"); + check(SIZEOF(S3, MODE), 8, "char, bitfields(32), char"); + check(OFFSETOF(S3, MODE, f3), 6, "offset of 2nd char"); + check(SIZEOF(S4, MODE), 8, "char, bitfields(32), char"); + check(OFFSETOF(S4, MODE, f3), 6, "offset of 2nd char"); + check(SIZEOF(S5, MODE), 6, "char, bitfields(16), char"); + check(OFFSETOF(S5, MODE, f3), 4, "offset of 2nd char"); + check(SIZEOF(S6, MODE), 4, "char, bitfields(8), char"); + check(OFFSETOF(S6, MODE, f3), 2, "offset of 2nd char"); +#endif + + if (nbr_failures > 0) + return 1; + else + return 0; +} diff --git a/gcc/testsuite/gcc.apple/align-test-4.h b/gcc/testsuite/gcc.apple/align-test-4.h new file mode 100644 index 00000000000..f7c18727fee --- /dev/null +++ b/gcc/testsuite/gcc.apple/align-test-4.h @@ -0,0 +1,43 @@ +/* APPLE LOCAL file Macintosh alignment */ + +typedef struct { + PEF_UBits32 symClass : 8; + PEF_UBits32 nameOffset : 24; + ByteCount offset; + SInt16 sectionNumber; +} NAME(LoaderExport, MODE); + +typedef struct { + unsigned f1 : 32; + char f2; +} NAME(S1, MODE); + +typedef struct { + unsigned f1; + char f2; +} NAME(S2, MODE); + +typedef struct { + char f1; + unsigned f2 : 32; + char f3; +} NAME(S3, MODE); + +typedef struct { + char f1; + unsigned f2_1 : 8; + unsigned f2_2 : 24; + char f3; +} NAME(S4, MODE); + +typedef struct { + char f1; + unsigned f2 : 16; + char f3; +} NAME(S5, MODE); + +typedef struct { + char f1; + unsigned f2 : 8; + char f3; +} NAME(S6, MODE); diff --git a/gcc/testsuite/gcc.apple/align-test-5a.c b/gcc/testsuite/gcc.apple/align-test-5a.c new file mode 100644 index 00000000000..6833535fcec --- /dev/null +++ b/gcc/testsuite/gcc.apple/align-test-5a.c @@ -0,0 +1,87 @@ +/* APPLE LOCAL file Macintosh alignment */ +/* align-test-5*.c are all the same code but with different options. */ + +/* { dg-do run } */ +/* { dg-options "-malign-natural -DSIZE=16" } */ + +/* + * GCC alignment test for command line options for setting alignment modes. + * Fred Forsman + * Apple Computer, Inc. + * (C) 2000-2002. + * Last modified 2002-2-18. + * + */ + + /* Check whether we are testing GCC 3 or later. */ +#ifdef __GNUC__ +#if __GNUC__ >= 3 +#define GCC3 1 +#else +#define GCC3 0 +#endif +#endif + +#include <stdio.h> +#include <stddef.h> +#include <string.h> + +#define Q(x) #x, x + +typedef unsigned char UINT8; +typedef unsigned long UINT32; + +static int bad_option = 0; +static int flag_verbose = 0; +static int nbr_failures = 0; + +typedef struct S0 { + UINT8 f1; + double f2; +} S0; + +static void check(char * rec_name, int actual, int expected, char * comment) +{ + if (flag_verbose || (actual != expected)) { + printf("%-20s = %2d (%2d) ", rec_name, actual, expected); + if (actual != expected) { + printf("*** FAIL"); + nbr_failures++; + } else + printf(" PASS"); + printf(": %s\n", comment); + } +} + +static void check_option(char *option) +{ + if (*option == '-') { + if (strcmp(option, "-v") == 0) + flag_verbose = 1; + else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } + } else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } +} + +int main(int argc, char *argv[]) +{ + int i; + + for (i = 1; i < argc; i++) + check_option(argv[i]); + + if (bad_option) + return 1; + + check(Q(sizeof(S0)), SIZE, "struct with 1 char, 1 double"); + + if (nbr_failures > 0) + return 1; + else + return 0; +} diff --git a/gcc/testsuite/gcc.apple/align-test-5b.c b/gcc/testsuite/gcc.apple/align-test-5b.c new file mode 100644 index 00000000000..6845bd34766 --- /dev/null +++ b/gcc/testsuite/gcc.apple/align-test-5b.c @@ -0,0 +1,87 @@ +/* APPLE LOCAL file Macintosh alignment */ +/* align-test-5*.c are all the same code but with different options. */ + +/* { dg-do run } */ +/* { dg-options "-malign-power -DSIZE=12" } */ + +/* + * GCC alignment test for command line options for setting alignment modes. + * Fred Forsman + * Apple Computer, Inc. + * (C) 2000-2002. + * Last modified 2002-2-18. + * + */ + + /* Check whether we are testing GCC 3 or later. */ +#ifdef __GNUC__ +#if __GNUC__ >= 3 +#define GCC3 1 +#else +#define GCC3 0 +#endif +#endif + +#include <stdio.h> +#include <stddef.h> +#include <string.h> + +#define Q(x) #x, x + +typedef unsigned char UINT8; +typedef unsigned long UINT32; + +static int bad_option = 0; +static int flag_verbose = 0; +static int nbr_failures = 0; + +typedef struct S0 { + UINT8 f1; + double f2; +} S0; + +static void check(char * rec_name, int actual, int expected, char * comment) +{ + if (flag_verbose || (actual != expected)) { + printf("%-20s = %2d (%2d) ", rec_name, actual, expected); + if (actual != expected) { + printf("*** FAIL"); + nbr_failures++; + } else + printf(" PASS"); + printf(": %s\n", comment); + } +} + +static void check_option(char *option) +{ + if (*option == '-') { + if (strcmp(option, "-v") == 0) + flag_verbose = 1; + else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } + } else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } +} + +int main(int argc, char *argv[]) +{ + int i; + + for (i = 1; i < argc; i++) + check_option(argv[i]); + + if (bad_option) + return 1; + + check(Q(sizeof(S0)), SIZE, "struct with 1 char, 1 double"); + + if (nbr_failures > 0) + return 1; + else + return 0; +} diff --git a/gcc/testsuite/gcc.apple/align-test-5c.c b/gcc/testsuite/gcc.apple/align-test-5c.c new file mode 100644 index 00000000000..fd9bd5cca4c --- /dev/null +++ b/gcc/testsuite/gcc.apple/align-test-5c.c @@ -0,0 +1,87 @@ +/* APPLE LOCAL file Macintosh alignment */ +/* align-test-5*.c are all the same code but with different options. */ + +/* { dg-do run } */ +/* { dg-options "-malign-mac68k -DSIZE=10" } */ + +/* + * GCC alignment test for command line options for setting alignment modes. + * Fred Forsman + * Apple Computer, Inc. + * (C) 2000-2002. + * Last modified 2002-2-18. + * + */ + + /* Check whether we are testing GCC 3 or later. */ +#ifdef __GNUC__ +#if __GNUC__ >= 3 +#define GCC3 1 +#else +#define GCC3 0 +#endif +#endif + +#include <stdio.h> +#include <stddef.h> +#include <string.h> + +#define Q(x) #x, x + +typedef unsigned char UINT8; +typedef unsigned long UINT32; + +static int bad_option = 0; +static int flag_verbose = 0; +static int nbr_failures = 0; + +typedef struct S0 { + UINT8 f1; + double f2; +} S0; + +static void check(char * rec_name, int actual, int expected, char * comment) +{ + if (flag_verbose || (actual != expected)) { + printf("%-20s = %2d (%2d) ", rec_name, actual, expected); + if (actual != expected) { + printf("*** FAIL"); + nbr_failures++; + } else + printf(" PASS"); + printf(": %s\n", comment); + } +} + +static void check_option(char *option) +{ + if (*option == '-') { + if (strcmp(option, "-v") == 0) + flag_verbose = 1; + else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } + } else { + fprintf(stderr, "*** unrecognized option '%s'.\n", option); + bad_option = 1; + } +} + +int main(int argc, char *argv[]) +{ + int i; + + for (i = 1; i < argc; i++) + check_option(argv[i]); + + if (bad_option) + return 1; + + check(Q(sizeof(S0)), SIZE, "struct with 1 char, 1 double"); + + if (nbr_failures > 0) + return 1; + else + return 0; +} diff --git a/gcc/testsuite/gcc.apple/altivec-1.c b/gcc/testsuite/gcc.apple/altivec-1.c new file mode 100644 index 00000000000..d2040d96bbc --- /dev/null +++ b/gcc/testsuite/gcc.apple/altivec-1.c @@ -0,0 +1,124 @@ +/* APPLE LOCAL file AltiVec */ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-options "-faltivec -Wno-long-double" } */ + +/* Test for correct handling of AltiVec constants passed + through '...' (va_arg). */ + +#include <stdarg.h> +#include <stdio.h> +#include <stdlib.h> + +#define CHECK_INVARIANT(expr) \ + if (!(expr)) { \ + printf ("ASSERT FAILED: %d: %s\n", __LINE__, #expr); \ + abort (); \ + } + +struct foo { int x; int y; }; +struct vfoo { int x; __vector signed int v; int y; }; +union u { __vector signed int v; signed int i[4]; }; + +struct foo x_g = { 3, 4}; +struct vfoo vx_g = { 10, (vector signed int)(11, 12, 13, 14), 15 }; +__vector signed int v_g = (vector signed int) (22, 23, 24, 25); +struct vfoo vx2_g = { 30, (vector signed int)(31, 32, 33, 34), 35 }; +__vector signed int v2_g = (vector signed int)(40, 41, 42, 43); +int i_1 = 99, i_2 = 33; +double d_2 = 1.5, d_3 = 1.75; +long double ld_1 = 1.25; + +void bar (int i, ... ) +{ + struct foo xi; + double d; + long double ld; + float f; + char c; + short s; + va_list ap; + va_start(ap, i); + xi = va_arg(ap, struct foo); + s = (short)va_arg(ap, int); + f = (float)va_arg(ap, double); + ld = va_arg(ap, long double); + c = (char)va_arg(ap, int); + d = va_arg(ap, double); + va_end(ap); + + CHECK_INVARIANT (xi.x == x_g.x && xi.y == x_g.y); + CHECK_INVARIANT (s == (short)i_2); + CHECK_INVARIANT (f == (float)d_2); + CHECK_INVARIANT (ld == ld_1); + CHECK_INVARIANT (c == (char)i_1); + CHECK_INVARIANT (d == d_3); +} + +void baz (int i, ... ) +{ + struct vfoo vx, vx2; + __vector signed int v_i, v2_i; + int j, k, l; + va_list ap; + va_start(ap, i); + v_i = va_arg(ap, __vector signed int); + j = va_arg(ap, int); + vx = va_arg(ap, struct vfoo); + k = va_arg(ap, int); + v2_i = va_arg(ap, __vector signed int); + l = va_arg(ap, int); + vx2 = va_arg(ap, struct vfoo); + va_end(ap); + + CHECK_INVARIANT (vec_all_eq (v_i, v_g)); + CHECK_INVARIANT (j == i_1); + CHECK_INVARIANT (vx.x == vx_g.x && vec_all_eq(vx.v, vx_g.v) && vx.y == vx_g.y); + CHECK_INVARIANT (k == i_1); + CHECK_INVARIANT (vec_all_eq (v2_i, v2_g)); + CHECK_INVARIANT (l == i_1); + CHECK_INVARIANT (vx2.x == vx2_g.x && vec_all_eq(vx2.v, vx2_g.v) && vx2.y == vx2_g.y); +} + +void quux (int i, ... ) +{ + __vector signed int v_i, v2_i; + union u vi, v2i; + va_list ap; + va_start(ap, i); + v_i = va_arg(ap, __vector signed int); + v2_i = va_arg(ap, __vector signed int); + va_end(ap); + vi.v = v_i; + v2i.v = v2_i; + + CHECK_INVARIANT (vec_all_eq (v_i, v_g)); + CHECK_INVARIANT (vec_all_eq (v2_i, v_g)); + CHECK_INVARIANT (vec_all_eq (vi.v, v_g)); + CHECK_INVARIANT (vec_all_eq (v2i.v, v_g)); +} + +void baz2 (int i, ... ) +{ + struct vfoo vx; + union u vxi; + va_list ap; + va_start(ap, i); + vx = va_arg(ap, struct vfoo); + va_end(ap); + vxi.v = vx.v; + + CHECK_INVARIANT (vx.x == vx_g.x && vec_all_eq(vx.v, vx_g.v) && vx.y == vx_g.y); + CHECK_INVARIANT (vec_all_eq (vxi.v, vx_g.v)); +} + +int main(void) +{ + CHECK_INVARIANT (sizeof(struct foo) == 8 && sizeof(struct vfoo) == 48); + + bar(i_1, x_g, (short)i_2, (float)d_2, ld_1, (char)i_1, d_3); + baz(i_1, v_g, i_1, vx_g, i_1, v2_g, i_1, vx2_g); + quux(i_1, v_g, v_g); + baz2(i_1, vx_g); + + return 0; +} diff --git a/gcc/testsuite/gcc.apple/applecc.c b/gcc/testsuite/gcc.apple/applecc.c new file mode 100644 index 00000000000..757ad573272 --- /dev/null +++ b/gcc/testsuite/gcc.apple/applecc.c @@ -0,0 +1,14 @@ +/* APPLE LOCAL file Apple version */ +/* { dg-do compile } */ + +#if __APPLE_CC__ < 1000 +#error build number too small +#endif +#if __APPLE_CC__ > 32768 +#error build number too big +#endif +#if ! ( __APPLE_CC__ > 1000) +#error build number not really a number +#endif + +int x = __APPLE_CC__; diff --git a/gcc/testsuite/gcc.apple/const-cfstring-1.c b/gcc/testsuite/gcc.apple/const-cfstring-1.c new file mode 100644 index 00000000000..3e8c1194d20 --- /dev/null +++ b/gcc/testsuite/gcc.apple/const-cfstring-1.c @@ -0,0 +1,29 @@ +/* APPLE LOCAL file constant CFStrings */ +/* Test whether the __builtin__CFStringMakeConstantString + "function" fails gracefully when handed a non-constant + argument. This will only work on MacOS X 10.1.2 and later. */ +/* Developed by Ziemowit Laski <zlaski@apple.com>. */ + +/* { dg-do compile { target *-*-darwin* } } */ +/* { dg-options "-fconstant-cfstrings" } */ + +typedef const struct __CFString *CFStringRef; + +#ifdef __CONSTANT_CFSTRINGS__ +#define CFSTR(STR) ((CFStringRef) __builtin___CFStringMakeConstantString (STR)) +#else +#error __CONSTANT_CFSTRINGS__ not defined +#endif + +extern int cond; +extern const char *func(void); + +const CFStringRef s0 = CFSTR("Hello" "there"); + +int main(void) { + CFStringRef s1 = CFSTR("Str1"); + CFStringRef s2 = CFSTR(cond? "Str2": "Str3"); /* { dg-error "literal expression is not constant" } */ + CFStringRef s3 = CFSTR(func()); /* { dg-error "literal expression is not constant" } */ + + return 0; +} diff --git a/gcc/testsuite/gcc.apple/const-cfstring-2.c b/gcc/testsuite/gcc.apple/const-cfstring-2.c new file mode 100644 index 00000000000..cbf09d3a977 --- /dev/null +++ b/gcc/testsuite/gcc.apple/const-cfstring-2.c @@ -0,0 +1,13 @@ +/* APPLE LOCAL file constant CFStrings */ +/* Test whether the __builtin__CFStringMakeConstantString + "function" fails gracefully when used without the + -fconstant-cfstrings flag. */ +/* Developed by Ziemowit Laski <zlaski@apple.com>. */ + +/* { dg-options "-fno-constant-cfstrings" } */ +/* { dg-do compile { target *-*-darwin* } } */ + +typedef const struct __CFString *CFStringRef; + +const CFStringRef S = ((CFStringRef)__builtin___CFStringMakeConstantString("Testing")); +/* { dg-error "built-in" "built-in function .* requires .* flag" { target *-*-* } 12 } */ diff --git a/gcc/testsuite/gcc.apple/const-cfstring-3.c b/gcc/testsuite/gcc.apple/const-cfstring-3.c new file mode 100644 index 00000000000..aba558b1f8b --- /dev/null +++ b/gcc/testsuite/gcc.apple/const-cfstring-3.c @@ -0,0 +1,29 @@ +/* APPLE LOCAL file constant CFStrings */ +/* Test whether the __builtin__CFStringMakeConstantString + "function" generates compile-time objects with the correct layout. */ +/* Developed by Ziemowit Laski <zlaski@apple.com>. */ + +/* { dg-do compile { target *-*-darwin* } } */ +/* { dg-options "-fconstant-cfstrings" } */ + +typedef const struct __CFString *CFStringRef; + +#ifdef __CONSTANT_CFSTRINGS__ +#define CFSTR(STR) ((CFStringRef) __builtin___CFStringMakeConstantString (STR)) +#else +#error __CONSTANT_CFSTRINGS__ not defined +#endif + +extern int cond; +extern const char *func(void); + +CFStringRef s0 = CFSTR("Hello" "there"); + +void foo(void) { + const CFStringRef s1 = CFSTR("Str1"); + + s0 = s1; +} + +/* { dg-final { scan-assembler "\\.long\[ \\t\]+___CFConstantStringClassReference\n\[ \\t\]*\\.long\[ \\t\]+1992\n\[ \\t\]*\\.long\[ \\t\]+LC.*\n\[ \\t\]*\\.long\[ \\t\]+4\n" } } */ +/* { dg-final { scan-assembler "\\.long\[ \\t\]+___CFConstantStringClassReference\n\[ \\t\]*\\.long\[ \\t\]+1992\n\[ \\t\]*\\.long\[ \\t\]+LC.*\n\[ \\t\]*\\.long\[ \\t\]+10\n" } } */ diff --git a/gcc/testsuite/gcc.dg/charset/charset.exp b/gcc/testsuite/gcc.apple/dg.exp index ad75cb55af8..42fcefba10e 100644 --- a/gcc/testsuite/gcc.dg/charset/charset.exp +++ b/gcc/testsuite/gcc.apple/dg.exp @@ -1,44 +1,40 @@ -# Copyright (C) 2004 Free Software Foundation, Inc. +# APPLE LOCAL file testsuite +# Copyright (C) 1997 Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# GCC testsuite that uses the 'dg.exp' driver. - -# There's a bunch of headers we need. -if [is_remote host] { - foreach header [glob -nocomplain $srcdir/$subdir/*.{h,def} ] { - remote_download host $header - } -} +# Apple-specific GCC testsuite driver. +# Note that this is basically a clone of gcc.dg/dg.exp, updated +# whenever the original file changes (which is not very often). # Load support procs. load_lib gcc-dg.exp -load_lib target-supports.exp # If a testcase doesn't have special options, use these. -global DEFAULT_CHARSETCFLAGS -if ![info exists DEFAULT_CHARSETCFLAGS] then { - set DEFAULT_CHARSETCFLAGS "-fexec-charset=IBM-1047" +global DEFAULT_CFLAGS +if ![info exists DEFAULT_CFLAGS] then { + set DEFAULT_CFLAGS " -ansi -pedantic-errors -Wno-long-double" } # Initialize `dg'. dg-init # Main loop. -dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.{c,S} ]] \ - "" $DEFAULT_CHARSETCFLAGS +# APPLE LOCAL preprocess .s files +dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[cSs\]]] \ + "" $DEFAULT_CFLAGS # All done. dg-finish diff --git a/gcc/testsuite/gcc.apple/execute/bitfield-1.c b/gcc/testsuite/gcc.apple/execute/bitfield-1.c new file mode 100644 index 00000000000..f013853f48e --- /dev/null +++ b/gcc/testsuite/gcc.apple/execute/bitfield-1.c @@ -0,0 +1,52 @@ +/* { dg-do run { target *-*-darwin* } } */ +/* { dg-options "-O2 -fss-const-prop" } */ +/* APPLE LOCAL */ +/* <rdar://problem/3366203>:Setup Assistant crashes in SetModificationDateToPasteboard */ +/* <rdar://problem/3379022>:GCC compiler error in bitfield handling */ + + +typedef struct +{ + unsigned int b01 : 1; + unsigned int b02 : 2; + unsigned int b03 : 1; + unsigned int b04 : 1; + unsigned int b05 : 1; + unsigned int b06 : 1; + unsigned int b07 : 3; + unsigned int b08 : 3; + unsigned int b09 : 3; + unsigned int b10 : 3; + unsigned int b11 : 8; + unsigned int b12 : 1; + unsigned int b13 : 4; +} test_struct; + +void func( test_struct* s, int t ) +{ + s->b12 = 0; + s->b02 = 0; +} + +main() +{ + test_struct r = { 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 }; + + func (&r, 42); + + if (r.b01 != 1 + || r.b03 != 1 + || r.b04 != 1 + || r.b05 != 1 + || r.b06 != 1 + || r.b07 != 1 + || r.b08 != 1 + || r.b09 != 1 + || r.b10 != 1 + || r.b11 != 1 + || r.b13 != 1) + { + abort(); + } + exit (0); +} diff --git a/gcc/testsuite/gcc.apple/execute/execute.exp b/gcc/testsuite/gcc.apple/execute/execute.exp new file mode 100644 index 00000000000..f7b1f5b5eeb --- /dev/null +++ b/gcc/testsuite/gcc.apple/execute/execute.exp @@ -0,0 +1,43 @@ +# Copyright (C) 1991, 1992, 1993, 1995, 1997 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# This file was written by Rob Savoye. (rob@cygnus.com) +# Modified and maintained by Jeffrey Wheat (cassidy@cygnus.com) + +# +# These tests come from Torbjorn Granlund (tege@cygnus.com) +# C torture test suite. +# + +if $tracelevel then { + strace $tracelevel +} + +# load support procs +load_lib c-torture.exp + +# +# main test loop +# + +foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.c]] { + # If we're only testing specific files and this isn't one of them, skip it. + if ![runtest_file_p $runtests $src] then { + continue + } + + c-torture-execute $src +} diff --git a/gcc/testsuite/gcc.apple/framework1.c b/gcc/testsuite/gcc.apple/framework1.c new file mode 100644 index 00000000000..bd0203669c2 --- /dev/null +++ b/gcc/testsuite/gcc.apple/framework1.c @@ -0,0 +1,12 @@ +/* Copyright (C) 2003 Free Software Foundation, Inc. */ + +/* { dg-do preprocess } */ +/* { dg-options "-nostdinc -c -F${srcdir}/gcc.apple" } */ + +/* Contributed by Devang Patel <dpatel@apple.com> */ + +#include <one/one.h> +int main() +{ + return 0; +} diff --git a/gcc/testsuite/gcc.apple/import.c b/gcc/testsuite/gcc.apple/import.c new file mode 100644 index 00000000000..110a2d249ed --- /dev/null +++ b/gcc/testsuite/gcc.apple/import.c @@ -0,0 +1,9 @@ +/* APPLE LOCAL file #import not deprecated */ +/* { dg-do compile } */ +/* { dg-options "" } */ + +#import "importee.h" + +#import "importee.h" + +void foo (bar x) {} diff --git a/gcc/testsuite/gcc.apple/importee.h b/gcc/testsuite/gcc.apple/importee.h new file mode 100644 index 00000000000..86fbd11da4d --- /dev/null +++ b/gcc/testsuite/gcc.apple/importee.h @@ -0,0 +1,3 @@ +/* APPLE LOCAL file #import not deprecated */ + +typedef int bar; diff --git a/gcc/testsuite/gcc.apple/inttypes-1.c b/gcc/testsuite/gcc.apple/inttypes-1.c new file mode 100644 index 00000000000..40404e2995b --- /dev/null +++ b/gcc/testsuite/gcc.apple/inttypes-1.c @@ -0,0 +1,21 @@ +/* APPLE LOCAL file test of inttypes.h formatter macros */ + +/* { dg-do compile } */ +/* { dg-options "-Wall -W" } */ + +#include <stdio.h> +#include <inttypes.h> +#include <stdint.h> + +int main () +{ + uint32_t x = 12; + int32_t y = 15; + printf("x = %" PRIo32 "\n", x); + printf("x = %" PRIu32 "\n", x); + printf("x = %" PRIx32 "\n", x); + printf("x = %" PRIX32 "\n", x); + printf("y = %" PRId32 "\n", y); + printf("y = %" PRIi32 "\n", y); + return 0; +} diff --git a/gcc/testsuite/gcc.apple/no-warning.c b/gcc/testsuite/gcc.apple/no-warning.c new file mode 100644 index 00000000000..9b71d722239 --- /dev/null +++ b/gcc/testsuite/gcc.apple/no-warning.c @@ -0,0 +1,8 @@ +/* APPLE LOCAL file -Wno-#warnings */ + +/* { dg-do compile } */ +/* { dg-options "-Wno-#warnings" } */ + +#warning "suppress this warning" + +int a; diff --git a/gcc/testsuite/gcc.apple/one.framework/Headers/one.h b/gcc/testsuite/gcc.apple/one.framework/Headers/one.h new file mode 100644 index 00000000000..50c24d3e6c5 --- /dev/null +++ b/gcc/testsuite/gcc.apple/one.framework/Headers/one.h @@ -0,0 +1,3 @@ +/* Contributed by Devang Patel <dpatel@apple.com> */ + +/* Empty header */ diff --git a/gcc/testsuite/gcc.apple/pascal-strings-1.c b/gcc/testsuite/gcc.apple/pascal-strings-1.c new file mode 100644 index 00000000000..c4e2d86ddc9 --- /dev/null +++ b/gcc/testsuite/gcc.apple/pascal-strings-1.c @@ -0,0 +1,46 @@ +/* APPLE LOCAL file pascal strings */ +/* Positive C test cases. */ +/* Origin: Ziemowit Laski <zlaski@apple.com> */ +/* { dg-do run } */ +/* { dg-options "-std=iso9899:1999 -fpascal-strings" } */ + +typedef __WCHAR_TYPE__ wchar_t; +typedef __SIZE_TYPE__ size_t; + +extern void abort (void); +extern size_t strlen (const char *s); + +const unsigned char *pascalStr1 = "\pHello, World!"; +const unsigned char *concat1 = "\pConcatenated" "string" "\pliteral"; + +const unsigned char msg1[] = "\pHello"; /* ok */ +const unsigned char *msg2 = "\pHello"; /* ok */ +const signed char msg3[] = "\pHello"; /* ok */ +const char msg4[] = "\pHello"; /* ok */ +unsigned char msg5[] = "\pHello"; /* ok */ +signed char msg7[] = "\pHello"; /* ok */ +char msg8[] = "\pHello"; /* ok */ + +int +main (void) +{ + const unsigned char *pascalStr2 = "\pGood-bye!"; + + if (strlen ((const char *)pascalStr1) != 14) + abort (); + if (*pascalStr1 != 13) + abort (); /* the length byte does not include trailing null */ + + if (strlen ((const char *)pascalStr2) != 10) + abort (); + if (*pascalStr2 != 9) + abort (); + + if (strlen ((const char *)concat1) != 26) + abort (); + if (*concat1 != 25) + abort (); + + return 0; +} + diff --git a/gcc/testsuite/gcc.apple/pascal-strings-2.c b/gcc/testsuite/gcc.apple/pascal-strings-2.c new file mode 100644 index 00000000000..6b617fa32c5 --- /dev/null +++ b/gcc/testsuite/gcc.apple/pascal-strings-2.c @@ -0,0 +1,45 @@ +/* APPLE LOCAL file pascal strings */ +/* Negative C test cases. */ +/* Origin: Ziemowit Laski <zlaski@apple.com> */ +/* { dg-do compile } */ +/* { dg-options "-std=iso9899:1999 -Wwrite-strings -fpascal-strings" } */ + +typedef __WCHAR_TYPE__ wchar_t; + +const wchar_t *pascalStr1 = L"\pHi!"; /* { dg-warning "unknown escape sequence" } */ +const wchar_t *pascalStr2 = L"Bye\p!"; /* { dg-warning "unknown escape sequence" } */ + +const wchar_t *initErr0 = "\pHi"; /* { dg-warning "incompatible pointer type" } */ +const wchar_t initErr0a[] = "\pHi"; /* { dg-error "initialized from non-wide string" } */ +const wchar_t *initErr1 = "Bye"; /* { dg-warning "incompatible pointer type" } */ +const wchar_t initErr1a[] = "Bye"; /* { dg-error "initialized from non-wide string" } */ + +const char *initErr2 = L"Hi"; /* { dg-warning "incompatible pointer type" } */ +const char initErr2a[] = L"Hi"; /* { dg-error "initialized from wide string" } */ +const signed char *initErr3 = L"Hi"; /* { dg-warning "incompatible pointer type" } */ +const signed char initErr3a[] = L"Hi"; /* { dg-error "initialized from wide string" } */ +const unsigned char *initErr4 = L"Hi"; /* { dg-warning "incompatible pointer type" } */ +const unsigned char initErr4a[] = L"Hi"; /* { dg-error "initialized from wide string" } */ + +const char *pascalStr3 = "Hello\p, World!"; /* { dg-warning "unknown escape sequence" } */ + +const char *concat2 = "Hi" "\pthere"; /* { dg-warning "unknown escape sequence" } */ +const char *concat3 = "Hi" "there\p"; /* { dg-warning "unknown escape sequence" } */ + +const char *s2 = "\pGoodbye!"; /* ok */ +unsigned char *s3 = "\pHi!"; /* { dg-warning "initialization discards qualifiers" } */ +char *s4 = "\pHi"; /* { dg-warning "initialization discards qualifiers" } */ +signed char *s5 = "\pHi"; /* { dg-warning "initialization discards qualifiers" } */ +const signed char *s6 = "\pHi"; /* ok */ + +/* the maximum length of a Pascal literal is 255. */ +const unsigned char *almostTooLong = + "\p12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "123456789012345"; /* ok */ +const unsigned char *definitelyTooLong = + "\p12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "1234567890123456"; /* { dg-error "too long" } */ diff --git a/gcc/testsuite/gcc.apple/preprocess.s b/gcc/testsuite/gcc.apple/preprocess.s new file mode 100644 index 00000000000..897f2a7d6b1 --- /dev/null +++ b/gcc/testsuite/gcc.apple/preprocess.s @@ -0,0 +1,16 @@ +/* APPLE LOCAL file preprocess .s files */ + +/* Regression test - in assembly language, # may have some significance + other than 'stringize macro argument' and therefore must be preserved + in the output, and should not be warned about. */ + +/* { dg-do preprocess } */ + +#define foo() mov r0, #5 /* { dg-bogus "not followed" "spurious warning" } */ + +entry: + foo() + +/* Check we don't EOF on an unknown directive. */ +#unknown directive +#error a later diagnostic /* { dg-error "diagnostic" } */ diff --git a/gcc/testsuite/gcc.apple/special/liblongcall.c b/gcc/testsuite/gcc.apple/special/liblongcall.c new file mode 100644 index 00000000000..297e473927a --- /dev/null +++ b/gcc/testsuite/gcc.apple/special/liblongcall.c @@ -0,0 +1,9 @@ +/* { dg-do compile } */ +/* { dg-options "-mlongcall" } */ + +int +dy_foo (char *str, int i) +{ + printf ("dy_foo (\"%s\", %d)\n", str, i); + return i + 1; +} diff --git a/gcc/testsuite/gcc.apple/special/longcall-prog.c b/gcc/testsuite/gcc.apple/special/longcall-prog.c new file mode 100644 index 00000000000..59448507350 --- /dev/null +++ b/gcc/testsuite/gcc.apple/special/longcall-prog.c @@ -0,0 +1,17 @@ +#include <stdio.h> + +/* declare all externally visible functions in libweak.c */ +int dy_foo (char *, int); + +main () +{ + int answer, x=41; + char *str = "foostr"; + printf ("%s begins:\n", __FILE__); + answer = dy_foo (str, x); + printf ("dy_foo (\"%s\", %d) = %d", str, x, answer); + if (answer != 42) + printf (" (error!)"); + printf ("\n%s done.\n", __FILE__); + exit (answer != 42); +} diff --git a/gcc/testsuite/gcc.apple/special/longcall.exp b/gcc/testsuite/gcc.apple/special/longcall.exp new file mode 100644 index 00000000000..d9ebd1270ea --- /dev/null +++ b/gcc/testsuite/gcc.apple/special/longcall.exp @@ -0,0 +1,69 @@ +# APPLE LOCAL file testsuite +# Copyright (C) 2002 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + + +# Load support procs. +load_lib gcc-dg.exp + +# Initialize `dg'. +dg-init + +set timeout 30 + +set prms_id 0 +set bug_id 0 + +set testfile "longcall-prog" +set binfile ${objdir}/${subdir}/${testfile} +set srcfile ${srcdir}/${subdir}/${testfile}.c + +set libfilestem "longcall" +set libfile "lib${libfilestem}" +set libbinfile ${objdir}/${subdir}/${libfile}.dylib +set libsrcfile ${srcdir}/${subdir}/${libfile}.c + +file mkdir ${objdir}/${subdir} + +set test "longcall/dylib" + +proc note_result {success diagnostic} { + set verb [expr {($success) ? "pass" : "fail"}] + eval {$verb $diagnostic} +} + +set whine "building $test library" +set additional_flags "additional_flags=-dynamiclib -mlongcall" +set result [expr {[gcc_target_compile "${libsrcfile}" "${libbinfile}" executable [list debug $additional_flags]] == ""}] +note_result $result $whine + +set whine "building $test test program" +set additional_flags "additional_flags=-L${objdir}/${subdir} -l${libfilestem}" +set result [expr {[gcc_target_compile "${srcfile}" "${binfile}" executable [list debug $additional_flags]] == ""}] +note_result $result $whine + +set result [gcc_load "$binfile" "" ""] +set status [lindex $result 0] +set output [lindex $result 1]; +if {$status == "pass" } { + pass $test + file delete $libbinfile $binfile +} else { + fail $test +} + +# All done. +dg-finish diff --git a/gcc/testsuite/gcc.apple/special/special.exp b/gcc/testsuite/gcc.apple/special/special.exp new file mode 100644 index 00000000000..5344a4817b7 --- /dev/null +++ b/gcc/testsuite/gcc.apple/special/special.exp @@ -0,0 +1,42 @@ +# APPLE LOCAL file testsuite +# Copyright (C) 2002 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + + +# Load support procs. +load_lib gcc-dg.exp + +# Initialize `dg'. +dg-init + +# Test the zerofill support by seeing if a file with a large array +# compiled -fno-common has a small size on disk. + +gcc_target_compile "$srcdir/$subdir/zerofill.c" "zerofill.o" object \ + "additional_flags=-fno-common" + +set size [ exec wc -c < zerofill.o ] + +if { $size < 100000 } { + pass "zerofill" +} else { + fail "zerofill" +} + +file delete zerofill.o + +# All done. +dg-finish diff --git a/gcc/testsuite/gcc.apple/special/zerofill.c b/gcc/testsuite/gcc.apple/special/zerofill.c new file mode 100644 index 00000000000..e4bd84c816f --- /dev/null +++ b/gcc/testsuite/gcc.apple/special/zerofill.c @@ -0,0 +1,5 @@ +/* APPLE LOCAL file zerofill */ + +int arr[40000]; + +foo() {} diff --git a/gcc/testsuite/gcc.apple/string-insns.c b/gcc/testsuite/gcc.apple/string-insns.c new file mode 100644 index 00000000000..741ab60f5df --- /dev/null +++ b/gcc/testsuite/gcc.apple/string-insns.c @@ -0,0 +1,9 @@ +/* APPLE LOCAL radar 3509006 */ +/* { dg-do compile { target powerpc*-apple-darwin* } } */ +/* { dg-options "-Os" } */ +/* On ppc at Apple, -Os should not use string instructions. 3509006. */ +struct s { int a; int b; int c; }; +int foo (struct s* p, struct s* q) { + *p = *q; +} +/* { dg-final { scan-assembler-not "lswi" } } */ diff --git a/gcc/testsuite/gcc.c-torture/compile/simd-4.x b/gcc/testsuite/gcc.c-torture/compile/simd-4.x new file mode 100644 index 00000000000..6bb99bad79f --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/compile/simd-4.x @@ -0,0 +1,4 @@ +# APPLE LOCAL vector instructions are not supported except with -faltivec + +if { [istarget "*-apple-darwin*"] } { set options "-faltivec" } +return 0 diff --git a/gcc/testsuite/gcc.c-torture/execute/20040308-1.c b/gcc/testsuite/gcc.c-torture/execute/20040308-1.c deleted file mode 100644 index 4c63535e7f7..00000000000 --- a/gcc/testsuite/gcc.c-torture/execute/20040308-1.c +++ /dev/null @@ -1,21 +0,0 @@ -/* This used to fail on SPARC with an unaligned memory access. */ - -void foo(int n) -{ - struct S { - int i[n]; - unsigned int b:1; - int i2; - } __attribute__ ((packed)) __attribute__ ((aligned (4))); - - struct S s; - - s.i2 = 0; -} - -int main(void) -{ - foo(4); - - return 0; -} diff --git a/gcc/testsuite/gcc.c-torture/execute/20040309-1.c b/gcc/testsuite/gcc.c-torture/execute/20040309-1.c deleted file mode 100644 index 49fa79560c6..00000000000 --- a/gcc/testsuite/gcc.c-torture/execute/20040309-1.c +++ /dev/null @@ -1,24 +0,0 @@ -extern void abort (); - -int foo(unsigned short x) -{ - unsigned short y; - y = x > 32767 ? x - 32768 : 0; - return y; -} - -int main() -{ - if (foo (0) != 0) - abort (); - if (foo (32767) != 0) - abort (); - if (foo (32768) != 0) - abort (); - if (foo (32769) != 1) - abort (); - if (foo (65535) != 32767) - abort (); - return 0; -} - diff --git a/gcc/testsuite/gcc.c-torture/execute/20040311-1.c b/gcc/testsuite/gcc.c-torture/execute/20040311-1.c deleted file mode 100644 index 013d869abf4..00000000000 --- a/gcc/testsuite/gcc.c-torture/execute/20040311-1.c +++ /dev/null @@ -1,68 +0,0 @@ -/* Copyright (C) 2004 Free Software Foundation. - - Check that constant folding and RTL simplification of -(x >> y) doesn't - break anything and produces the expected results. - - Written by Roger Sayle, 11th March 2004. */ - -extern void abort (void); - -#define INT_BITS (sizeof(int)*8) - -int test1(int x) -{ - return -(x >> (INT_BITS-1)); -} - -int test2(unsigned int x) -{ - return -((int)(x >> (INT_BITS-1))); -} - -int test3(int x) -{ - int y; - y = INT_BITS-1; - return -(x >> y); -} - -int test4(unsigned int x) -{ - int y; - y = INT_BITS-1; - return -((int)(x >> y)); -} - -int main() -{ - if (test1(0) != 0) - abort (); - if (test1(1) != 0) - abort (); - if (test1(-1) != 1) - abort (); - - if (test2(0) != 0) - abort (); - if (test2(1) != 0) - abort (); - if (test2((unsigned int)-1) != -1) - abort (); - - if (test3(0) != 0) - abort (); - if (test3(1) != 0) - abort (); - if (test3(-1) != 1) - abort (); - - if (test4(0) != 0) - abort (); - if (test4(1) != 0) - abort (); - if (test4((unsigned int)-1) != -1) - abort (); - - return 0; -} - diff --git a/gcc/testsuite/gcc.c-torture/execute/20040313-1.c b/gcc/testsuite/gcc.c-torture/execute/20040313-1.c deleted file mode 100644 index c05fe730f0c..00000000000 --- a/gcc/testsuite/gcc.c-torture/execute/20040313-1.c +++ /dev/null @@ -1,17 +0,0 @@ -/* PR middle-end/14470 */ -/* Origin: Lodewijk Voge <lvoge@cs.vu.nl> */ - -extern void abort(void); - -int main() -{ - int t[1025] = { 1024 }, d; - - d = 0; - d = t[d]++; - if (t[0] != 1025) - abort(); - if (d != 1024) - abort(); - return 0; -} diff --git a/gcc/testsuite/gcc.c-torture/execute/simd-1.x b/gcc/testsuite/gcc.c-torture/execute/simd-1.x new file mode 100644 index 00000000000..db203f3d590 --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/simd-1.x @@ -0,0 +1,7 @@ +# APPLE LOCAL vector instructions are not supported except with -faltivec. xfailed it. + +if { [istarget "*-apple-darwin*"] } { + set torture_compile_xfail "*-apple-darwin*" +} + +return 0 diff --git a/gcc/testsuite/gcc.c-torture/execute/simd-2.x b/gcc/testsuite/gcc.c-torture/execute/simd-2.x new file mode 100644 index 00000000000..db203f3d590 --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/simd-2.x @@ -0,0 +1,7 @@ +# APPLE LOCAL vector instructions are not supported except with -faltivec. xfailed it. + +if { [istarget "*-apple-darwin*"] } { + set torture_compile_xfail "*-apple-darwin*" +} + +return 0 diff --git a/gcc/testsuite/gcc.dg/20020416-1.c b/gcc/testsuite/gcc.dg/20020416-1.c index db1a2617fcd..44916ef1b83 100644 --- a/gcc/testsuite/gcc.dg/20020416-1.c +++ b/gcc/testsuite/gcc.dg/20020416-1.c @@ -1,6 +1,7 @@ /* PR bootstrap/6315 */ /* { dg-do compile } */ -/* { dg-options "-O2" } */ +/* APPLE LOCAL -Wlong-double */ +/* { dg-options "-O2 -Wno-long-double" } */ /* { dg-options "-O2 -mhard-quad-float" { target sparc*-*-* } } */ /* { dg-options "-O2" { target sparclet*-*-* sparclite*-*-* sparc86x-*-* } } */ diff --git a/gcc/testsuite/gcc.dg/20040322-1.c b/gcc/testsuite/gcc.dg/20040322-1.c new file mode 100644 index 00000000000..af5e0b4820c --- /dev/null +++ b/gcc/testsuite/gcc.dg/20040322-1.c @@ -0,0 +1,4 @@ +/* PR c/14069 */ +/* { dg-do compile } */ +struct S { int a; char b[]; char *c; }; /* { dg-error "error" "flexible array member not" } */ +struct S s = { .b = "foo", .c = .b }; /* { dg-error "error" "parse error before" } */ diff --git a/gcc/testsuite/gcc.dg/20040331-1.c b/gcc/testsuite/gcc.dg/20040331-1.c new file mode 100644 index 00000000000..4cef3d3297a --- /dev/null +++ b/gcc/testsuite/gcc.dg/20040331-1.c @@ -0,0 +1,14 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -fwrapv" } */ + +extern void abort (void); +extern void exit (int); + +int +main (void) +{ + struct { int count: 2; } s = { -2 }; + while (s.count-- != -2) + abort (); + exit (0); +} diff --git a/gcc/testsuite/gcc.dg/20040409-1.c b/gcc/testsuite/gcc.dg/20040409-1.c new file mode 100644 index 00000000000..dc9206a0ae0 --- /dev/null +++ b/gcc/testsuite/gcc.dg/20040409-1.c @@ -0,0 +1,4 @@ +/* This tests to make sure that the attribute noreturn + can be used on function pointers. */ + +int (*temp) (void) __attribute__((noreturn)); diff --git a/gcc/testsuite/gcc.dg/Wshadow-2.c b/gcc/testsuite/gcc.dg/Wshadow-2.c new file mode 100644 index 00000000000..b0c051271ee --- /dev/null +++ b/gcc/testsuite/gcc.dg/Wshadow-2.c @@ -0,0 +1,10 @@ +/* Bogus warning for a double declaration of the same extern variable, + first at file scope, then at block scope. PR 13129. */ + +/* { dg-options "-Wshadow" } */ + +extern struct foo bar; +void dummy() +{ + extern struct foo bar; /* { dg-bogus "shadows" } */ +} diff --git a/gcc/testsuite/gcc.dg/altivec-13.c b/gcc/testsuite/gcc.dg/altivec-13.c new file mode 100644 index 00000000000..298e6100559 --- /dev/null +++ b/gcc/testsuite/gcc.dg/altivec-13.c @@ -0,0 +1,16 @@ +/* { dg-do compile { target powerpc*-*-* } } */ +/* { dg-options "-faltivec" } */ +/* Author: Ziemowit Laski <zlaski@apple.com> */ + +/* This test case exercises intrinsic/argument combinations that, + while not in the Motorola AltiVec PIM, have nevertheless crept + into the AltiVec vernacular over the years. */ + +void foo() { + vector bool int boolVec1 = (vector bool int) vec_splat_u32(3); + vector bool short boolVec2 = (vector bool short) vec_splat_u16(3); + vector bool char boolVec3 = (vector bool char) vec_splat_u8(3); + boolVec1 = vec_sld( boolVec1, boolVec1, 4 ); + boolVec2 = vec_sld( boolVec2, boolVec2, 2 ); + boolVec3 = vec_sld( boolVec3, boolVec3, 1 ); +} diff --git a/gcc/testsuite/gcc.dg/altivec-2.c b/gcc/testsuite/gcc.dg/altivec-2.c index f64081ff813..914910c3476 100644 --- a/gcc/testsuite/gcc.dg/altivec-2.c +++ b/gcc/testsuite/gcc.dg/altivec-2.c @@ -4,13 +4,12 @@ /* Program to test the vector_size attribute. This needs to run on a target that has vectors, so use AltiVec. */ -#define vector __attribute__((vector_size(16))) - vector int foobar; /* Only floats and integrals allowed. We don't care if they map to SIs. */ struct X { int frances; }; -vector struct X hotdog; /* { dg-error "invalid vector type" } */ +/* APPLE LOCAL AltiVec */ +vector struct X hotdog; /* { dg-error "(syntax error|invalid vector type)" } */ /* Arrays of vectors. */ vector char b[10], ouch; diff --git a/gcc/testsuite/gcc.dg/altivec-4.c b/gcc/testsuite/gcc.dg/altivec-4.c index 175663581ac..f5a46493152 100644 --- a/gcc/testsuite/gcc.dg/altivec-4.c +++ b/gcc/testsuite/gcc.dg/altivec-4.c @@ -1,8 +1,6 @@ /* { dg-do compile { target powerpc*-*-* } } */ /* { dg-options "-maltivec -O0 -Wall" } */ -#define vector __attribute__((vector_size(16))) - static int __attribute__((mode(V4SI))) x, y; static vector signed int i,j; diff --git a/gcc/testsuite/gcc.dg/altivec-5.c b/gcc/testsuite/gcc.dg/altivec-5.c index 0adfdb84d19..37c9a9fa79b 100644 --- a/gcc/testsuite/gcc.dg/altivec-5.c +++ b/gcc/testsuite/gcc.dg/altivec-5.c @@ -1,8 +1,6 @@ /* { dg-do compile { target powerpc*-*-* } } */ /* { dg-options "-maltivec -O2" } */ -#define vector __attribute__((vector_size(16))) - void foo (const unsigned long x, vector signed int a, vector signed int b) { diff --git a/gcc/testsuite/gcc.dg/altivec-varargs-1.c b/gcc/testsuite/gcc.dg/altivec-varargs-1.c index 14e5e6ee976..72e6c4ad9ba 100644 --- a/gcc/testsuite/gcc.dg/altivec-varargs-1.c +++ b/gcc/testsuite/gcc.dg/altivec-varargs-1.c @@ -6,7 +6,11 @@ #include "altivec_check.h" +/* APPLE LOCAL begin AltiVec */ +#ifndef vector #define vector __attribute__((mode(V4SI))) +#endif +/* APPLE LOCAL end AltiVec */ const vector unsigned int v1 = {10,11,12,13}; const vector unsigned int v2 = {20,21,22,23}; diff --git a/gcc/testsuite/gcc.dg/builtin-inf-1.c b/gcc/testsuite/gcc.dg/builtin-inf-1.c index d2d28415899..0e97114cfca 100644 --- a/gcc/testsuite/gcc.dg/builtin-inf-1.c +++ b/gcc/testsuite/gcc.dg/builtin-inf-1.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ - +/* { dg-options "-Wno-long-double" { target *-apple-darwin* } } */ float fi = __builtin_inff(); double di = __builtin_inf(); long double li = __builtin_infl(); diff --git a/gcc/testsuite/gcc.dg/builtins-35.c b/gcc/testsuite/gcc.dg/builtins-35.c new file mode 100644 index 00000000000..f898707e24a --- /dev/null +++ b/gcc/testsuite/gcc.dg/builtins-35.c @@ -0,0 +1,6 @@ +/* Test that nan functions are not built-in in C90 mode. Bug 14635. */ +/* Origin: Joseph Myers <jsm@polyomino.org.uk> */ +/* { dg-do compile } */ +/* { dg-options "-std=c89" } */ + +int nan, nanf, nanl, nans, nansf, nansl; diff --git a/gcc/testsuite/gcc.dg/builtins-36.c b/gcc/testsuite/gcc.dg/builtins-36.c new file mode 100644 index 00000000000..dc711988448 --- /dev/null +++ b/gcc/testsuite/gcc.dg/builtins-36.c @@ -0,0 +1,79 @@ +/* Copyright (C) 2004 Free Software Foundation. + + Check sin, sinf, sinl, cos, cosf and cosl built-in functions + eventually compile to sincos, sincosf and sincosl. + + Written by Uros Bizjak, 5th April 2004. */ + +/* { dg-do compile } */ +/* { dg-options "-O2 -ffast-math" } */ + +extern double sin(double); +extern float sinf(float); +extern long double sinl(long double); + +extern double cos(double); +extern float cosf(float); +extern long double cosl(long double); + + +double test1(double x) +{ + double y1, y2; + + y1 = sin(x); + y2 = cos(x); + + return y1 - y2; +} + +float test1f(float x) +{ + float y1, y2; + + y1 = sinf(x); + y2 = cosf(x); + + return y1 - y2; +} + +long double test1l(long double x) +{ + long double y1, y2; + + y1 = sinl(x); + y2 = cosl(x); + + return y1 - y2; +} + +double test2(double x) +{ + return sin(x); +} + +float test2f(float x) +{ + return sinf(x); +} + +long double test2l(long double x) +{ + return sinl(x); +} + +double test3(double x) +{ + return cos(x); +} + +float test3f(float x) +{ + return cosf(x); +} + +long double test3l(long double x) +{ + return cosl(x); +} + diff --git a/gcc/testsuite/gcc.dg/builtins-37.c b/gcc/testsuite/gcc.dg/builtins-37.c new file mode 100644 index 00000000000..e366a6ac552 --- /dev/null +++ b/gcc/testsuite/gcc.dg/builtins-37.c @@ -0,0 +1,29 @@ +/* Copyright (C) 2004 Free Software Foundation. + + Check tan, tanf and tanl built-in functions. + + Written by Uros Bizjak, 7th April 2004. */ + +/* { dg-do compile } */ +/* { dg-options "-O2 -ffast-math" } */ + +extern double tan(double); +extern float tanf(float); +extern long double tanl(long double); + + +double test1(double x) +{ + return tan(x); +} + +float test1f(float x) +{ + return tanf(x); +} + +long double test1l(long double x) +{ + return tanl(x); +} + diff --git a/gcc/testsuite/gcc.dg/c90-intprom-1.c b/gcc/testsuite/gcc.dg/c90-intprom-1.c new file mode 100644 index 00000000000..78e4b39ef35 --- /dev/null +++ b/gcc/testsuite/gcc.dg/c90-intprom-1.c @@ -0,0 +1,47 @@ +/* Test for integer promotion rules: C90 subset of types. */ +/* Origin: Joseph Myers <jsm@polyomino.org.uk> */ +/* { dg-do compile } */ +/* { dg-options "-std=iso9899:1990 -pedantic-errors" } */ + +#include <limits.h> + +#define CHECK(T1, T2, TC) \ + do { \ + T1 a = 0; \ + T2 b = 0; \ + TC *c = 0; \ + __typeof__(a+b) *d = 0; \ + c = d; \ + d = c; \ + } while (0) + +void +f (void) +{ + /* One type is unsigned long. */ + CHECK(unsigned long, unsigned long, unsigned long); + CHECK(unsigned int, unsigned long, unsigned long); + CHECK(unsigned long, unsigned int, unsigned long); + CHECK(int, unsigned long, unsigned long); + CHECK(long, unsigned long, unsigned long); + CHECK(unsigned long, int, unsigned long); + CHECK(unsigned long, long, unsigned long); + /* long and unsigned int. */ +#if LONG_MAX >= UINT_MAX + CHECK(unsigned int, long, long); + CHECK(long, unsigned int, long); +#else + CHECK(unsigned int, long, unsigned long); + CHECK(long, unsigned int, unsigned long); +#endif + /* One type is long. */ + CHECK(long, long, long); + CHECK(int, long, long); + CHECK(long, int, long); + /* One type is unsigned int. */ + CHECK(unsigned int, unsigned int, unsigned int); + CHECK(int, unsigned int, unsigned int); + CHECK(unsigned int, int, unsigned int); + /* Otherwise int. */ + CHECK(int, int, int); +} diff --git a/gcc/testsuite/gcc.dg/c99-complex-1.c b/gcc/testsuite/gcc.dg/c99-complex-1.c index 2e1ba7df539..494cdd6a266 100644 --- a/gcc/testsuite/gcc.dg/c99-complex-1.c +++ b/gcc/testsuite/gcc.dg/c99-complex-1.c @@ -1,8 +1,8 @@ /* Test for _Complex: in C99 only. A few basic tests. */ /* Origin: Joseph Myers <jsm28@cam.ac.uk> */ /* { dg-do compile } */ -/* { dg-options "-std=iso9899:1999 -pedantic-errors" } */ - +/* APPLE LOCAL -Wlong-double */ +/* { dg-options "-std=iso9899:1999 -pedantic-errors -Wno-long-double" } */ /* Test _Complex allowed on floating types. */ float _Complex a; diff --git a/gcc/testsuite/gcc.dg/c99-intprom-1.c b/gcc/testsuite/gcc.dg/c99-intprom-1.c new file mode 100644 index 00000000000..0d7a33ee8be --- /dev/null +++ b/gcc/testsuite/gcc.dg/c99-intprom-1.c @@ -0,0 +1,77 @@ +/* Test for integer promotion rules: extended to long long by C99. */ +/* Origin: Joseph Myers <jsm@polyomino.org.uk> */ +/* { dg-do compile } */ +/* { dg-options "-std=iso9899:1999 -pedantic-errors" } */ + +#include <limits.h> + +#define CHECK(T1, T2, TC) \ + do { \ + T1 a = 0; \ + T2 b = 0; \ + TC *c = 0; \ + __typeof__(a+b) *d = 0; \ + c = d; \ + d = c; \ + } while (0) + +void +f (void) +{ + /* Same type. */ + CHECK(int, int, int); + CHECK(unsigned int, unsigned int, unsigned int); + CHECK(long, long, long); + CHECK(unsigned long, unsigned long, unsigned long); + CHECK(long long, long long, long long); + CHECK(unsigned long long, unsigned long long, unsigned long long); + /* Both signed. */ + CHECK(int, long, long); + CHECK(int, long long, long long); + CHECK(long, int, long); + CHECK(long, long long, long long); + CHECK(long long, int, long long); + CHECK(long long, long, long long); + /* Both unsigned. */ + CHECK(unsigned int, unsigned long, unsigned long); + CHECK(unsigned int, unsigned long long, unsigned long long); + CHECK(unsigned long, unsigned int, unsigned long); + CHECK(unsigned long, unsigned long long, unsigned long long); + CHECK(unsigned long long, unsigned int, unsigned long long); + CHECK(unsigned long long, unsigned long, unsigned long long); + /* Unsigned of greater or equal rank. */ + CHECK(int, unsigned int, unsigned int); + CHECK(int, unsigned long, unsigned long); + CHECK(int, unsigned long long, unsigned long long); + CHECK(unsigned int, int, unsigned int); + CHECK(long, unsigned long, unsigned long); + CHECK(long, unsigned long long, unsigned long long); + CHECK(unsigned long, int, unsigned long); + CHECK(unsigned long, long, unsigned long); + CHECK(long long, unsigned long long, unsigned long long); + CHECK(unsigned long long, int, unsigned long long); + CHECK(unsigned long long, long, unsigned long long); + CHECK(unsigned long long, long long, unsigned long long); + /* Signed of greater rank. */ +#if LONG_MAX >= UINT_MAX + CHECK(unsigned int, long, long); + CHECK(long, unsigned int, long); +#else + CHECK(unsigned int, long, unsigned long); + CHECK(long, unsigned int, unsigned long); +#endif +#if LLONG_MAX >= UINT_MAX + CHECK(unsigned int, long long, long long); + CHECK(long long, unsigned int, long long); +#else + CHECK(unsigned int, long long, unsigned long long); + CHECK(long long, unsigned int, unsigned long long); +#endif +#if LLONG_MAX >= ULONG_MAX + CHECK(unsigned long, long long, long long); + CHECK(long long, unsigned long, long long); +#else + CHECK(unsigned long, long long, unsigned long long); + CHECK(long long, unsigned long, unsigned long long); +#endif +} diff --git a/gcc/testsuite/gcc.dg/cast-ptr-1.c b/gcc/testsuite/gcc.dg/cast-ptr-1.c new file mode 100644 index 00000000000..cb42d13ac48 --- /dev/null +++ b/gcc/testsuite/gcc.dg/cast-ptr-1.c @@ -0,0 +1,15 @@ +/* APPLE LOCAL file pointer casts */ +/* Test that casts of pointer to unsigned long long aren't sign extended */ +/* Author: Matt Austern <austern@apple.com> */ +/* { dg-do run } */ +/* { dg-options "-Wno-error -w" } */ + +int main () { + /* Note: test assumes sizeof(long long) >= sizeof(void*) */ + + unsigned long x1 = 0x80000000ul; + void* p = (void*) x1; + unsigned long long x2 = (unsigned long long) p; + + return !(x1 == x2); +} diff --git a/gcc/testsuite/gcc.dg/charset/asm1.c b/gcc/testsuite/gcc.dg/charset/asm1.c deleted file mode 100644 index d7578d418f6..00000000000 --- a/gcc/testsuite/gcc.dg/charset/asm1.c +++ /dev/null @@ -1,14 +0,0 @@ -/* { dg-do compile } - { dg-require-iconv "IBM-1047" } - { dg-final { scan-assembler ".ascii bar" } } - { dg-final { scan-assembler ".ascii foo" } } - */ -extern int x, y; - -asm (".ascii bar"); - -int foo (void) -{ - __asm__ (".ascii foo"); - return 0; -} diff --git a/gcc/testsuite/gcc.dg/charset/asm3.c b/gcc/testsuite/gcc.dg/charset/asm3.c deleted file mode 100644 index 8d8dbbb524d..00000000000 --- a/gcc/testsuite/gcc.dg/charset/asm3.c +++ /dev/null @@ -1,33 +0,0 @@ -/* Test for complex asm statements. Make sure it compiles - then test for some of the asm statements not being translated. */ -/* { dg-do compile { target i?86-*-* } } - { dg-require-iconv "IBM-1047" } - { dg-final { scan-assembler "std" } } - { dg-final { scan-assembler "cld" } } - { dg-final { scan-assembler "rep" } } - { dg-final { scan-assembler "movsb" } } */ -#define size_t int -void * -memmove (void *__dest, __const void *__src, size_t __n) -{ - register unsigned long int __d0, __d1, __d2; - if (__dest < __src) - __asm__ __volatile__ - ("cld\n\t" - "rep\n\t" - "movsb" - : "=&c" (__d0), "=&S" (__d1), "=&D" (__d2) - : "0" (__n), "1" (__src), "2" (__dest) - : "memory"); - else - __asm__ __volatile__ - ("std\n\t" - "rep\n\t" - "movsb\n\t" - "cld" - : "=&c" (__d0), "=&S" (__d1), "=&D" (__d2) - : "0" (__n), "1" (__n - 1 + (const char *) __src), - "2" (__n - 1 + (char *) __dest) - : "memory"); - return __dest; -} diff --git a/gcc/testsuite/gcc.dg/charset/asm4.c b/gcc/testsuite/gcc.dg/charset/asm4.c deleted file mode 100644 index cd850c3e81f..00000000000 --- a/gcc/testsuite/gcc.dg/charset/asm4.c +++ /dev/null @@ -1,10 +0,0 @@ -/* Simple asm test. */ -/* { dg-do compile } - { dg-require-iconv "IBM-1047" } - { dg-final { scan-assembler "foo" } } */ -extern int bar; - -int main (void) -{ - asm ("foo %0" : "=r" (bar)); -} diff --git a/gcc/testsuite/gcc.dg/charset/asm5.c b/gcc/testsuite/gcc.dg/charset/asm5.c deleted file mode 100644 index fa93f40fdaf..00000000000 --- a/gcc/testsuite/gcc.dg/charset/asm5.c +++ /dev/null @@ -1,8 +0,0 @@ -/* Test for string translation. */ -/* { dg-do compile } - { dg-require-iconv "IBM-1047" } - { dg-final { scan-assembler-not "translate" } } */ -void foo (void) -{ - asm ("xx" : : "r"("translate") : "cc"); -} diff --git a/gcc/testsuite/gcc.dg/charset/attribute1.c b/gcc/testsuite/gcc.dg/charset/attribute1.c deleted file mode 100644 index 993c7934c80..00000000000 --- a/gcc/testsuite/gcc.dg/charset/attribute1.c +++ /dev/null @@ -1,10 +0,0 @@ -/* Test for attribute non-translation. */ -/* { dg-do compile } - { dg-require-iconv "IBM-1047" } - { dg-final { scan-assembler "foo" } } */ -int walrus __attribute__ ((section (".foo"))); - -int main (void) -{ - return 0; -} diff --git a/gcc/testsuite/gcc.dg/charset/attribute2.c b/gcc/testsuite/gcc.dg/charset/attribute2.c deleted file mode 100644 index 4ce95a51f84..00000000000 --- a/gcc/testsuite/gcc.dg/charset/attribute2.c +++ /dev/null @@ -1,8 +0,0 @@ -/* Test to make sure that invalid attributes aren't translated. - If error recovery is ever testable then "foobar" should be - translated. */ -/* { dg-do compile } - { dg-require-iconv "IBM-1047" } - */ -int foo __attribute__ ((walrus)); /* { dg-error "walrus" "ignored" } */ -char x[] = "foobar"; diff --git a/gcc/testsuite/gcc.dg/charset/string.c b/gcc/testsuite/gcc.dg/charset/string.c deleted file mode 100644 index 375e28a2ed6..00000000000 --- a/gcc/testsuite/gcc.dg/charset/string.c +++ /dev/null @@ -1,5 +0,0 @@ -/* Simple character translation test. */ -/* { dg-do compile } - { dg-require-iconv "IBM-1047" } - { dg-final { scan-assembler-not "string foobar" } } */ -char *foo = "string foobar"; diff --git a/gcc/testsuite/gcc.dg/compare8.c b/gcc/testsuite/gcc.dg/compare8.c new file mode 100644 index 00000000000..d723c45a095 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compare8.c @@ -0,0 +1,21 @@ +/* { dg-do compile } */ +/* { dg-options "-Wsign-compare" } */ + +int +f(unsigned short a1, unsigned short a2, unsigned int b) +{ + return ((a1+a2)|5) > b ? 2 : 3; /* { dg-bogus "signed and unsigned" } */ +} + +int +g(unsigned short a1, unsigned short a2, unsigned int b) +{ + return ((a1+a2)&5) > b ? 2 : 3; /* { dg-bogus "signed and unsigned" } */ +} + +int +h(unsigned short a1, unsigned short a2, unsigned int b) +{ + return ((a1+a2)^5) > b ? 2 : 3; /* { dg-bogus "signed and unsigned" } */ +} + diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_main.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_main.c new file mode 100644 index 00000000000..d6f9eff2563 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_main.c @@ -0,0 +1,14 @@ +/* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are float + scalars. */ + +extern void struct_by_value_5a_x (void); +extern void exit (int); +int fails; + +int +main () +{ + struct_by_value_5a_x (); + exit (0); +} diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_x.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_x.c new file mode 100644 index 00000000000..90738a7a7e8 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_x.c @@ -0,0 +1,43 @@ +#include "compat-common.h" + +#include "fp-struct-defs.h" +#include "fp-struct-check.h" +#include "fp-struct-test-by-value-x.h" + +DEFS(f, float) +CHECKS(f, float) + +TEST(Sf1, float) +TEST(Sf2, float) +TEST(Sf3, float) +TEST(Sf4, float) +TEST(Sf5, float) +TEST(Sf6, float) +TEST(Sf7, float) +TEST(Sf8, float) + +#undef T + +void +struct_by_value_5a_x () +{ +DEBUG_INIT + +#define T(TYPE, MTYPE) testit##TYPE (); + +T(Sf1, float) +T(Sf2, float) +T(Sf3, float) +T(Sf4, float) +T(Sf5, float) +T(Sf6, float) +T(Sf7, float) +T(Sf8, float) + +DEBUG_FINI + +if (fails != 0) + abort (); + +#undef T +} diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_y.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_y.c new file mode 100644 index 00000000000..9ac1f913474 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_y.c @@ -0,0 +1,25 @@ +#include <stdarg.h> + +#include "compat-common.h" + +#ifdef SKIP_VA +const int test_va = 0; +#else +const int test_va = 1; +#endif + +#include "fp-struct-defs.h" +#include "fp-struct-init.h" +#include "fp-struct-test-by-value-y.h" + +DEFS(f,float) +INITS(f, float) + +TEST(Sf1, float) +TEST(Sf2, float) +TEST(Sf3, float) +TEST(Sf4, float) +TEST(Sf5, float) +TEST(Sf6, float) +TEST(Sf7, float) +TEST(Sf8, float) diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_main.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_main.c new file mode 100644 index 00000000000..dcb5f27ed09 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_main.c @@ -0,0 +1,14 @@ +/* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are float + scalars. */ + +extern void struct_by_value_5b_x (void); +extern void exit (int); +int fails; + +int +main () +{ + struct_by_value_5b_x (); + exit (0); +} diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_x.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_x.c new file mode 100644 index 00000000000..3c371558728 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_x.c @@ -0,0 +1,43 @@ +#include "compat-common.h" + +#include "fp-struct-defs.h" +#include "fp-struct-check.h" +#include "fp-struct-test-by-value-x.h" + +DEFS(f, float) +CHECKS(f, float) + +TEST(Sf9, float) +TEST(Sf10, float) +TEST(Sf11, float) +TEST(Sf12, float) +TEST(Sf13, float) +TEST(Sf14, float) +TEST(Sf15, float) +TEST(Sf16, float) + +#undef T + +void +struct_by_value_5b_x () +{ +DEBUG_INIT + +#define T(TYPE, MTYPE) testit##TYPE (); + +T(Sf9, float) +T(Sf10, float) +T(Sf11, float) +T(Sf12, float) +T(Sf13, float) +T(Sf14, float) +T(Sf15, float) +T(Sf16, float) + +DEBUG_FINI + +if (fails != 0) + abort (); + +#undef T +} diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_y.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_y.c new file mode 100644 index 00000000000..cedc1660709 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_y.c @@ -0,0 +1,25 @@ +#include <stdarg.h> + +#include "compat-common.h" + +#ifdef SKIP_VA +const int test_va = 0; +#else +const int test_va = 1; +#endif + +#include "fp-struct-defs.h" +#include "fp-struct-init.h" +#include "fp-struct-test-by-value-y.h" + +DEFS(f,float) +INITS(f, float) + +TEST(Sf9, float) +TEST(Sf10, float) +TEST(Sf11, float) +TEST(Sf12, float) +TEST(Sf13, float) +TEST(Sf14, float) +TEST(Sf15, float) +TEST(Sf16, float) diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_main.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_main.c new file mode 100644 index 00000000000..609c1d67308 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_main.c @@ -0,0 +1,14 @@ +/* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are double + scalars. */ + +extern void struct_by_value_6a_x (void); +extern void exit (int); +int fails; + +int +main () +{ + struct_by_value_6a_x (); + exit (0); +} diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_x.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_x.c new file mode 100644 index 00000000000..e6852d9c9b7 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_x.c @@ -0,0 +1,43 @@ +#include "compat-common.h" + +#include "fp-struct-defs.h" +#include "fp-struct-check.h" +#include "fp-struct-test-by-value-x.h" + +DEFS(d, double) +CHECKS(d, double) + +TEST(Sd1, double) +TEST(Sd2, double) +TEST(Sd3, double) +TEST(Sd4, double) +TEST(Sd5, double) +TEST(Sd6, double) +TEST(Sd7, double) +TEST(Sd8, double) + +#undef T + +void +struct_by_value_6a_x () +{ +DEBUG_INIT + +#define T(TYPE, MTYPE) testit##TYPE (); + +T(Sd1, double) +T(Sd2, double) +T(Sd3, double) +T(Sd4, double) +T(Sd5, double) +T(Sd6, double) +T(Sd7, double) +T(Sd8, double) + +DEBUG_FINI + +if (fails != 0) + abort (); + +#undef T +} diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_y.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_y.c new file mode 100644 index 00000000000..8684b53c2f3 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_y.c @@ -0,0 +1,25 @@ +#include <stdarg.h> + +#include "compat-common.h" + +#ifdef SKIP_VA +const int test_va = 0; +#else +const int test_va = 1; +#endif + +#include "fp-struct-defs.h" +#include "fp-struct-init.h" +#include "fp-struct-test-by-value-y.h" + +DEFS(d, double) +INITS(d, double) + +TEST(Sd1, double) +TEST(Sd2, double) +TEST(Sd3, double) +TEST(Sd4, double) +TEST(Sd5, double) +TEST(Sd6, double) +TEST(Sd7, double) +TEST(Sd8, double) diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_main.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_main.c new file mode 100644 index 00000000000..ff17221718f --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_main.c @@ -0,0 +1,14 @@ +/* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are double + scalars. */ + +extern void struct_by_value_6b_x (void); +extern void exit (int); +int fails; + +int +main () +{ + struct_by_value_6b_x (); + exit (0); +} diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_x.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_x.c new file mode 100644 index 00000000000..5b285c9c5b6 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_x.c @@ -0,0 +1,43 @@ +#include "compat-common.h" + +#include "fp-struct-defs.h" +#include "fp-struct-check.h" +#include "fp-struct-test-by-value-x.h" + +DEFS(d, double) +CHECKS(d, double) + +TEST(Sd9, double) +TEST(Sd10, double) +TEST(Sd11, double) +TEST(Sd12, double) +TEST(Sd13, double) +TEST(Sd14, double) +TEST(Sd15, double) +TEST(Sd16, double) + +#undef T + +void +struct_by_value_6b_x () +{ +DEBUG_INIT + +#define T(TYPE, MTYPE) testit##TYPE (); + +T(Sd9, double) +T(Sd10, double) +T(Sd11, double) +T(Sd12, double) +T(Sd13, double) +T(Sd14, double) +T(Sd15, double) +T(Sd16, double) + +DEBUG_FINI + +if (fails != 0) + abort (); + +#undef T +} diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_y.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_y.c new file mode 100644 index 00000000000..c568761b241 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_y.c @@ -0,0 +1,25 @@ +#include <stdarg.h> + +#include "compat-common.h" + +#ifdef SKIP_VA +const int test_va = 0; +#else +const int test_va = 1; +#endif + +#include "fp-struct-defs.h" +#include "fp-struct-init.h" +#include "fp-struct-test-by-value-y.h" + +DEFS(d, double) +INITS(d, double) + +TEST(Sd9, double) +TEST(Sd10, double) +TEST(Sd11, double) +TEST(Sd12, double) +TEST(Sd13, double) +TEST(Sd14, double) +TEST(Sd15, double) +TEST(Sd16, double) diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_main.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_main.c new file mode 100644 index 00000000000..8379dc563c5 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_main.c @@ -0,0 +1,14 @@ +/* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are long double + scalars. */ + +extern void struct_by_value_7a_x (void); +extern void exit (int); +int fails; + +int +main () +{ + struct_by_value_7a_x (); + exit (0); +} diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_x.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_x.c new file mode 100644 index 00000000000..9818c3c2251 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_x.c @@ -0,0 +1,43 @@ +#include "compat-common.h" + +#include "fp-struct-defs.h" +#include "fp-struct-check.h" +#include "fp-struct-test-by-value-x.h" + +DEFS(ld, long double) +CHECKS(ld, long double) + +TEST(Sld1, long double) +TEST(Sld2, long double) +TEST(Sld3, long double) +TEST(Sld4, long double) +TEST(Sld5, long double) +TEST(Sld6, long double) +TEST(Sld7, long double) +TEST(Sld8, long double) + +#undef T + +void +struct_by_value_7a_x () +{ +DEBUG_INIT + +#define T(TYPE, MTYPE) testit##TYPE (); + +T(Sld1, long double) +T(Sld2, long double) +T(Sld3, long double) +T(Sld4, long double) +T(Sld5, long double) +T(Sld6, long double) +T(Sld7, long double) +T(Sld8, long double) + +DEBUG_FINI + +if (fails != 0) + abort (); + +#undef T +} diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_y.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_y.c new file mode 100644 index 00000000000..cb53df89dac --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_y.c @@ -0,0 +1,25 @@ +#include <stdarg.h> + +#include "compat-common.h" + +#ifdef SKIP_VA +const int test_va = 0; +#else +const int test_va = 1; +#endif + +#include "fp-struct-defs.h" +#include "fp-struct-init.h" +#include "fp-struct-test-by-value-y.h" + +DEFS(ld, long double) +INITS(ld, long double) + +TEST(Sld1, long double) +TEST(Sld2, long double) +TEST(Sld3, long double) +TEST(Sld4, long double) +TEST(Sld5, long double) +TEST(Sld6, long double) +TEST(Sld7, long double) +TEST(Sld8, long double) diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_main.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_main.c new file mode 100644 index 00000000000..5d6908bfc1f --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_main.c @@ -0,0 +1,14 @@ +/* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are long double + scalars. */ + +extern void struct_by_value_7b_x (void); +extern void exit (int); +int fails; + +int +main () +{ + struct_by_value_7b_x (); + exit (0); +} diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_x.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_x.c new file mode 100644 index 00000000000..508ff616584 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_x.c @@ -0,0 +1,43 @@ +#include "compat-common.h" + +#include "fp-struct-defs.h" +#include "fp-struct-check.h" +#include "fp-struct-test-by-value-x.h" + +DEFS(ld, long double) +CHECKS(ld, long double) + +TEST(Sld9, long double) +TEST(Sld10, long double) +TEST(Sld11, long double) +TEST(Sld12, long double) +TEST(Sld13, long double) +TEST(Sld14, long double) +TEST(Sld15, long double) +TEST(Sld16, long double) + +#undef T + +void +struct_by_value_7b_x () +{ +DEBUG_INIT + +#define T(TYPE, MTYPE) testit##TYPE (); + +T(Sld9, long double) +T(Sld10, long double) +T(Sld11, long double) +T(Sld12, long double) +T(Sld13, long double) +T(Sld14, long double) +T(Sld15, long double) +T(Sld16, long double) + +DEBUG_FINI + +if (fails != 0) + abort (); + +#undef T +} diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_y.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_y.c new file mode 100644 index 00000000000..cc70a7d2925 --- /dev/null +++ b/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_y.c @@ -0,0 +1,25 @@ +#include <stdarg.h> + +#include "compat-common.h" + +#ifdef SKIP_VA +const int test_va = 0; +#else +const int test_va = 1; +#endif + +#include "fp-struct-defs.h" +#include "fp-struct-init.h" +#include "fp-struct-test-by-value-y.h" + +DEFS(ld, long double) +INITS(ld, long double) + +TEST(Sld9, long double) +TEST(Sld10, long double) +TEST(Sld11, long double) +TEST(Sld12, long double) +TEST(Sld13, long double) +TEST(Sld14, long double) +TEST(Sld15, long double) +TEST(Sld16, long double) diff --git a/gcc/testsuite/gcc.dg/cpp/c++98-pedantic.cc b/gcc/testsuite/gcc.dg/cpp/c++98-pedantic.cc new file mode 100644 index 00000000000..1e8c160a96f --- /dev/null +++ b/gcc/testsuite/gcc.dg/cpp/c++98-pedantic.cc @@ -0,0 +1,11 @@ +/* APPLE LOCAL file rename for HFS */ +/* Copyright (C) 2000 Free Software Foundation, Inc. */ + +/* { dg-do preprocess } */ +/* { dg-options "-std=c++98 -pedantic" } */ + +/* This file is for testing the preprocessor in -std=c++98 -pedantic mode. + Neil Booth, 2 Dec 2000. */ + +#if 1LL /* { dg-warning "long long" } */ +#endif diff --git a/gcc/testsuite/gcc.dg/cpp/c++98.cc b/gcc/testsuite/gcc.dg/cpp/c++98.cc new file mode 100644 index 00000000000..a9843b878fd --- /dev/null +++ b/gcc/testsuite/gcc.dg/cpp/c++98.cc @@ -0,0 +1,11 @@ +/* APPLE LOCAL file rename for HFS */ +/* Copyright (C) 2000 Free Software Foundation, Inc. */ + +/* { dg-do preprocess } */ +/* { dg-options "-std=c++98" } */ + +/* This file is for testing the preprocessor in -std=c++98 mode. + Neil Booth, 2 Dec 2000. */ + +#if 1LL +#endif diff --git a/gcc/testsuite/gcc.dg/cpp/endif-pedantic2.c b/gcc/testsuite/gcc.dg/cpp/endif-pedantic2.c index d5c6eb960e6..a5db0fbc80f 100644 --- a/gcc/testsuite/gcc.dg/cpp/endif-pedantic2.c +++ b/gcc/testsuite/gcc.dg/cpp/endif-pedantic2.c @@ -1,8 +1,8 @@ /* Copyright (C) 2002 Free Software Foundation, Inc. */ - /* { dg-do preprocess } */ /* { dg-options "-Wno-endif-labels -pedantic" } */ - +/* APPLE LOCAL No error emit by Apple's default, use -Wextra-tokens to enable */ +/* { dg-options "-Wextra-tokens -Wno-endif-labels -pedantic" { target *-apple-darwin* } } */ /* Tests combinations of -pedantic and -Wno-endif-labels; see extratokens2.c for more general tests. */ diff --git a/gcc/testsuite/gcc.dg/cpp/extratokens.c b/gcc/testsuite/gcc.dg/cpp/extratokens.c index c06a41d4c2b..e57374cef93 100644 --- a/gcc/testsuite/gcc.dg/cpp/extratokens.c +++ b/gcc/testsuite/gcc.dg/cpp/extratokens.c @@ -1,7 +1,8 @@ /* Copyright (C) 2000 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ -/* { dg-options "-fno-show-column" } */ +/* APPLE LOCAL Wextra-tokens */ +/* { dg-options "-fno-show-column -Wextra-tokens" } */ /* Tests all directives that do not permit excess tokens at the end of the line. */ diff --git a/gcc/testsuite/gcc.dg/cpp/if-2.c b/gcc/testsuite/gcc.dg/cpp/if-2.c index 866d25c3a60..6630bf55d65 100644 --- a/gcc/testsuite/gcc.dg/cpp/if-2.c +++ b/gcc/testsuite/gcc.dg/cpp/if-2.c @@ -18,6 +18,8 @@ #endif #if 'abcd' /* { dg-warning "multi-character character constant" "multi-character charconst" } */ +# /* APPLE LOCAL enable the warning with the -Wfour-char-constants flag */ +# /* { dg-options "-Wfour-char-constants" { target *-apple-darwin* } } */ #endif #if 'abcdefghi' /* { dg-error "character constant (is )?too long" "charconst too long" } */ diff --git a/gcc/testsuite/gcc.dg/cpp/include2.c b/gcc/testsuite/gcc.dg/cpp/include2.c index 60edfccb0cd..e935703b614 100644 --- a/gcc/testsuite/gcc.dg/cpp/include2.c +++ b/gcc/testsuite/gcc.dg/cpp/include2.c @@ -1,10 +1,10 @@ /* Copyright (C) 2000 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ - +/* APPLE LOCAL BEGIN Apple disable this warning by default */ /* Tests that #include does not allow the terminating '>' or '"' to be escaped, as per the standard. */ - +/* { dg-options "-Wextra-tokens" } */ /* Source: Neil Booth, 4 Nov 2000. */ #include <silly\>> /* { dg-warning "extra tokens" "" } */ @@ -13,4 +13,4 @@ /* These error is No such file or directory, just once. However, this message is locale-dependent, so don't test for it. */ /* { dg-error "silly" "" { target *-*-* } 10 } */ - +/* APPLE LOCAL END */ diff --git a/gcc/testsuite/gcc.dg/cpp/skipping2.c b/gcc/testsuite/gcc.dg/cpp/skipping2.c index 3b0d0f32c8e..21378003fe2 100644 --- a/gcc/testsuite/gcc.dg/cpp/skipping2.c +++ b/gcc/testsuite/gcc.dg/cpp/skipping2.c @@ -6,6 +6,9 @@ /* Source: Neil Booth, 25 Jul 2001. */ +/* APPLE LOCAL -Wextra-tokens required in Apple's compiler to elicit req'd warnings here */ +/* { dg-options "-Wextra-tokens" } */ + #if 0 #if foo #else foo /* { dg-bogus "extra tokens" "extra tokens in skipped block" } */ diff --git a/gcc/testsuite/gcc.dg/cpp/sysmac2.c b/gcc/testsuite/gcc.dg/cpp/sysmac2.c index 0d1efabdc07..19ddf6ccb94 100644 --- a/gcc/testsuite/gcc.dg/cpp/sysmac2.c +++ b/gcc/testsuite/gcc.dg/cpp/sysmac2.c @@ -1,7 +1,8 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. */ /* { dg-do compile } */ -/* { dg-options "-std=gnu99 -pedantic -Wtraditional -fno-show-column" } */ +/* APPLE LOCAL -Wlong-double */ +/* { dg-options "-std=gnu99 -pedantic -Wtraditional -fno-show-column -Wno-long-double" } */ /* Tests diagnostics are suppressed for some macros defined in system headers. */ diff --git a/gcc/testsuite/gcc.dg/debug/20020220-1.c b/gcc/testsuite/gcc.dg/debug/20020220-1.c index 07109e86a98..21bdc22b62b 100644 --- a/gcc/testsuite/gcc.dg/debug/20020220-1.c +++ b/gcc/testsuite/gcc.dg/debug/20020220-1.c @@ -3,6 +3,8 @@ constant -4.0 in constant pool was never referenced by anything but Dwarf-2 location descriptor. */ /* { dg-do run } */ +/* APPLE LOCAL -Wlong-double */ +/* { dg-options "-Wno-long-double" } */ void __attribute__((noinline)) foo (const char *x __attribute__((unused)), diff --git a/gcc/testsuite/gcc.dg/debug/debug-1.c b/gcc/testsuite/gcc.dg/debug/debug-1.c index 8cc520dcd79..b6faed04519 100644 --- a/gcc/testsuite/gcc.dg/debug/debug-1.c +++ b/gcc/testsuite/gcc.dg/debug/debug-1.c @@ -1,7 +1,8 @@ /* Verify that the scheduler does not discard the lexical block. */ /* { dg-do compile } */ /* { dg-options "-dA" } */ -/* { dg-final { scan-assembler "xyzzy" } } */ +/* APPLE LOCAL xfail for Apple only, serena */ +/* { dg-final { scan-assembler "xyzzy" { xfail *-apple-darwin* } } } */ long p; diff --git a/gcc/testsuite/gcc.dg/debug/debug-2.c b/gcc/testsuite/gcc.dg/debug/debug-2.c index b164ff97734..f3a3cf80777 100644 --- a/gcc/testsuite/gcc.dg/debug/debug-2.c +++ b/gcc/testsuite/gcc.dg/debug/debug-2.c @@ -1,7 +1,8 @@ /* Verify that the scheduler does not discard the lexical block. */ /* { dg-do compile } */ /* { dg-options "-dA" } */ -/* { dg-final { scan-assembler "xyzzy" } } */ +/* APPLE LOCAL xfail for Apple only, serena */ +/* { dg-final { scan-assembler "xyzzy" { xfail *-apple-darwin* } } } */ long p; diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die1.c b/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die1.c deleted file mode 100644 index 39f0bf2792a..00000000000 --- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die1.c +++ /dev/null @@ -1,8 +0,0 @@ -/* Verify that inline function never actually inlined has no abstract DIE. */ -/* { dg-do compile */ -/* { dg-options "-O2 -gdwarf-2 -dA" } */ -/* { dg-final { scan-assembler-not "DW_AT_inline" } } */ -inline int t() -{ -} -int (*q)()=t; diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die2.c b/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die2.c deleted file mode 100644 index 48bce243d41..00000000000 --- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die2.c +++ /dev/null @@ -1,7 +0,0 @@ -/* Verify that inline function never actually emit has no DIE. */ -/* { dg-do compile */ -/* { dg-options "-O0 -gdwarf-2 -dA" } */ -/* { dg-final { scan-assembler-not "CIE Version" } } */ -static inline int t() -{ -} diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die3.c b/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die3.c deleted file mode 100644 index 34fddfaffc0..00000000000 --- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die3.c +++ /dev/null @@ -1,11 +0,0 @@ -/* Verify that extern inline function never actually inlined has no abstract DIE. */ -/* { dg-do compile */ -/* { dg-options "-O0 -gdwarf-2 -dA" } */ -/* { dg-final { scan-assembler-not "DW_AT_inline" } } */ -extern inline int t() -{ -} -int (*q)()=t; -int t() -{ -} diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die5.c b/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die5.c deleted file mode 100644 index b3a245d2b11..00000000000 --- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die5.c +++ /dev/null @@ -1,12 +0,0 @@ -/* Inlined inline function must have abstract DIE */ -/* { dg-do compile */ -/* { dg-options "-O2 -gdwarf-2 -dA -fpreprocessed" } */ -/* { dg-final { scan-assembler "3.*DW_AT_inline" } } */ -#1 "test.h" -inline int t() -{ -} -int q() -{ - t(); -} diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die6.c b/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die6.c deleted file mode 100644 index 40cdc8dee37..00000000000 --- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die6.c +++ /dev/null @@ -1,12 +0,0 @@ -/* not inline inline function must not have abstract DIE */ -/* { dg-do compile */ -/* { dg-options "-O2 -fno-inline -gdwarf-2 -dA -fpreprocessed" } */ -/* { dg-final { scan-assembler-not "DW_AT_inline" } } */ -#1 "test.h" -inline int t() -{ -} -int q() -{ - t(); -} diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die7.c b/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die7.c deleted file mode 100644 index d8d013af38c..00000000000 --- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die7.c +++ /dev/null @@ -1,14 +0,0 @@ -/* Inlined non-inline function must have abstract DIE */ -/* { dg-do compile */ -/* { dg-options "-O2 -gdwarf-2 -dA -fpreprocessed" } */ -/* { dg-final { scan-assembler "1.*DW_AT_inline" } } */ -#1 "test.h" -void f(void); -static int t() -{ - f(); -} -int q() -{ - t(); -} diff --git a/gcc/testsuite/gcc.dg/dg.exp b/gcc/testsuite/gcc.dg/dg.exp index 14cf79d7e14..eb11a3a70c5 100644 --- a/gcc/testsuite/gcc.dg/dg.exp +++ b/gcc/testsuite/gcc.dg/dg.exp @@ -22,7 +22,7 @@ load_lib gcc-dg.exp # If a testcase doesn't have special options, use these. global DEFAULT_CFLAGS if ![info exists DEFAULT_CFLAGS] then { - set DEFAULT_CFLAGS " -ansi -pedantic-errors" + set DEFAULT_CFLAGS " -ansi -pedantic-errors -Wno-long-double" } # Initialize `dg'. diff --git a/gcc/testsuite/gcc.dg/format/c90-printf-1.c b/gcc/testsuite/gcc.dg/format/c90-printf-1.c index e4c18f76862..f2a566aa5fa 100644 --- a/gcc/testsuite/gcc.dg/format/c90-printf-1.c +++ b/gcc/testsuite/gcc.dg/format/c90-printf-1.c @@ -4,7 +4,8 @@ */ /* Origin: Joseph Myers <jsm28@cam.ac.uk> */ /* { dg-do compile } */ -/* { dg-options "-std=iso9899:1990 -pedantic -Wformat" } */ +/* APPLE LOCAL -Wlong-double */ +/* { dg-options "-std=iso9899:1990 -pedantic -Wformat -Wno-long-double" } */ #include "format.h" diff --git a/gcc/testsuite/gcc.dg/format/c90-scanf-1.c b/gcc/testsuite/gcc.dg/format/c90-scanf-1.c index ea42f1e131e..2a949f937a7 100644 --- a/gcc/testsuite/gcc.dg/format/c90-scanf-1.c +++ b/gcc/testsuite/gcc.dg/format/c90-scanf-1.c @@ -4,7 +4,8 @@ */ /* Origin: Joseph Myers <jsm28@cam.ac.uk> */ /* { dg-do compile } */ -/* { dg-options "-std=iso9899:1990 -pedantic -Wformat" } */ +/* APPLE LOCAL -Wlong-double */ +/* { dg-options "-std=iso9899:1990 -pedantic -Wformat -Wno-long-double" } */ #include "format.h" diff --git a/gcc/testsuite/gcc.dg/format/strfmon-1.c b/gcc/testsuite/gcc.dg/format/strfmon-1.c index d163751328c..94c68586f49 100644 --- a/gcc/testsuite/gcc.dg/format/strfmon-1.c +++ b/gcc/testsuite/gcc.dg/format/strfmon-1.c @@ -1,7 +1,8 @@ /* Test for strfmon format checking. */ /* Origin: Joseph Myers <jsm28@cam.ac.uk> */ /* { dg-do compile } */ -/* { dg-options "-std=gnu99 -Wformat" } */ +/* APPLE LOCAL -Wlong-double */ +/* { dg-options "-std=gnu99 -Wformat -Wno-long-double" } */ #include "format.h" diff --git a/gcc/testsuite/gcc.dg/gnu89-init-3.c b/gcc/testsuite/gcc.dg/gnu89-init-3.c new file mode 100644 index 00000000000..bd4283ec875 --- /dev/null +++ b/gcc/testsuite/gcc.dg/gnu89-init-3.c @@ -0,0 +1,18 @@ +/* PR 11527 */ +/* { dg-do compile } */ +/* { dg-options "-std=gnu89" } */ + +typedef struct smrdd_memory_blocks_s +{ + int blocks; + int block[]; +} smrdd_memory_blocks_t; + +const smrdd_memory_blocks_t smrdd_memory_blocks = +{ + 3, + { + [5] = 5, + [1] = 2, + } +}; diff --git a/gcc/testsuite/gcc.dg/i386-387-7.c b/gcc/testsuite/gcc.dg/i386-387-7.c new file mode 100644 index 00000000000..43c916c61d0 --- /dev/null +++ b/gcc/testsuite/gcc.dg/i386-387-7.c @@ -0,0 +1,10 @@ +/* Verify that 387 fsincos instruction is generated. */ +/* { dg-do compile { target "i?86-*-*" } } */ +/* { dg-options "-O -ffast-math -march=i686" } */ +/* { dg-final { scan-assembler "fsincos" } } */ + +double f1(double x) +{ + return sin(x) + cos (x); +} + diff --git a/gcc/testsuite/gcc.dg/i386-387-8.c b/gcc/testsuite/gcc.dg/i386-387-8.c new file mode 100644 index 00000000000..05787160b00 --- /dev/null +++ b/gcc/testsuite/gcc.dg/i386-387-8.c @@ -0,0 +1,12 @@ +/* Verify that 387 fptan instruction is generated. Also check fptan + peephole2 optimizer. */ +/* { dg-do compile { target "i?86-*-*" } } */ +/* { dg-options "-O2 -ffast-math -march=i686" } */ +/* { dg-final { scan-assembler "fptan" } } */ +/* { dg-final { scan-assembler-not "fld1" } } */ + +double f1(double x) +{ + return 1.0 / tan(x); +} + diff --git a/gcc/testsuite/gcc.dg/noncompile/incomplete-3.c b/gcc/testsuite/gcc.dg/noncompile/incomplete-3.c new file mode 100644 index 00000000000..735ef465b38 --- /dev/null +++ b/gcc/testsuite/gcc.dg/noncompile/incomplete-3.c @@ -0,0 +1,9 @@ +/* Both occurrences of "c" should get diagnostics. PR 12391. */ +typedef struct { int a; } b_t; + +int foo (void) +{ + b_t d; + struct b_t *c = &d; /* { dg-warning "incompatible pointer type" } */ + c->a; /* { dg-error "incomplete type" } */ +} diff --git a/gcc/testsuite/gcc.dg/noncompile/undeclared-1.c b/gcc/testsuite/gcc.dg/noncompile/undeclared-1.c new file mode 100644 index 00000000000..5bb7c2a4df9 --- /dev/null +++ b/gcc/testsuite/gcc.dg/noncompile/undeclared-1.c @@ -0,0 +1,8 @@ +/* Test for no ICE with an undeclared identifier in an enum in old-style + parameter decls. PR 12560. */ +/* { dg-options "-w" } */ + +foo(c) + enum { a = b } c; /* { dg-error "undeclared|for each" } */ +{ +} diff --git a/gcc/testsuite/gcc.dg/noncompile/undeclared-2.c b/gcc/testsuite/gcc.dg/noncompile/undeclared-2.c new file mode 100644 index 00000000000..36cd0eaf175 --- /dev/null +++ b/gcc/testsuite/gcc.dg/noncompile/undeclared-2.c @@ -0,0 +1,3 @@ +/* Invalid, but should not ICE. PRs 11944, 14734. */ + +void foo(const int[i]); /* { dg-error "undeclared|for each" } */ diff --git a/gcc/testsuite/gcc.dg/pch/apple-altivec-1.c b/gcc/testsuite/gcc.dg/pch/apple-altivec-1.c new file mode 100644 index 00000000000..7dc24c0d797 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/apple-altivec-1.c @@ -0,0 +1,126 @@ +/* APPLE LOCAL file AltiVec */ +/* { dg-do compile { target powerpc-*-darwin* } } */ +/* { dg-options "-faltivec -Wno-long-double -I." } */ + +#include "apple-altivec-1.h" + +/* Test for correct handling of AltiVec constants passed + through '...' (va_arg). */ + +#include <stdarg.h> +#include <stdio.h> +#include <stdlib.h> + +#define CHECK_INVARIANT(expr) \ + if (!(expr)) { \ + printf ("ASSERT FAILED: %d: %s\n", __LINE__, #expr); \ + abort (); \ + } + +struct foo { int x; int y; }; +struct vfoo { int x; __vector signed int v; int y; }; +union u { __vector signed int v; signed int i[4]; }; + +struct foo x_g = { 3, 4}; +struct vfoo vx_g = { 10, (vector signed int)(11, 12, 13, 14), 15 }; +__vector signed int v_g = (vector signed int) (22, 23, 24, 25); +struct vfoo vx2_g = { 30, (vector signed int)(31, 32, 33, 34), 35 }; +__vector signed int v2_g = (vector signed int)(40, 41, 42, 43); +int i_1 = 99, i_2 = 33; +double d_2 = 1.5, d_3 = 1.75; +long double ld_1 = 1.25; + +void bar (int i, ... ) +{ + struct foo xi; + double d; + long double ld; + float f; + char c; + short s; + va_list ap; + va_start(ap, i); + xi = va_arg(ap, struct foo); + s = (short)va_arg(ap, int); + f = (float)va_arg(ap, double); + ld = va_arg(ap, long double); + c = (char)va_arg(ap, int); + d = va_arg(ap, double); + va_end(ap); + + CHECK_INVARIANT (xi.x == x_g.x && xi.y == x_g.y); + CHECK_INVARIANT (s == (short)i_2); + CHECK_INVARIANT (f == (float)d_2); + CHECK_INVARIANT (ld == ld_1); + CHECK_INVARIANT (c == (char)i_1); + CHECK_INVARIANT (d == d_3); +} + +void baz (int i, ... ) +{ + struct vfoo vx, vx2; + __vector signed int v_i, v2_i; + int j, k, l; + va_list ap; + va_start(ap, i); + v_i = va_arg(ap, __vector signed int); + j = va_arg(ap, int); + vx = va_arg(ap, struct vfoo); + k = va_arg(ap, int); + v2_i = va_arg(ap, __vector signed int); + l = va_arg(ap, int); + vx2 = va_arg(ap, struct vfoo); + va_end(ap); + + CHECK_INVARIANT (vec_all_eq (v_i, v_g)); + CHECK_INVARIANT (j == i_1); + CHECK_INVARIANT (vx.x == vx_g.x && vec_all_eq(vx.v, vx_g.v) && vx.y == vx_g.y); + CHECK_INVARIANT (k == i_1); + CHECK_INVARIANT (vec_all_eq (v2_i, v2_g)); + CHECK_INVARIANT (l == i_1); + CHECK_INVARIANT (vx2.x == vx2_g.x && vec_all_eq(vx2.v, vx2_g.v) && vx2.y == vx2_g.y); +} + +void quux (int i, ... ) +{ + __vector signed int v_i, v2_i; + union u vi, v2i; + va_list ap; + va_start(ap, i); + v_i = va_arg(ap, __vector signed int); + v2_i = va_arg(ap, __vector signed int); + va_end(ap); + vi.v = v_i; + v2i.v = v2_i; + + CHECK_INVARIANT (vec_all_eq (v_i, v_g)); + CHECK_INVARIANT (vec_all_eq (v2_i, v_g)); + CHECK_INVARIANT (vec_all_eq (vi.v, v_g)); + CHECK_INVARIANT (vec_all_eq (v2i.v, v_g)); +} + +void baz2 (int i, ... ) +{ + struct vfoo vx; + union u vxi; + va_list ap; + va_start(ap, i); + vx = va_arg(ap, struct vfoo); + va_end(ap); + vxi.v = vx.v; + + CHECK_INVARIANT (vx.x == vx_g.x && vec_all_eq(vx.v, vx_g.v) && vx.y == vx_g.y); + CHECK_INVARIANT (vec_all_eq (vxi.v, vx_g.v)); +} + +int main(void) +{ + CHECK_INVARIANT (sizeof(struct foo) == 8 && sizeof(struct vfoo) == 48); + + bar(i_1, x_g, (short)i_2, (float)d_2, ld_1, (char)i_1, d_3); + baz(i_1, v_g, i_1, vx_g, i_1, v2_g, i_1, vx2_g); + quux(i_1, v_g, v_g); + baz2(i_1, vx_g); + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/pch/apple-altivec-1.hs b/gcc/testsuite/gcc.dg/pch/apple-altivec-1.hs new file mode 100644 index 00000000000..d31591ae112 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/apple-altivec-1.hs @@ -0,0 +1,2 @@ +/* APPLE LOCAL file AltiVec */ +/* { dg-options "-faltivec -Wno-long-double" } */ diff --git a/gcc/testsuite/gcc.dg/pch/valid-1.c b/gcc/testsuite/gcc.dg/pch/valid-1.c new file mode 100644 index 00000000000..ebfa85a9949 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-1.c @@ -0,0 +1,5 @@ +/* { dg-options "-I. -Winvalid-pch -g" } */ + +#include "valid-1.h"/* { dg-error "created with -gnone, but used with -g|No such file|they were invalid" } */ + +int x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-1.hs b/gcc/testsuite/gcc.dg/pch/valid-1.hs new file mode 100644 index 00000000000..e1ed11df4cc --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-1.hs @@ -0,0 +1,3 @@ +/* { dg-options "-I. -Winvalid-pch -g0" } */ + +extern int x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-1b.c b/gcc/testsuite/gcc.dg/pch/valid-1b.c new file mode 100644 index 00000000000..a2709967c07 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-1b.c @@ -0,0 +1,5 @@ +/* { dg-options "-I. -Winvalid-pch -g0" } */ + +#include "valid-1b.h" + +int x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-1b.hs b/gcc/testsuite/gcc.dg/pch/valid-1b.hs new file mode 100644 index 00000000000..6dc358735a7 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-1b.hs @@ -0,0 +1,3 @@ +/* { dg-options "-I. -Winvalid-pch -g" } */ + +extern int x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-2.c b/gcc/testsuite/gcc.dg/pch/valid-2.c new file mode 100644 index 00000000000..52a2e35a441 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-2.c @@ -0,0 +1,5 @@ +/* { dg-options "-I. -Winvalid-pch -fexceptions" } */ + +#include "valid-2.h"/* { dg-error "settings for -fexceptions do not match|No such file|they were invalid" } */ + +int x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-2.hs b/gcc/testsuite/gcc.dg/pch/valid-2.hs new file mode 100644 index 00000000000..2497af651c2 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-2.hs @@ -0,0 +1 @@ +extern int x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-3.c b/gcc/testsuite/gcc.dg/pch/valid-3.c new file mode 100644 index 00000000000..741a917df5d --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-3.c @@ -0,0 +1,5 @@ +/* { dg-options "-I. -Winvalid-pch -fno-unit-at-a-time" } */ + +#include "valid-3.h"/* { dg-error "settings for -funit-at-a-time do not match|No such file|they were invalid" } */ + +int x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-3.hs b/gcc/testsuite/gcc.dg/pch/valid-3.hs new file mode 100644 index 00000000000..2a0af94c9f7 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-3.hs @@ -0,0 +1,3 @@ +/* { dg-options "-I. -Winvalid-pch -funit-at-a-time" } */ + +extern int x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-4.c b/gcc/testsuite/gcc.dg/pch/valid-4.c new file mode 100644 index 00000000000..1249531ef67 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-4.c @@ -0,0 +1,6 @@ +/* { dg-options "-I. -Winvalid-pch -Wtrigraphs" } */ + +#include "valid-4.h" + +char * x = "??/"; /* { dg-error "trigraph" } */ + diff --git a/gcc/testsuite/gcc.dg/pch/valid-4.hs b/gcc/testsuite/gcc.dg/pch/valid-4.hs new file mode 100644 index 00000000000..051c720ee3f --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-4.hs @@ -0,0 +1 @@ +extern char * x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-5.c b/gcc/testsuite/gcc.dg/pch/valid-5.c new file mode 100644 index 00000000000..4022d0458f2 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-5.c @@ -0,0 +1,5 @@ +/* { dg-options "-I. -Winvalid-pch -pedantic-errors" } */ + +#include "valid-5.h" + +int x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-5.hs b/gcc/testsuite/gcc.dg/pch/valid-5.hs new file mode 100644 index 00000000000..2497af651c2 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-5.hs @@ -0,0 +1 @@ +extern int x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-6.c b/gcc/testsuite/gcc.dg/pch/valid-6.c new file mode 100644 index 00000000000..f111c31ae99 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-6.c @@ -0,0 +1,5 @@ +/* { dg-options "-I. -Winvalid-pch -dH -pipe -fcond-mismatch" } */ + +#include "valid-6.h" + +int x; diff --git a/gcc/testsuite/gcc.dg/pch/valid-6.hs b/gcc/testsuite/gcc.dg/pch/valid-6.hs new file mode 100644 index 00000000000..2497af651c2 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pch/valid-6.hs @@ -0,0 +1 @@ +extern int x; diff --git a/gcc/testsuite/gcc.dg/reg-vol-struct-1.c b/gcc/testsuite/gcc.dg/reg-vol-struct-1.c new file mode 100644 index 00000000000..7751bb4a117 --- /dev/null +++ b/gcc/testsuite/gcc.dg/reg-vol-struct-1.c @@ -0,0 +1,18 @@ +/* Test cases of structures with volatile fields declared register: + should be allowed unless register name given but explicitly taking + the address forbidden. */ +/* Origin: Joseph Myers <jsm@polyomino.org.uk> */ + +/* { dg-do compile } */ + +struct S { volatile int field; }; + +void +f (void) +{ + register struct S a; + register struct S b[2]; + register struct S c __asm__("nosuchreg"); /* { dg-error "object with volatile field" "explicit reg name" } */ + &a; /* { dg-warning "address of register" "explicit address" } */ + b; /* { dg-warning "address of register" "implicit address" } */ +} diff --git a/gcc/testsuite/gcc.dg/simd-1.c b/gcc/testsuite/gcc.dg/simd-1.c index fff6292d1a0..43e63e4a40e 100644 --- a/gcc/testsuite/gcc.dg/simd-1.c +++ b/gcc/testsuite/gcc.dg/simd-1.c @@ -4,10 +4,10 @@ /* Origin: Aldy Hernandez <aldyh@redhat.com>. */ /* Purpose: Program to test generic SIMD support. */ -typedef int __attribute__((mode(V4SI))) v4si; -typedef int __attribute__((mode(V8HI))) v8hi; -typedef int __attribute__((mode(V2SI))) v2si; -typedef unsigned int __attribute__((mode(V4SI))) uv4si; +typedef int __attribute__((vector_size (16))) v4si; +typedef short __attribute__((vector_size (16))) v8hi; +typedef int __attribute__((vector_size (8))) v2si; +typedef unsigned int __attribute__((vector_size (16))) uv4si; v4si a, b; v2si c, d; @@ -16,7 +16,7 @@ uv4si f; int foo __attribute__((mode(DI))); int foo1 __attribute__((mode(SI))); -int foo2 __attribute__((mode(V4HI))); +short foo2 __attribute__((vector_size (8))); void hanneke () @@ -32,7 +32,7 @@ hanneke () e = (typeof (e)) a; /* Different signed SIMD assignment. */ - f = a; /* { dg-error "incompatible types in assignment" } */ + f = a; /* Casted different signed SIMD assignment. */ f = (uv4si) a; diff --git a/gcc/testsuite/gcc.dg/spill-1.c b/gcc/testsuite/gcc.dg/spill-1.c new file mode 100644 index 00000000000..b85942e87aa --- /dev/null +++ b/gcc/testsuite/gcc.dg/spill-1.c @@ -0,0 +1,15 @@ +/* This caused an ICE during register spilling when targeting thumb. + There are 8 registers available for arithmetic operations (r0-r7) + r7 is the frame pointer, and r0-r3 are used to pass arguments. + Combine was extending the lives of the arguments (in r0-r3) up until the + call to z. This leaves only 3 regs free which isn't enough to preform the + doubleword addition. */ +/* { dg-do compile } */ +/* { dg-options "-O2 -fno-omit-frame-pointer" } */ +void z(int); +int foo(int a, int b, int c, int d, long long *q) +{ + *q=*q+1; + z (a+b+c+d); +} + diff --git a/gcc/testsuite/gcc.dg/ss/README b/gcc/testsuite/gcc.dg/ss/README new file mode 100644 index 00000000000..ca8a96a5483 --- /dev/null +++ b/gcc/testsuite/gcc.dg/ss/README @@ -0,0 +1,17 @@ +APPLE LOCAL entire file + +This directory contains tests for Symbol Separation. + +Information about various files in this directory: + +README : This file +ss.exp : Driver for Symbol Separation tests +*.h : Normal header file +*.ssh : Header file is candidate for making separate + repository. This header is included in source + file as *.h. It will renamed on the fly during + test. + +*.c : Normal source file +*_part_2.c : Second source file associated with corrosponding + *.c source file. diff --git a/gcc/testsuite/gcc.dg/ss/one.c b/gcc/testsuite/gcc.dg/ss/one.c new file mode 100644 index 00000000000..866177926c9 --- /dev/null +++ b/gcc/testsuite/gcc.dg/ss/one.c @@ -0,0 +1,18 @@ +/* APPLE LOCAL entire file */ +/* Copyright (C) 2003 Free Software Foundation. + Contributed by Devang Patel <dpatel@apple.com> */ + +/* Test simple use of symbol repository. + Include file one.h is supplied as one.ssh in this directory, + so that ss.exp can pick it up as candidate for making + repository. */ +/* { dg-do assemble } */ + +#include "one.h" +int main () +{ + struct x_y_point a; + a.x = 0; + a.y = 0; + return 0; +} diff --git a/gcc/testsuite/gcc.dg/ss/one.ssh b/gcc/testsuite/gcc.dg/ss/one.ssh new file mode 100644 index 00000000000..57d77bbf06d --- /dev/null +++ b/gcc/testsuite/gcc.dg/ss/one.ssh @@ -0,0 +1,13 @@ +/* APPLE LOCAL entire file */ + +/* Copyright (C) 2003 Free Software Foundation. + Contributed by Devang Patel <dpatel@apple.com> */ + +/* Test simple use of symbol repository. + Part of one.c test. */ + +struct x_y_point +{ + int x; + int y; +}; diff --git a/gcc/testsuite/gcc.dg/ss/ss-cmd1.c b/gcc/testsuite/gcc.dg/ss/ss-cmd1.c new file mode 100644 index 00000000000..167d666f63e --- /dev/null +++ b/gcc/testsuite/gcc.dg/ss/ss-cmd1.c @@ -0,0 +1,10 @@ +/* APPLE LOCAL entire file */ +/* Copyright (C) 2003 Free Software Foundation. + Contributed by Devang Patel <dpatel@apple.com> */ +/* Test command line option -grepository */ +/* { dg-do compile } */ +/* { dg-options "-grepository" } */ +int main() +{ + return 0; +} diff --git a/gcc/testsuite/gcc.dg/ss/ss.exp b/gcc/testsuite/gcc.dg/ss/ss.exp new file mode 100644 index 00000000000..b393f973425 --- /dev/null +++ b/gcc/testsuite/gcc.dg/ss/ss.exp @@ -0,0 +1,235 @@ +# APPLE LOCAL entire file +# Copyright (C) 1997, 2002, 2003 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# GCC testsuite for symbol separation interaction, +# that uses the `dg.exp' driver. + +# Load support procs. +load_lib gcc-dg.exp + +# Initialize `dg'. +dg-init + +# Get checksum (first field of BINCL and EXCL stab information +proc get_checksum {input_file search_string} { + + # Regular expression to extract hexadecimal word + set hexexp {[0-9a-fA-F]+} + + # Do nm on input_file and grep for search_string + catch {exec nm -ap $input_file >& $input_file.nm} + catch {exec grep "$search_string" $input_file.nm >& $input_file.grep} + + # Extract dummy-checksum from the grep result (first hexdecimal word) + # and save it in RESULT + set file_h [open $input_file.grep r] + while {[gets $file_h line] >= 0} { + # We expect only one line in file_h + regexp $hexexp $line RESULT + } + close $file_h + + # Clean up + catch { file delete "$input_file.nm" } + catch { file delete "$input_file.grep" } + + # Return check sum + return $RESULT +} + +set old_dg_do_what_default "${dg-do-what-default}" + +# Main loop. +foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.c]] { + global runtests torture_without_loops dg-do-what-default + + # If we're only testing specific files and this isn't one of them, skip it. + if ![runtest_file_p $runtests $test] { + continue + } + + # [file tail name] returns part of name after last / + set nshort "$subdir/[file tail $test]" + set short_bname "[file rootname [file tail $test]]" + set bname "[file rootname $test]" + set hexexp {[0-9a-fA-F]+} + set ss_exp_debug 0 + + catch { file delete "$bname.h" } + catch { file delete "$bname.h.cinfo" } + catch { file delete "$bname.o" } + catch { file delete "$bname.h.o" } + + # We don't try to use the loop-optimizing options, since they are highly + # unlikely to make any difference to CINFO. + foreach flags $torture_without_loops { + verbose "Testing $nshort, $flags" 1 + + if {$ss_exp_debug == 1} { + puts "ss_exp_debug: various names" + puts "ss_exp_debug bname:"; puts $bname + puts "ss_exp_debug bname.ssh:"; puts $bname.ssh + puts "ss_exp_debug test:"; puts $test + puts "ss_exp_debug short_bname:"; puts $short_bname + } + + # 1) compile foo.h to create foo.cinfo and foo.h.o + if { [ file exists "$bname.ssh" ] } { + + # For the header files, the default is to make repository + set dg-do-what-default assemble + + # Header files are supplied using .ssh extension, so that we can + # identify candidates for makeing symbol repository. Get header copy + # with .h here. + file copy -force "$bname.ssh" "$bname.h" + file copy -force "$bname.ssh" "$short_bname.h" + + # Make repository + # This will create two output files, $short_bname.o and $short_h.cinfo + dg-test -keep-output "$bname.h" $flags "-fsave-repository=. " + + if { [ file exists "$short_bname.o" ] } { + file rename -force "$short_bname.o" "$bname.h.o" + + # Do nm on $bname.h.o and grep for "BINCL $bname.h" + # Extract dummy-checksum from the grep result and save it in RESULT1 + set RESULT1 [get_checksum $bname.h.o "BINCL $bname.h"] + + if {$ss_exp_debug == 1} { + puts "ss_exp_debug: RESULT1"; puts $RESULT1 + } + + pass "$nshort $flags Make Repository" + + } else { + set RESULT1 " " + fail "$nshort $flags Make Repository" + } + + if { [ file exists "$short_bname.h.cinfo" ] } { + + # 2) compile foo.c to create foo.o + dg-test -keep-output $test $flags "-I. -grepository -Winvalid-sr" + if { [ file exists "$short_bname.o" ] } { + + # Do nm on $bname.o and grep for "EXCL $bname.h" + # Extract dummy-checksum from the grep result and save it in RESULT2 + set RESULT2 [get_checksum $short_bname.o "EXCL $bname.h"] + + if {$ss_exp_debug == 1} { + puts "ss_exp_debug: RESULT2"; puts $RESULT2 + } + + pass "$nshort $flags Use symbol repository" + + } else { + set RESULT2 " " + fail "$nshort $flags Use symbol repository YES" + } + + + if { [ file exists "$bname.part_2.c" ] } { + + # 3) compile foo_part_2.c to create foo_part_2.o + dg-test -keep-output "$bname_part_2.c" $flags "-I. -grepository" + if { [ file exists "$short_bname_part_2.o" ] } { + + # Do nm on $bname_part_2.o and grep for "EXCL $bname.h" + # Extract dummy-checksum from the grep result and save it in RESULT3 + set RESULT3 [get_checksum $short_bname_part_2.o "EXCL $bname.h"] + + if {$ss_exp_debug == 1} { + puts "ss_exp_debug: RESULT3"; puts $RESULT3 + } + + pass "$nshort $flags Use symbol repository" + + } else { + set RESULT3 " " + fail "$nshort $flags Use symbol repository" + } + + # 4) Link foo.h.o foo.o and foo_part_2.o to create foo + set dg-do-what-default link + dg-test -keep-output "$bname.h.o" "$bname.o" "$bname_part_2.o" "-o $short_bname.out" + + # 5) do 'nm |grep ' on final assembler and save result in RES4 + # Do nm on $bname.out and grep for "EXCL $bname.h" + # Extract dummy-checksum from the grep result and save it in RESULT4 + set RESULT4 [get_checksum $short_bname.out "EXCL $bname.h"] + + # Do nm on $bname.out and grep for "BINCL $bname.h" + # Extract dummy-checksum from the grep result and save it in RESULT5 + set RESULT5 [get_checksum $short_bname.out "BINCL $bname.h"] + + if {$ss_exp_debug == 1} { + puts "ss_exp_debug: RESULT4"; puts $RESULT4 + puts "ss_exp_debug: RESULT5"; puts $RESULT5 + } + + pass "$nshort $flags symbol separation: linking" + + } else { + + # If we are not testing second part then set values so that comparison test succeeds + set RESULT3 $RESULT2 + set RESULT4 $RESULT2 + set RESULT5 $RESULT2 + if {$ss_exp_debug == 1} { + puts "ss_exp_debug: RESULT3"; puts $RESULT3 + puts "ss_exp_debug: RESULT4"; puts $RESULT4 + puts "ss_exp_debug: RESULT5"; puts $RESULT5 + } + } + + # 6) Compare RES1 and RES2 and RES3 and RES4 + if { ( $RESULT1 == $RESULT2 ) + && ( $RESULT1 == $RESULT3 ) + && ( $RESULT1 == $RESULT4 ) } { + pass "$nshort $flags symbol separation valid use test" + } else { + fail "$nshort $flags symbol separation valid use test" + } + if { ( $RESULT1 == $RESULT5 ) } { + pass "$nshort $flags symbol separation link test" + } else { + fail "$nshort $flags symbol separation link test" + } + + } else { + fail "$nshort $flags Make repository" + } + } else { + + # Normal test + set dg-do-what-default compile + dg-test -keep-output $test $flags "-I." + } + + # Clean up + catch { file delete "$bname.h" } + catch { file delete "$bname.h.cinfo" } + catch { file delete "$bname.o" } + catch { file delete "$bname.h.o" } + } +} + +set dg-do-what-default "$old_dg_do_what_default" + +# All done. +dg-finish diff --git a/gcc/testsuite/gcc.dg/torture/builtin-convert-1.c b/gcc/testsuite/gcc.dg/torture/builtin-convert-1.c new file mode 100644 index 00000000000..ac671590d20 --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/builtin-convert-1.c @@ -0,0 +1,138 @@ +/* Copyright (C) 2004 Free Software Foundation. + + Verify that built-in math function conversion to smaller FP types + is correctly performed by the compiler. + + Written by Kaveh Ghazi, 2004-03-17. */ + +/* { dg-do link } */ +/* { dg-options "-ffast-math" } */ + +#include "../builtins-config.h" + +/* This check is necessary when converting to a C99 function. */ +#ifdef HAVE_C99_RUNTIME +#define C99CODE(CODE) (CODE) +#define MAYBEC99(CODE, C99) (CODE) +#else +#define C99CODE(CODE) 0 +#define MAYBEC99(CODE, C99) (!(C99) && (CODE)) +#endif + +#define PROTOTYPE1(FN) extern double FN(double); extern float FN##f(float); \ + extern long double FN##l(long double); + +void test(double d1, float f1, long double ld1) +{ + /* Test converting math builtins to narrower FP types based on a + narrowing cast on the outside of the call. MATHFN is the + function to test, and C99 is 0/1 depending on whether the + `double' version of MATHFN is a C99 function. The optimization + is only performed if the replacement function is actually + narrower in width, so check that first. */ +#define OUTER_CAST1(MATHFN, C99) \ + PROTOTYPE1 (MATHFN) \ + extern void link_failure_outer_##MATHFN##l_##MATHFN##_1(void); \ + extern void link_failure_outer_##MATHFN##l_##MATHFN##_2(void); \ + extern void link_failure_outer_##MATHFN##l_##MATHFN##f_1(void); \ + extern void link_failure_outer_##MATHFN##l_##MATHFN##f_2(void); \ + extern void link_failure_outer_##MATHFN##_##MATHFN##f_1(void); \ + extern void link_failure_outer_##MATHFN##_##MATHFN##f_2(void); \ + if (sizeof (long double) > sizeof (double) \ + && MAYBEC99 ((double) MATHFN##l((double)ld1) != MATHFN(ld1), C99)) \ + link_failure_outer_##MATHFN##l_##MATHFN##_1(); \ + if (sizeof (long double) > sizeof (double) \ + && MAYBEC99 ((double) MATHFN##l(d1) != MATHFN(d1), C99)) \ + link_failure_outer_##MATHFN##l_##MATHFN##_1(); \ + if (sizeof (long double) > sizeof (double) \ + && MAYBEC99 ((double) MATHFN##l(f1) != MATHFN(f1), C99)) \ + link_failure_outer_##MATHFN##l_##MATHFN##_2(); \ + if (sizeof (long double) > sizeof (float) \ + && C99CODE ((float) MATHFN##l((float) ld1) != MATHFN##f(ld1))) \ + link_failure_outer_##MATHFN##l_##MATHFN##f_1(); \ + if (sizeof (long double) > sizeof (float) \ + && C99CODE ((float) MATHFN##l((float) d1) != MATHFN##f(d1))) \ + link_failure_outer_##MATHFN##l_##MATHFN##f_1(); \ + if (sizeof (long double) > sizeof (float) \ + && C99CODE ((float) MATHFN##l(f1) != MATHFN##f(f1))) \ + link_failure_outer_##MATHFN##l_##MATHFN##f_2(); \ + if (sizeof (double) > sizeof (float) \ + && C99CODE ((float) MATHFN((float) ld1) != MATHFN##f(ld1))) \ + link_failure_outer_##MATHFN##_##MATHFN##f_1(); \ + if (sizeof (double) > sizeof (float) \ + && C99CODE ((float) MATHFN((float) d1) != MATHFN##f(d1))) \ + link_failure_outer_##MATHFN##_##MATHFN##f_1(); \ + if (sizeof (double) > sizeof (float) \ + && C99CODE ((float) MATHFN(f1) != MATHFN##f(f1))) \ + link_failure_outer_##MATHFN##_##MATHFN##f_2() + + /* Test converting math builtins to narrower FP types based on if + the argument is a narrower type (perhaps implicitly) cast to a + wider one. */ +#define INNER_CAST1(MATHFN, C99) \ + PROTOTYPE1 (MATHFN) \ + extern void link_failure_inner_##MATHFN##l_##MATHFN(void); \ + extern void link_failure_inner_##MATHFN##l_##MATHFN##f(void); \ + extern void link_failure_inner_##MATHFN##_##MATHFN##f(void); \ + if (sizeof (long double) > sizeof (double) \ + && MAYBEC99 (MATHFN##l(d1) != (long double) MATHFN(d1), C99)) \ + link_failure_inner_##MATHFN##l_##MATHFN(); \ + if (sizeof (long double) > sizeof (float) \ + && C99CODE (MATHFN##l(f1) != (long double) MATHFN##f(f1))) \ + link_failure_inner_##MATHFN##l_##MATHFN##f(); \ + if (sizeof (long double) > sizeof (float) \ + && C99CODE (MATHFN##l((double)f1) != (long double) MATHFN##f(f1))) \ + link_failure_inner_##MATHFN##l_##MATHFN##f(); \ + if (sizeof (double) > sizeof (float) \ + && C99CODE (MATHFN(f1) != (double) MATHFN##f(f1))) \ + link_failure_inner_##MATHFN##_##MATHFN##f() + + +#ifdef __OPTIMIZE__ + OUTER_CAST1 (acos, /*C99=*/ 0); + OUTER_CAST1 (acosh, /*C99=*/ 1); + OUTER_CAST1 (asin, /*C99=*/ 1); + OUTER_CAST1 (asinh, /*C99=*/ 1); + OUTER_CAST1 (atan, /*C99=*/ 0); + OUTER_CAST1 (atanh, /*C99=*/ 1); + OUTER_CAST1 (cbrt, /*C99=*/ 1); + OUTER_CAST1 (cos, /*C99=*/ 0); + OUTER_CAST1 (cosh, /*C99=*/ 0); + OUTER_CAST1 (erf, /*C99=*/ 1); + OUTER_CAST1 (erfc, /*C99=*/ 1); + OUTER_CAST1 (exp, /*C99=*/ 0); + OUTER_CAST1 (exp2, /*C99=*/ 1); + OUTER_CAST1 (expm1, /*C99=*/ 1); + OUTER_CAST1 (fabs, /*C99=*/ 0); + OUTER_CAST1 (lgamma, /*C99=*/ 1); + OUTER_CAST1 (log, /*C99=*/ 0); + OUTER_CAST1 (log10, /*C99=*/ 0); + OUTER_CAST1 (log1p, /*C99=*/ 1); + OUTER_CAST1 (log2, /*C99=*/ 1); + OUTER_CAST1 (logb, /*C99=*/ 1); + OUTER_CAST1 (sin, /*C99=*/ 0); + OUTER_CAST1 (sinh, /*C99=*/ 0); + OUTER_CAST1 (sqrt, /*C99=*/ 0); + OUTER_CAST1 (tan, /*C99=*/ 0); + OUTER_CAST1 (tanh, /*C99=*/ 0); + OUTER_CAST1 (tgamma, /*C99=*/ 1); + + INNER_CAST1 (ceil, /*C99=*/ 0); + OUTER_CAST1 (ceil, /*C99=*/ 0); + INNER_CAST1 (floor, /*C99=*/ 0); + OUTER_CAST1 (floor, /*C99=*/ 0); + INNER_CAST1 (nearbyint, /*C99=*/ 1); + OUTER_CAST1 (nearbyint, /*C99=*/ 1); + INNER_CAST1 (rint, /*C99=*/ 1); + OUTER_CAST1 (rint, /*C99=*/ 1); + INNER_CAST1 (round, /*C99=*/ 1); + OUTER_CAST1 (round, /*C99=*/ 1); + INNER_CAST1 (trunc, /*C99=*/ 1); + OUTER_CAST1 (trunc, /*C99=*/ 1); +#endif /* __OPTIMIZE__ */ +} + +int main (void) +{ + return 0; +} diff --git a/gcc/testsuite/gcc.dg/torture/builtin-ctype-1.c b/gcc/testsuite/gcc.dg/torture/builtin-ctype-1.c new file mode 100644 index 00000000000..ad6fc1c60b6 --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/builtin-ctype-1.c @@ -0,0 +1,44 @@ +/* Copyright (C) 2004 Free Software Foundation. + + Verify that built-in ctype function attributes are correctly set by + the compiler. + + Written by Kaveh Ghazi, 2004-03-23. */ + +/* { dg-do link } */ + + +void test(int i) +{ + /* All of these ctype functions should be const/pure and thus + eliminated. */ +#define TEST_CTYPE(FN) \ + extern int FN(int); \ + extern void link_failure_##FN(void); \ + if (FN(i) != FN(i)) \ + link_failure_##FN() + +#ifdef __OPTIMIZE__ + TEST_CTYPE(isalnum); + TEST_CTYPE(isalpha); + TEST_CTYPE(isascii); + TEST_CTYPE(isblank); + TEST_CTYPE(iscntrl); + TEST_CTYPE(isdigit); + TEST_CTYPE(isgraph); + TEST_CTYPE(islower); + TEST_CTYPE(isprint); + TEST_CTYPE(ispunct); + TEST_CTYPE(isspace); + TEST_CTYPE(isupper); + TEST_CTYPE(isxdigit); + TEST_CTYPE(toascii); + TEST_CTYPE(tolower); + TEST_CTYPE(toupper); +#endif /* __OPTIMIZE__ */ +} + +int main (void) +{ + return 0; +} diff --git a/gcc/testsuite/gcc.dg/torture/builtin-ctype-2.c b/gcc/testsuite/gcc.dg/torture/builtin-ctype-2.c new file mode 100644 index 00000000000..7046aad6562 --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/builtin-ctype-2.c @@ -0,0 +1,107 @@ +/* Copyright (C) 2004 Free Software Foundation. + + Verify that built-in ctype transformations are done correctly by + the compiler. + + Written by Kaveh Ghazi, 2004-04-05. */ + +/* { dg-do link } */ + +extern void link_failure_var(void); + +void test(int i) +{ + /* All of these ctype calls should compile-time evaluate to true. */ +#define TEST_CTYPE_CST_TRUE(FN, VALUE) \ + extern void link_failure_##FN##_cst_true(void); \ + extern int FN(int); \ + if (! FN(VALUE)) \ + link_failure_##FN##_cst_true() + + /* All of these ctype calls should compile-time evaluate to false. */ +#define TEST_CTYPE_CST_FALSE(FN, VALUE) \ + extern void link_failure_##FN##_cst_false(void); \ + extern int FN(int); \ + if (FN(VALUE)) \ + link_failure_##FN##_cst_false() + + /* All of these ctype calls should compile-time evaluate to true. */ +#define TEST_TOCTYPE_CST_TRUE(FN, VALUE) \ + extern void link_failure_##FN##_cst_true(void); \ + extern int FN(int); \ + if (FN(VALUE) != (VALUE)) \ + link_failure_##FN##_cst_true() + + /* All of these ctype calls should compile-time evaluate to false. */ +#define TEST_TOCTYPE_CST_FALSE(FN, VALUE) \ + extern void link_failure_##FN##_cst_false(void); \ + extern int FN(int); \ + if (FN(VALUE) == (VALUE)) \ + link_failure_##FN##_cst_false() + +#ifdef __OPTIMIZE__ + TEST_CTYPE_CST_TRUE (isascii, 0); + TEST_CTYPE_CST_TRUE (isascii, 1); + TEST_CTYPE_CST_TRUE (isascii, 126); + TEST_CTYPE_CST_TRUE (isascii, 127); + + TEST_CTYPE_CST_FALSE (isascii, -1); + TEST_CTYPE_CST_FALSE (isascii, 128); + TEST_CTYPE_CST_FALSE (isascii, 129); + TEST_CTYPE_CST_FALSE (isascii, 255); + TEST_CTYPE_CST_FALSE (isascii, 256); + TEST_CTYPE_CST_FALSE (isascii, 257); + TEST_CTYPE_CST_FALSE (isascii, 10000); + TEST_CTYPE_CST_FALSE (isascii, __INT_MAX__); + + /* This ctype call should transform into another expression. */ + if (isascii(i) != ((i & ~0x7f) == 0)) + link_failure_var(); + + TEST_TOCTYPE_CST_TRUE (toascii, 0); + TEST_TOCTYPE_CST_TRUE (toascii, 1); + TEST_TOCTYPE_CST_TRUE (toascii, 126); + TEST_TOCTYPE_CST_TRUE (toascii, 127); + + TEST_TOCTYPE_CST_FALSE (toascii, -1); + TEST_TOCTYPE_CST_FALSE (toascii, 128); + TEST_TOCTYPE_CST_FALSE (toascii, 129); + TEST_TOCTYPE_CST_FALSE (toascii, 255); + TEST_TOCTYPE_CST_FALSE (toascii, 256); + TEST_TOCTYPE_CST_FALSE (toascii, 10000); + TEST_TOCTYPE_CST_FALSE (toascii, __INT_MAX__); + + /* This ctype call should transform into another expression. */ + if (toascii(i) != (i & 0x7f)) + link_failure_var(); + + TEST_CTYPE_CST_TRUE (isdigit, '0'); + TEST_CTYPE_CST_TRUE (isdigit, '1'); + TEST_CTYPE_CST_TRUE (isdigit, '2'); + TEST_CTYPE_CST_TRUE (isdigit, '3'); + TEST_CTYPE_CST_TRUE (isdigit, '4'); + TEST_CTYPE_CST_TRUE (isdigit, '5'); + TEST_CTYPE_CST_TRUE (isdigit, '6'); + TEST_CTYPE_CST_TRUE (isdigit, '7'); + TEST_CTYPE_CST_TRUE (isdigit, '8'); + TEST_CTYPE_CST_TRUE (isdigit, '9'); + + TEST_CTYPE_CST_FALSE (isdigit, '0'-1); + TEST_CTYPE_CST_FALSE (isdigit, '9'+1); + TEST_CTYPE_CST_FALSE (isdigit, -1); + TEST_CTYPE_CST_FALSE (isdigit, 0); + TEST_CTYPE_CST_FALSE (isdigit, 255); + TEST_CTYPE_CST_FALSE (isdigit, 256); + TEST_CTYPE_CST_FALSE (isdigit, 10000); + TEST_CTYPE_CST_FALSE (isdigit, __INT_MAX__); + + /* This ctype call should transform into another expression. */ + if (isdigit(i) != ((unsigned)i - '0' <= 9)) + link_failure_var(); +#endif /* __OPTIMIZE__ */ +} + +int main (void) +{ + return 0; +} diff --git a/gcc/testsuite/gcc.dg/torture/builtin-power-1.c b/gcc/testsuite/gcc.dg/torture/builtin-power-1.c new file mode 100644 index 00000000000..45566118a81 --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/builtin-power-1.c @@ -0,0 +1,105 @@ +/* Copyright (C) 2004 Free Software Foundation. + + Verify that built-in folding of various math "power" functions is + correctly performed by the compiler. + + Written by Kaveh Ghazi, 2004-03-11. */ + +/* { dg-do link } */ +/* { dg-options "-ffast-math" } */ + +#include "../builtins-config.h" + +#ifdef HAVE_C99_RUNTIME +#define C99CODE(CODE) CODE +#else +#define C99CODE(CODE) 0 +#endif + +#define PROTOTYPE(FN) extern double FN(double); extern float FN##f(float); \ + extern long double FN##l(long double); +#define PROTOTYPE2(FN) extern double FN(double, double); \ + extern float FN##f(float, float); \ + extern long double FN##l(long double, long double); + +PROTOTYPE(sqrt) +PROTOTYPE(cbrt) +PROTOTYPE2(pow) + +void test(double d1, double d2, double d3, + float f1, float f2, float f3, + long double ld1, long double ld2, long double ld3) +{ + /* Test N1root(N2root(x)) -> pow(x,1/(N1*N2)). */ + /* E.g. sqrt(cbrt(x)) -> pow(x,1/6). */ +#define ROOT_ROOT(FN1,N1,FN2,N2) \ + extern void link_failure_##FN1##_##FN2(void); \ + if (FN1(FN2(d1)) != pow(d1,1.0/(N1*N2)) \ + || C99CODE (FN1##f(FN2##f(f1)) != powf(f1,1.0F/(N1*N2))) \ + || C99CODE (FN1##l(FN2##l(ld1)) != powl(ld1,1.0L/(N1*N2)))) \ + link_failure_##FN1##_##FN2() + + ROOT_ROOT(sqrt,2,sqrt,2); + ROOT_ROOT(sqrt,2,cbrt,3); + ROOT_ROOT(cbrt,3,sqrt,2); + /*ROOT_ROOT(cbrt,3,cbrt,3); Intentionally not implemented. */ + + /* Test pow(Nroot(x),y) -> pow(x,y/N). */ +#define POW_ROOT(FN,N) \ + extern void link_failure_pow_##FN(void); \ + if (pow(FN(d1), d2) != pow(d1,d2/N) \ + || powf(FN##f(f1),f2) != powf(f1,f2/N) \ + || powl(FN##l(ld1),ld2) != powl(ld1,ld2/N)) \ + link_failure_pow_##FN() + + POW_ROOT(sqrt,2); + /*POW_ROOT(cbrt,3); Intentionally not implemented. */ + + /* Test Nroot(pow(x,y)) -> pow(x,y/N). */ +#define ROOT_POW(FN,N) \ + extern void link_failure_##FN##_pow(void); \ + if (FN(pow(d1, d2)) != pow(d1,d2/N) \ + || FN##f(powf(f1,f2)) != powf(f1,f2/N) \ + || FN##l(powl(ld1,ld2)) != powl(ld1,ld2/N)) \ + link_failure_##FN##_pow() + + ROOT_POW(sqrt,2); + /*ROOT_POW(cbrt,3); Intentionally not implemented. */ + + /* Test pow(pow(x,y),z) -> pow(x,y*z). */ +#define POW_POW \ + extern void link_failure_pow_pow(void); \ + if (pow(pow(d1, d2), d3) != pow(d1,d2*d3) \ + || powf(powf(f1,f2),f3) != powf(f1,f2*f3) \ + || powl(powl(ld1,ld2),ld3) != powl(ld1,ld2*ld3)) \ + link_failure_pow_pow() + + POW_POW; + + /* Test Nroot(x)*Nroot(y) -> Nroot(x*y). */ +#define ROOT_X_ROOT(FN) \ + extern void link_failure_root_x_root(void); \ + if (FN(d1)*FN(d2) != FN(d1*d2) \ + || FN##f(f1)*FN##f(f2) != FN##f(f1*f2) \ + || FN##l(ld1)*FN##l(ld2) != FN##l(ld1*ld2)) \ + link_failure_root_x_root() + + ROOT_X_ROOT(sqrt); + ROOT_X_ROOT(cbrt); + + /* Test pow(x,y)*pow(x,z) -> pow(x,y+z). */ +#define POW_X_POW \ + extern void link_failure_pow_x_pow(void); \ + if (pow(d1,d2)*pow(d1,d3) != pow(d1,d2+d3) \ + || powf(f1,f2)*powf(f1,f3) != powf(f1,f2+f3) \ + || powl(ld1,ld2)*powl(ld1,ld3) != powl(ld1,ld2+ld3)) \ + link_failure_pow_x_pow() + + POW_X_POW; + +} + +int main (void) +{ + return 0; +} diff --git a/gcc/testsuite/gcc.dg/torture/builtin-wctype-1.c b/gcc/testsuite/gcc.dg/torture/builtin-wctype-1.c new file mode 100644 index 00000000000..b8338de0bd1 --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/builtin-wctype-1.c @@ -0,0 +1,42 @@ +/* Copyright (C) 2004 Free Software Foundation. + + Verify that built-in wctype function attributes are correctly set + by the compiler. + + Written by Kaveh Ghazi, 2004-03-25. */ + +/* { dg-do link } */ + + +void test(int i) +{ + /* All of these ctype functions should be const/pure and thus + eliminated. */ +#define TEST_CTYPE(FN) \ + extern int FN(int); \ + extern void link_failure_##FN(void); \ + if (FN(i) != FN(i)) \ + link_failure_##FN() + +#ifdef __OPTIMIZE__ + TEST_CTYPE(iswalnum); + TEST_CTYPE(iswalpha); + TEST_CTYPE(iswblank); + TEST_CTYPE(iswcntrl); + TEST_CTYPE(iswdigit); + TEST_CTYPE(iswgraph); + TEST_CTYPE(iswlower); + TEST_CTYPE(iswprint); + TEST_CTYPE(iswpunct); + TEST_CTYPE(iswspace); + TEST_CTYPE(iswupper); + TEST_CTYPE(iswxdigit); + TEST_CTYPE(towlower); + TEST_CTYPE(towupper); +#endif /* __OPTIMIZE__ */ +} + +int main (void) +{ + return 0; +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/20040216-1.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/20040216-1.c new file mode 100644 index 00000000000..f4ac534bcc7 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/20040216-1.c @@ -0,0 +1,26 @@ +/* Test dependence graph. */ + +/* { dg-do compile } */ +/* { dg-options "-O2 -fscalar-evolutions -ftree-ddg -c -fdump-tree-all" } */ + +#define N 16 +void bar(int *); +void foo() +{ + int i,j; + int A[N]; + int X[N]; + int Y[N]; + int Z[N]; + + for (i=2; i<9; i++) + { + X[i] = Y[i] + Z[i]; + A[i] = X[i-1] + 1; + } + + bar (A); +} + +/* Find 4 Dependence nodes */ +/* { dg-final { scan-tree-dump-times "Dependence Node" 4 "ddg"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-01.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-01.c new file mode 100644 index 00000000000..f293f9b8c37 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-01.c @@ -0,0 +1,35 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +int main(void) +{ + unsigned a; + int b; + int c; + + /* loop_1 runs exactly 4 times. */ + for (a = 22; a < 50; a+=1) + { + /* loop_2 runs exactly 6 times. On exit, the variable B is equal to 53. */ + for (b = 23; b < 50; b+=5) + { + ++a; + + /* loop_3 runs {{77, +, -7}_1, +, -1}_2 times. */ + for (c = a; c < 100; c++) + { + + } + } + } +} + +/* The analyzer has to detect the following evolution functions: + b -> {23, +, 5}_2 + a -> {{22, +, 7}_1, +, 1}_2 + c -> {{{23, +, 7}_1, +, 1}_2, +, 1}_3 +*/ +/* { dg-final { scan-tree-dump-times "nb_iterations 4" 1 "scev"} } */ +/* { dg-final { scan-tree-dump-times "nb_iterations 6" 1 "scev"} } */ + + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-02.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-02.c new file mode 100644 index 00000000000..4baecaceb1b --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-02.c @@ -0,0 +1,28 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +int main(void) +{ + int a; + int b; + int *c; + + /* The following loop runs exactly 3 times. */ + for (a = 11; a < 50; a++) + { + /* The following loop runs exactly 9 times. */ + for (b = 8; b < 50; b+=5) + { + c[a + 5] = 5; + c[b] = 6; + a+=2; + } + } +} + +/* The analyzer has to detect the following evolution functions: + b -> {8, +, 5}_2 + a -> {{11, +, 19}_1, +, 2}_2 +*/ +/* { dg-final { scan-tree-dump-times "nb_iterations 3" 1 "scev"} } */ +/* { dg-final { scan-tree-dump-times "nb_iterations 9" 1 "scev"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-03.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-03.c new file mode 100644 index 00000000000..9b681273c15 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-03.c @@ -0,0 +1,29 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-stats" } */ + + +int main(void) +{ + int a; + int b; + int *c; + + /* loop_1 runs exactly 5 times. */ + for (a = 11; a < 50; a++) + { + /* loop_2 runs exactly 7 times. */ + for (b = 8; b < 50; b+=5) + { + c[a++] = 5; + c[b++] = 6; + } + } +} + +/* The analyzer has to detect the following evolution functions: + b -> {8, +, 6}_2 + a -> {{11, +, 8}_1, +, 1}_2 +*/ +/* { dg-final { scan-tree-dump-times "nb_iterations 5" 1 "scev"} } */ +/* { dg-final { scan-tree-dump-times "nb_iterations 7" 1 "scev"} } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-04.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-04.c new file mode 100644 index 00000000000..99986cfdbc6 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-04.c @@ -0,0 +1,21 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -ftree-elim-checks -fdump-tree-scev-details -fdump-tree-elck-details -fdump-tree-optimized" } */ + +void remove_me (void); + +int main(void) +{ + int a; + int b = 22; + + /* loop_1 runs exactly 28 times. */ + for (a = 22; a < 50; a++) /* a -> {22, +, 1}_1 */ + { + if (a > b) /* This condition is always false. */ + remove_me (); + b = b + 2; /* b -> {22, +, 2}_1 */ + } +} + +/* { dg-final { scan-tree-dump-times "nb_iterations 28" 1 "scev"} } */ +/* { dg-final { scan-tree-dump-times "remove_me" 0 "optimized"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-05.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-05.c new file mode 100644 index 00000000000..cb02875e674 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-05.c @@ -0,0 +1,32 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main(void) +{ + int a; + int b; + int c; + + /* nb_iterations 28 */ + for (a = 22; a < 50; a++) + { + /* nb_iterations 6 */ + for (b = 23; b < 50; b+=5) + { + /* nb_iterations {78, +, -1}_1 */ + for (c = a; c < 100; c++) + { + + } + } + } +} + +/* The analyzer has to detect the following evolution functions: + a -> {22, +, 1}_1 + b -> {23, +, 5}_2 + c -> {{22, +, 1}_1, +, 1}_3 +*/ +/* { dg-final { scan-tree-dump-times "nb_iterations 28" 1 "scev"} } */ +/* { dg-final { scan-tree-dump-times "nb_iterations 6" 1 "scev"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-06.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-06.c new file mode 100644 index 00000000000..7d720c94f2b --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-06.c @@ -0,0 +1,50 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -ftree-elim-checks -fdump-tree-scev-details -fdump-tree-optimized" } */ + +void remove_me (void); + +int main(void) +{ + int a; + int b; + int c; + + /* loop_1 runs 2 times. */ + for (a = 22; a < 83; a+=1) /* a -> {22, +, 60}_1 */ + { + c = a; + + /* loop_2 runs exactly 6 times. */ + for (b = 23; b < 50; b+=5) /* b -> {23, +, 5}_2 */ + { + ++a; + } + /* The following stmt exercises the value of B on the exit of the loop. + In this case the value of B out of the loop is that of the evolution + function of B applied to the number of iterations the inner loop_2 runs. + Value (B) = {23, +, 5}_2 (6) = 53. */ + + /* At this point, the variable A has the evolution function: + {{22, +, 6}_1, +, 1}_2. */ + if (b != 53 + || a != c + 6) + remove_me (); + + a = a + b; + /* At this point, the variable A has the evolution function: + {{22, +, 59}_1, +, 1}_2. The evolution of the variable B in + the loop_2 does not matter, and is not recorded in the + evolution of A. The above statement is equivalent to: + "a = a + 53", ie. the scalar value of B on exit of the loop_2. */ + + if (a != c + 59) + remove_me (); + + /* And finally the a+=1 from the FOR_STMT produces the evolution + function: {{22, +, 60}_1, +, 1}_2. */ + } +} + +/* { dg-final { scan-tree-dump-times "nb_iterations 2" 1 "scev"} } */ +/* { dg-final { scan-tree-dump-times "nb_iterations 6" 1 "scev"} } */ +/* { dg-final { scan-tree-dump-times "remove_me" 0 "optimized"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-07.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-07.c new file mode 100644 index 00000000000..8cc619a6f47 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-07.c @@ -0,0 +1,27 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -ftree-elim-checks -fdump-tree-optimized" } */ + +void remove_me (void); + +int main(void) +{ + int a = -100; + int b = 2; + int d = -1; + int e = -100; + + while (a) + { + /* Exercises higher order polynomials. */ + a = a + b; /* a -> {-100, +, {2, +, 3}_1}_1 */ + b = b + 3; /* b -> {2, +, 3}_1 */ + + d = d + 3; /* d -> {-1, +, 3}_1 */ + e = e + d; /* e -> {-100, +, {2, +, 3}_1}_1 */ + + if (a != e) /* a -> {-98, +, {5, +, 3}_1}_1 */ + remove_me (); + } +} + +/* { dg-final { scan-tree-dump-times "remove_me" 0 "optimized"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-08.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-08.c new file mode 100644 index 00000000000..3d6eb7ba3b2 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-08.c @@ -0,0 +1,31 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -ftree-elim-checks -fdump-tree-optimized" } */ + +void remove_me (void); + +int main(void) +{ + int a = -100; + int b = 2; + int c = 3; + int d = -5; + int e = 3; + int f = -100; + + while (a) + { + /* Exercises higher order polynomials. */ + a = a + b; /* a -> {-100, +, 2, +, 3, +, 4}_1 */ + b = b + c; /* b -> {2, +, 3, +, 4}_1 */ + c = c + 4; /* c -> {3, +, 4}_1 */ + + d = d + 4; /* d -> {-5, +, 4}_1 */ + e = e + d; /* e -> {3, +, -1, +, 4}_1 */ + f = f + e; /* f -> {-100, +, 2, +, 3, +, 4}_1 */ + + if (a != f) /* (a == f) -> {-98, +, 5, +, 7, +, 4}_1 */ + remove_me (); + } +} + +/* { dg-final { scan-tree-dump-times "remove_me" 0 "optimized"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-09.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-09.c new file mode 100644 index 00000000000..9964a6d30c2 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-09.c @@ -0,0 +1,41 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +int main(void) +{ + int a = -100; + int b = 2; + int c = 3; + int d = 4; + int e = 5; + + while (a) + { + /* Exercises the cycle detector: a -> b -> (c -> d -> e -> c)*. */ + a += b; + b += c; + c += d; + d += e; + e += c; + } +} + +/* This is what is commonly called a "mixer". It whirls the data in a + strongly connected component. We expect the following evolution + functions: + + e -> {5, +, c_13}_1 + d -> {4, +, {5, +, c_13}_1}_1 + c -> {3, +, {4, +, {5, +, c_13}_1}_1}_1 + b -> {2, +, {3, +, {4, +, {5, +, c_13}_1}_1}_1}_1 + a -> {-100, +, {2, +, {3, +, {4, +, {5, +, c_13}_1}_1}_1}_1}_1 +*/ + +/* FIXME: + For the moment this testcase does not test for anything, but for + not ICEing, and for documentation purposes (okay here is the + definition of a mixer). However, I'm considering testing something + around the lines of ssa-chrec-08.c, ie. build two mixers, and then + compare their values. But that is difficult, and low priority. */ + + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-10.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-10.c new file mode 100644 index 00000000000..649dfb0b2d8 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-10.c @@ -0,0 +1,30 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev -fall-data-deps -fdump-tree-ddall" } */ + +void bar (int); + +int foo (void) +{ + int a; + int x; + int c[100][100]; + + /* loop_1 runs 39 times. */ + for (a = 11; a < 50; a++) + { + /* Array access functions have to be analyzed. */ + x = a + 5; + c[x][a+1] = c[x+2][a+3] + c[x-1][a+2]; + } + bar (c[1][2]); +} + +/* The analyzer has to detect the scalar functions: + a -> {11, +, 1}_1 + x -> {16, +, 1}_1 + x+2 -> {18, +, 1}_1 + x-1 -> {15, +, 1}_1 +*/ + +/* { dg-final { scan-tree-dump-times "nb_iterations 39" 1 "scev"} } */ +/* { dg-final { diff-tree-dumps "ddall" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-10.c.ddall b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-10.c.ddall new file mode 100644 index 00000000000..5bf0e92b185 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-10.c.ddall @@ -0,0 +1,215 @@ + +;; Function foo (foo) + + +(Data Dep (A = 0, B = 0): + (subscript 0: + access_fn_A: {14, +, 1}_1 + access_fn_B: {14, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {18, +, 1}_1 + access_fn_B: {18, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 0, B = 1): (no dependence) + +) +(Data Dep (A = 0, B = 2): + (subscript 0: + access_fn_A: {14, +, 1}_1 + access_fn_B: {12, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {2, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {18, +, 1}_1 + access_fn_B: {16, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {2, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(2 +) +(2 +) + ) + (Direction Vector: +(+) +(+) + ) + +) +(Data Dep (A = 0, B = 3): (no dependence) + +) +(Data Dep (A = 1, B = 0): (no dependence) + +) +(Data Dep (A = 1, B = 1): + (subscript 0: + access_fn_A: {13, +, 1}_1 + access_fn_B: {13, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {15, +, 1}_1 + access_fn_B: {15, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 1, B = 2): (no dependence) + +) +(Data Dep (A = 1, B = 3): (no dependence) + +) +(Data Dep (A = 2, B = 0): + (subscript 0: + access_fn_A: {12, +, 1}_1 + access_fn_B: {14, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {2, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {16, +, 1}_1 + access_fn_B: {18, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {2, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(-2 +) +(-2 +) + ) + (Direction Vector: +(-) +(-) + ) + +) +(Data Dep (A = 2, B = 1): (no dependence) + +) +(Data Dep (A = 2, B = 2): + (subscript 0: + access_fn_A: {12, +, 1}_1 + access_fn_B: {12, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {16, +, 1}_1 + access_fn_B: {16, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 2, B = 3): (no dependence) + +) +(Data Dep (A = 3, B = 0): (no dependence) + +) +(Data Dep (A = 3, B = 1): (no dependence) + +) +(Data Dep (A = 3, B = 2): (no dependence) + +) +(Data Dep (A = 3, B = 3): + (subscript 0: + access_fn_A: 2 + access_fn_B: 2 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: 1 + access_fn_B: 1 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-11.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-11.c new file mode 100644 index 00000000000..b68b3d5bf1f --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-11.c @@ -0,0 +1,59 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main(void) +{ + int a = -100; + int b = 2; + + int f = 6; + int g = 7; + int h = 8; + + /* Exercises complex loop exit conditions. + FIXME: This is a strange case where the compiler cc1 and the wrapper gcc + don't produce the same representation: + + (with gcc from command line) + + T.1_9 = f_2 | a_1; + if (T.1_9 == 0) + { + goto <UL47e0>; + } + + versus (with cc1 called from gdb): + + if (f_2 == 0) + { + if (a_1 == 0) + { + goto <ULc7e0>; + } + else + { + (void)0 + } + } + else + { + (void)0 + }; + */ + while (f || a) + { + a += b; + + f += g; + g += h; + } +} + +/* + g -> {7, +, 8}_1 + f -> {6, +, {7, +, 8}_1}_1 + a -> {-100, +, 2}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-12.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-12.c new file mode 100644 index 00000000000..ab43eaf0a1a --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-12.c @@ -0,0 +1,32 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int bar (void); + +int foo () +{ + int a = -100; + int b = 2; + int c = 3; + int d = 4; + + while (a) + { + a = a + b; + + /* Exercises if-phi-nodes. */ + if (bar ()) + b = b + c; + + c = c + d; + } +} + +/* The analyzer has to detect the following evolution functions: + c -> {3, +, 4}_1 + b -> {2, +, {[0, 3], +, [0, 4]}_1}_1 + a -> {-100, +, {2, +, {[0, 3], +, [0, 4]}_1}_1}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-13.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-13.c new file mode 100644 index 00000000000..37fba692f27 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-13.c @@ -0,0 +1,32 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +int foo (void); + +int main (void) +{ + int a = -100; + int b = 2; + int c = 3; + + while (a) + { + /* Exercises if-phi-nodes. */ + if (foo ()) + a += b; + else + a += c; + + b++; + c++; + } +} + +/* The analyzer has to detect the following evolution function: + a -> {-100, +, {[2, 3], +, 1}_1}_1 +*/ + +/* FIXME. */ + + + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-14.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-14.c new file mode 100644 index 00000000000..e541160ebb6 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-14.c @@ -0,0 +1,36 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +int foo (void); + +int main (void) +{ + int a = -100; + int b = 2; + int c = 3; + int d = 4; + + while (d) + { + if (foo ()) + a += b; + else + a += c; + + b += 1; + c += 5; + + /* Exercises the initial condition of A after the if-phi-node. */ + d = d + a; + } +} + +/* The analyzer has to detect the following evolution function: + b -> {2, +, 1}_1 + c -> {3, +, 5}_1 + a -> {-100, +, {[2, 3], +, [1, 5]}_1}_1 + d -> {4, +, {[-98, -97], +, {[2, 3], +, [1, 5]}_1}_1}_1 +*/ + +/* FIXME. */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-15.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-15.c new file mode 100644 index 00000000000..e56a7dd91b6 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-15.c @@ -0,0 +1,23 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main (void) +{ + int a; + int b; + int c; + + /* Exercises the MINUS_EXPR. loop_1 runs 50 times. */ + for (a = 100; a > 50; a--) + { + + } +} + +/* The analyzer has to detect the following evolution function: + a -> {100, +, -1}_1 +*/ + +/* { dg-final { scan-tree-dump-times "nb_iterations 50" 1 "scev"} } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-16.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-16.c new file mode 100644 index 00000000000..b2c26348dc0 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-16.c @@ -0,0 +1,26 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main (void) +{ + int a = -100; + int b = 2; + int c = 3; + int d = 4; + + /* Determining the number of iterations for the != or == is work in + progress. Same for polynomials of degree >= 2, where we have to + find the zeros of the polynomial. */ + while (d) + { + a += 23; + d = a + d; + } +} + +/* a -> {-100, +, 23}_1 + d -> {4, +, {-77, +, 23}_1}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-17.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-17.c new file mode 100644 index 00000000000..9c624b08ca9 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-17.c @@ -0,0 +1,35 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int bar (void); + +void foo () +{ + int a = -100; + int b = 2; + + while (b) + { + if (bar ()) + a += 3; + else + a = 2; + + /* Exercises the case when one of the branches of the if-phi-node is a constant. + FIXME: + - What is the chrec representation of such an evolution? + - Does this kind of code exist in real codes? */ + b += a; + } +} + +/* For the moment the analyzer is expected to output a "don't know" answer, + both for the initial condition and for the evolution part. This is done + in the merge condition branches information. + + a -> [-oo, +oo] + b -> {2, +, a_1}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-18.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-18.c new file mode 100644 index 00000000000..73996eac447 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-18.c @@ -0,0 +1,31 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int bar (void); + +int foo (int x) +{ + int a = -100; + int b = 2; + + while (b) + { + if (x) + a += 3; + else + a += bar (); + + /* Exercises the case when one of the branches of the if-phi-node cannot + be determined: [-oo, +oo]. + Since the evolution function is too difficult to handle in the expanded + form, we have to keep it in its symbolic form: "b -> {2, +, a_1}_1". */ + b += a; + } +} + +/* a -> {-100, +, [min<t, 3>, max<t, 3>]}_1 + b -> {2, +, {[min<t, 3>, max<t, 3>] - 100, +, [min<t, 3>, max<t, 3>]}_1}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-19.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-19.c new file mode 100644 index 00000000000..47219680039 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-19.c @@ -0,0 +1,20 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main () +{ + int b = 2; + + while (b) + { + /* Exercises the MULT_EXPR. */ + b = 2*b; + } +} + +/* b -> {2, *, 2}_1 +*/ + +/* FIXME. */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-20.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-20.c new file mode 100644 index 00000000000..521f60efe52 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-20.c @@ -0,0 +1,29 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main () +{ + int a = 3; + int b = 2; + + while (a) + { + b += 5; + a += b; + + /* Exercises the sum of a polynomial of degree 2 with an + evolution of degree 1: + + (loop_num = 1, chrec_var = {3, +, 7, +, 5}, to_add = 2). + The result should be: {3, +, 9, +, 5}. */ + a += 2; + } +} + +/* + b -> {2, +, 5}_1 + a -> {3, +, {9, +, 5}_1}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-21.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-21.c new file mode 100644 index 00000000000..1f8d0e600d3 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-21.c @@ -0,0 +1,21 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main () +{ + int a = 3; + int b = 2; + + while (b) + { + a *= 4; + b *= a; + } +} + +/* a -> {3, *, 4}_1 + b -> {{2, *, 12}_1, *, 4}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-22.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-22.c new file mode 100644 index 00000000000..a6df37051d7 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-22.c @@ -0,0 +1,23 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main () +{ + int a = 2; + int b = 4; + + while (a) + { + a *= 3; + a *= b; + b *= 5; + } +} + +/* + b -> {4, *, 5}_1 + a -> {2, *, {12, *, 5}_1}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-23.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-23.c new file mode 100644 index 00000000000..2b67406b6a9 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-23.c @@ -0,0 +1,21 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main () +{ + int a = 1; + int b = 1; + + while (a) + { + a *= b; + b += 1; + } +} + +/* a -> {1, *, {1, +, 1}_1}_1 +*/ + +/* FIXME. */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-24.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-24.c new file mode 100644 index 00000000000..a81957e583d --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-24.c @@ -0,0 +1,29 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int bar (void); + +int foo () +{ + int c; + + /* This exercises the initial condition propagator: + Interval Copy Constant Propagation (ICCP). */ + if (bar ()) + c = 2; + else + c = 3; + + while (c) + { + c += 5; + } +} + +/* + c -> {[2, 3], +, 5}_1 +*/ + +/* FIXME. */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-25.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-25.c new file mode 100644 index 00000000000..5c535707cca --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-25.c @@ -0,0 +1,28 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int bar (void); + +int foo () +{ + int c = 7; + + /* This exercises the initial condition propagator: + Interval Copy Constant Propagation (ICCP). */ + if (bar ()) + c = 2; + else + c += 3; + + while (c) + { + c += 5; + } +} + +/* + c -> {[2, 10], +, 5}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-26.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-26.c new file mode 100644 index 00000000000..b9e08d45810 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-26.c @@ -0,0 +1,25 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int bar (void); + +int foo () +{ + int a = -100; + int b = -10; + + /* This exercises a code with two loop nests. */ + + while (a) + a++; + + while (b) + b++; +} + +/* a -> {-100, +, 1}_1 + b -> {-10, +, 1}_2 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-27.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-27.c new file mode 100644 index 00000000000..c699bc6ac80 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-27.c @@ -0,0 +1,40 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int bar (void); + +int foo () +{ + int a = -100; + + /* This exercises a code with two loop nests. */ + + /* loop_1 runs 100 times. */ + while (a < 0) + a++; + + a -= 77; + + /* loop_2 runs 26 times. */ + while (a < 0) + a+=3; +} + +/* The analyzer sees two loop nests: + for the first, it determines the evolution: + a -> {-100, +, 1}_1 + + and for the second, it determines that the first loop ends at 0 and then: + a -> {-77, +, 3}_2 + + When the constant propagation is postponed, the analyzer detects + for the second loop the evolution function: + a -> {a_5, +, 3}_2 + +*/ + +/* { dg-final { scan-tree-dump-times "nb_iterations 100" 1 "scev"} } */ +/* { dg-final { scan-tree-dump-times "nb_iterations 26" 1 "scev"} } */ + + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-28.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-28.c new file mode 100644 index 00000000000..59702851d9a --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-28.c @@ -0,0 +1,39 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int bar (void); + +int foo () +{ + int i; + int a = 2; + + while (a) + { + a *= 3; + + for (i = 0; i < 100; i++) + a += 4; + } +} + +/* FIXME: We have to transform the evolution function of "a" into an infinite + sum, a -> {//2, *, 2//}, and then to add the 400 from the inner sum... + But this is quite difficult, and cases like this one do not happen often. + + (Francois Irigoin consider that this case falls into the 0.01 percent + rule, and it is no worth to implement a solution for this testcase in a + production compiler. ) +*/ + +/* Do nothing for this testcase. + The following evolutions are detected: + + i -> {0, +, 1}_2 + a -> {{2, *, [-oo, +oo]}_1, +, 4}_2 + +*/ + +/* FIXME. */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-29.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-29.c new file mode 100644 index 00000000000..716797361fe --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-29.c @@ -0,0 +1,40 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int bar (void); + +int foo () +{ + int i; + int a = 2; + + while (a) + { + a *= 3; + a += 5; + } +} + +/* FIXME: This exposes a problem in the representation. Is it + possible to have an exponential and a polynomial together? + + The first assignment constructs "a -> {2, *, 3}_1", + while the second adds 5 as a polynomial function. + + The following two representations are not correct: + "a -> {{2, *, 3}_1, +, 5}_1" + "a -> {{2, +, 5}_1, *, 3}_1" + + The right solution is: + "a -> {2, *, 3}_1 + {0, +, 5}_1" + but this exposes yet again the "exp + poly" problem: the representation + is not homogen. Going into a Taylor decomposition could solve this problem. + + This is too difficult for the moment, and does not happen often. +*/ + +/* Do nothing for this testcase. */ + +/* FIXME. */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-30.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-30.c new file mode 100644 index 00000000000..3a36c5173c0 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-30.c @@ -0,0 +1,21 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details -fall-data-deps -fdump-tree-ddall" } */ + +void foo (int); + +int main () +{ + int c[100][200]; + int a; + int x; + + for (a = 1; a < 50; a++) + { + x = a; + c[x-7][1] = c[x+2][3] + c[x-1][2]; + c[x][2] = c[x+2][3]; + } + foo (c[12][13]); +} + +/* { dg-final { diff-tree-dumps "ddall" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-30.c.ddall b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-30.c.ddall new file mode 100644 index 00000000000..1e9a201c189 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-30.c.ddall @@ -0,0 +1,383 @@ + +;; Function main (main) + + +(Data Dep (A = 0, B = 0): + (subscript 0: + access_fn_A: 3 + access_fn_B: 3 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {3, +, 1}_1 + access_fn_B: {3, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 0, B = 1): (no dependence) + +) +(Data Dep (A = 0, B = 2): (no dependence) + +) +(Data Dep (A = 0, B = 3): + (subscript 0: + access_fn_A: 3 + access_fn_B: 3 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {3, +, 1}_1 + access_fn_B: {3, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 0, B = 4): (no dependence) + +) +(Data Dep (A = 0, B = 5): (no dependence) + +) +(Data Dep (A = 1, B = 0): (no dependence) + +) +(Data Dep (A = 1, B = 1): + (subscript 0: + access_fn_A: 2 + access_fn_B: 2 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {0, +, 1}_1 + access_fn_B: {0, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 1, B = 2): (no dependence) + +) +(Data Dep (A = 1, B = 3): (no dependence) + +) +(Data Dep (A = 1, B = 4): + (subscript 0: + access_fn_A: 2 + access_fn_B: 2 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {0, +, 1}_1 + access_fn_B: {1, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {1, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(-1 +) + ) + (Direction Vector: +(=) +(-) + ) + +) +(Data Dep (A = 1, B = 5): (no dependence) + +) +(Data Dep (A = 2, B = 0): (no dependence) + +) +(Data Dep (A = 2, B = 1): (no dependence) + +) +(Data Dep (A = 2, B = 2): + (subscript 0: + access_fn_A: 1 + access_fn_B: 1 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {-6, +, 1}_1 + access_fn_B: {-6, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 2, B = 3): (no dependence) + +) +(Data Dep (A = 2, B = 4): (no dependence) + +) +(Data Dep (A = 2, B = 5): (no dependence) + +) +(Data Dep (A = 3, B = 0): + (subscript 0: + access_fn_A: 3 + access_fn_B: 3 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {3, +, 1}_1 + access_fn_B: {3, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 3, B = 1): (no dependence) + +) +(Data Dep (A = 3, B = 2): (no dependence) + +) +(Data Dep (A = 3, B = 3): + (subscript 0: + access_fn_A: 3 + access_fn_B: 3 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {3, +, 1}_1 + access_fn_B: {3, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 3, B = 4): (no dependence) + +) +(Data Dep (A = 3, B = 5): (no dependence) + +) +(Data Dep (A = 4, B = 0): (no dependence) + +) +(Data Dep (A = 4, B = 1): + (subscript 0: + access_fn_A: 2 + access_fn_B: 2 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {1, +, 1}_1 + access_fn_B: {0, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {1, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(1 +) + ) + (Direction Vector: +(=) +(+) + ) + +) +(Data Dep (A = 4, B = 2): (no dependence) + +) +(Data Dep (A = 4, B = 3): (no dependence) + +) +(Data Dep (A = 4, B = 4): + (subscript 0: + access_fn_A: 2 + access_fn_B: 2 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {1, +, 1}_1 + access_fn_B: {1, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 4, B = 5): (no dependence) + +) +(Data Dep (A = 5, B = 0): (no dependence) + +) +(Data Dep (A = 5, B = 1): (no dependence) + +) +(Data Dep (A = 5, B = 2): (no dependence) + +) +(Data Dep (A = 5, B = 3): (no dependence) + +) +(Data Dep (A = 5, B = 4): (no dependence) + +) +(Data Dep (A = 5, B = 5): + (subscript 0: + access_fn_A: 13 + access_fn_B: 13 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: 12 + access_fn_B: 12 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-31.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-31.c new file mode 100644 index 00000000000..bb3f29cab3e --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-31.c @@ -0,0 +1,19 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details -fall-data-deps -fdump-tree-ddall" } */ + +void bar (short); + +#define N 100 +foo (){ + short a[N]; + short b[N]; + short c[N]; + int i; + + for (i=0; i<N; i++){ + a[i] = b[i] + c[i]; + } + bar (a[2]); +} + +/* { dg-final { diff-tree-dumps "ddall" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-31.c.ddall b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-31.c.ddall new file mode 100644 index 00000000000..6aaf0f386c2 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-31.c.ddall @@ -0,0 +1,143 @@ + +;; Function foo (foo) + + +(Data Dep (A = 0, B = 0): + (subscript 0: + access_fn_A: {0, +, 1}_1 + access_fn_B: {0, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) +(Data Dep (A = 0, B = 1): (no dependence) + +) +(Data Dep (A = 0, B = 2): (no dependence) + +) +(Data Dep (A = 0, B = 3): (no dependence) + +) +(Data Dep (A = 1, B = 0): (no dependence) + +) +(Data Dep (A = 1, B = 1): + (subscript 0: + access_fn_A: {0, +, 1}_1 + access_fn_B: {0, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) +(Data Dep (A = 1, B = 2): (no dependence) + +) +(Data Dep (A = 1, B = 3): (no dependence) + +) +(Data Dep (A = 2, B = 0): (no dependence) + +) +(Data Dep (A = 2, B = 1): (no dependence) + +) +(Data Dep (A = 2, B = 2): + (subscript 0: + access_fn_A: {0, +, 1}_1 + access_fn_B: {0, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) +(Data Dep (A = 2, B = 3): + (subscript 0: + access_fn_A: {0, +, 1}_1 + access_fn_B: 2 + iterations_that_access_an_element_twice_in_A: 2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(-2 +) + ) + (Direction Vector: +(-) + ) + +) +(Data Dep (A = 3, B = 0): (no dependence) + +) +(Data Dep (A = 3, B = 1): (no dependence) + +) +(Data Dep (A = 3, B = 2): + (subscript 0: + access_fn_A: 2 + access_fn_B: {0, +, 1}_1 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(2 +) + ) + (Direction Vector: +(+) + ) + +) +(Data Dep (A = 3, B = 3): + (subscript 0: + access_fn_A: 2 + access_fn_B: 2 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-32.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-32.c new file mode 100644 index 00000000000..784caef3270 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-32.c @@ -0,0 +1,35 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details -fall-data-deps -fdump-tree-ddall" } */ + +void bar (short); + +#define N 100 +#define NPad 10 +#define M 32 +void foo() +{ + short coef[M]; + short input[N]; + short output[N]; + + int i,j,k; + int sum; + + for (i = 0; i < N; i++) { + sum = 0; + for (j = 0; j < M; j++) { + sum += input[i+NPad-j] * coef[j]; + } + output[i] = sum; + } + bar (sum); +} + +/* The following evolution functions have to be detected: + + i -> {0, +, 1}_1 + j -> {0, +, 1}_2 + +*/ + +/* { dg-final { diff-tree-dumps "ddall" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-32.c.ddall b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-32.c.ddall new file mode 100644 index 00000000000..2929ec3271a --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-32.c.ddall @@ -0,0 +1,47 @@ + +;; Function foo (foo) + + +(Data Dep (A = 0, B = 0): + (subscript 0: + access_fn_A: {{10, +, 1}_1, +, -1}_2 + access_fn_B: {{10, +, 1}_1, +, -1}_2 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) +(Data Dep (A = 0, B = 1): (no dependence) + +) +(Data Dep (A = 1, B = 0): (no dependence) + +) +(Data Dep (A = 1, B = 1): + (subscript 0: + access_fn_A: {0, +, 1}_2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-33.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-33.c new file mode 100644 index 00000000000..a2a24a7e4e3 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-33.c @@ -0,0 +1,46 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details -fall-data-deps -fdump-tree-ddall" } */ + +void bar (int); + +#define N 100 +#define NPad 10 +#define M 32 + +void foo () +{ + short coefs[2*M]; + short input[2*N]; + short output[2*N]; + + int sum_real, sum_imag; + int i,j,k; + + k = NPad; + for (i = 0; i < N; i++) + { + sum_real = 0; + sum_imag = 0; + for (j = 0; j < M; j++) + { + sum_real += + input[2*k-2*j+1]*coefs[2*j+1] - input[2*k-2*j]*coefs[2*j]; + + sum_imag += + input[2*k-2*j]*coefs[2*j+1] + input[2*k-2*j+1]*coefs[2*j]; + } + output[2*i+1] = sum_imag; + output[2*i] = sum_real; + k++; + } + bar (sum_imag); +} + +/* The following evolution functions have to be detected: + + i -> {0, +, 1}_1 + j -> {0, +, 1}_2 + +*/ + +/* { dg-final { diff-tree-dumps "ddall" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-33.c.ddall b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-33.c.ddall new file mode 100644 index 00000000000..1e9f1ee4002 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-33.c.ddall @@ -0,0 +1,113 @@ + +;; Function foo (foo) + + +(Data Dep (A = 0, B = 0): + (subscript 0: + access_fn_A: {{21, +, 2}_1, +, -2}_2 + access_fn_B: {{21, +, 2}_1, +, -2}_2 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) +(Data Dep (A = 0, B = 1): (no dependence) + +) +(Data Dep (A = 0, B = 2): (no dependence) + +) +(Data Dep (A = 0, B = 3): (no dependence) + +) +(Data Dep (A = 1, B = 0): (no dependence) + +) +(Data Dep (A = 1, B = 1): + (subscript 0: + access_fn_A: {1, +, 2}_2 + access_fn_B: {1, +, 2}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) +(Data Dep (A = 1, B = 2): (no dependence) + +) +(Data Dep (A = 1, B = 3): (no dependence) + +) +(Data Dep (A = 2, B = 0): (no dependence) + +) +(Data Dep (A = 2, B = 1): (no dependence) + +) +(Data Dep (A = 2, B = 2): + (subscript 0: + access_fn_A: {{20, +, 2}_1, +, -2}_2 + access_fn_B: {{20, +, 2}_1, +, -2}_2 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) +(Data Dep (A = 2, B = 3): (no dependence) + +) +(Data Dep (A = 3, B = 0): (no dependence) + +) +(Data Dep (A = 3, B = 1): (no dependence) + +) +(Data Dep (A = 3, B = 2): (no dependence) + +) +(Data Dep (A = 3, B = 3): + (subscript 0: + access_fn_A: {0, +, 2}_2 + access_fn_B: {0, +, 2}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-34.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-34.c new file mode 100644 index 00000000000..1a5687a527b --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-34.c @@ -0,0 +1,33 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details -fall-data-deps -fdump-tree-ddall" } */ + +void bar (int); + +#define M 16 +#define N 8 + +short foo (short image[][M], short block[][N]){ + int sad, diff = 0; + int i, j; + int tmp; + + for (i = 0; i < N; i++) { + sad = 0; + for (j = 0; j < N; j++) { + tmp = image[i][j] - block[i][j]; + sad += (tmp < 0) ? -tmp : tmp; + } + diff += sad; + } + + return diff; +} + +/* The following evolution functions have to be detected: + + i -> {0, +, 1}_1 + j -> {0, +, 1}_2 + +*/ + +/* { dg-final { diff-tree-dumps "ddall" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-34.c.ddall b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-34.c.ddall new file mode 100644 index 00000000000..9f3d13edc91 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-34.c.ddall @@ -0,0 +1,47 @@ + +;; Function foo (foo) + + +(Data Dep (A = 0, B = 0): + (subscript 0: + access_fn_A: {0, +, 1}_2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) +(Data Dep (A = 0, B = 1): (no dependence) + +) +(Data Dep (A = 1, B = 0): (no dependence) + +) +(Data Dep (A = 1, B = 1): + (subscript 0: + access_fn_A: {0, +, 1}_2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-35.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-35.c new file mode 100644 index 00000000000..f33f28b397a --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-35.c @@ -0,0 +1,34 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details -fall-data-deps -fdump-tree-ddall" } */ + +#define L 100 +#define M 100 +#define N 100 + +int bar (float); + +int foo (float A[][M][N]) +{ + int i, j, k; + + for (i = 0; i < L; i++) + for (j = 0; j < M; j++) + for (k = 0; k < N; k++) + A[i][j][j] = A[i][j][k]; + + return bar (A[10][11][12]); +} + +/* The following evolution functions have to be detected: + + i -> {0, +, 1}_1 + j -> {0, +, 1}_2 + k -> {0, +, 1}_3 + + For the subscript [j] vs. [k], "{0, +, 1}_2" vs. "{0, +, 1}_3" + the overlapping elements are respectively located at iterations: + {0, +, 1}_3 and {0, +, 1}_2. + +*/ + +/* { dg-final { diff-tree-dumps "ddall" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-35.c.ddall b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-35.c.ddall new file mode 100644 index 00000000000..858b925f649 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-35.c.ddall @@ -0,0 +1,167 @@ + +;; Function foo (foo) + + +(Data Dep (A = 0, B = 0): + (subscript 0: + access_fn_A: {0, +, 1}_3 + access_fn_B: {0, +, 1}_3 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_3 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_3 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {0, +, 1}_2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 0, B = 1): + (subscript 0: + access_fn_A: {0, +, 1}_3 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_3 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {0, +, 1}_2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +([-oo, +oo] +) +(0 +) + ) + (Direction Vector: +(*) +(=) + ) + +) +(Data Dep (A = 0, B = 2): (no dependence) + +) +(Data Dep (A = 1, B = 0): + (subscript 0: + access_fn_A: {0, +, 1}_2 + access_fn_B: {0, +, 1}_3 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_3 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {0, +, 1}_2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +([-oo, +oo] +) +(0 +) + ) + (Direction Vector: +(*) +(=) + ) + +) +(Data Dep (A = 1, B = 1): + (subscript 0: + access_fn_A: {0, +, 1}_2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {0, +, 1}_2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 1, B = 2): (no dependence) + +) +(Data Dep (A = 2, B = 0): (no dependence) + +) +(Data Dep (A = 2, B = 1): (no dependence) + +) +(Data Dep (A = 2, B = 2): + (subscript 0: + access_fn_A: 12 + access_fn_B: 12 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: 11 + access_fn_B: 11 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-36.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-36.c new file mode 100644 index 00000000000..916c81548c8 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-36.c @@ -0,0 +1,35 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details -fall-data-deps -fdump-tree-ddall" } */ + +int foo (int); + +int main () +{ + int res; + int c[100][200]; + int a; + int x; + + for (a = 1; a < 50; a++) + { + c[a+1][a] = 2; + res += c[a][a]; + + /* This case exercises the subscript coupling detection: the dependence + detectors have to determine that there is no dependence between + c[a+1][a] and c[a][a]. */ + } + + return res + foo (c[12][13]); +} + +/* This also exercises the case when, after a PRE, the loop phi node contains: + " # a_1 = PHI <1(0), T.1_11(1)>; + ... + T.1_11 = a_1 + 1;". + In fact this creates a cycle: a -> T.1 -> a. + The PRE has screwed up the case... + ...I really have to implement the mixers analyzers. */ + +/* { dg-final { diff-tree-dumps "ddall" } } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-36.c.ddall b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-36.c.ddall new file mode 100644 index 00000000000..ac9536852cd --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-36.c.ddall @@ -0,0 +1,221 @@ + +;; Function main (main) + + +(Data Dep (A = 0, B = 0): + (subscript 0: + access_fn_A: {1, +, 1}_1 + access_fn_B: {1, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {2, +, 1}_1 + access_fn_B: {2, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 0, B = 1): (no dependence) + +) +(Data Dep (A = 0, B = 2): + (subscript 0: + access_fn_A: {1, +, 1}_1 + access_fn_B: 13 + iterations_that_access_an_element_twice_in_A: 12 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {2, +, 1}_1 + access_fn_B: 12 + iterations_that_access_an_element_twice_in_A: 10 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(-12 +) +(-10 +) + ) + (Direction Vector: +(-) +(-) + ) + +) +(Data Dep (A = 1, B = 0): (no dependence) + +) +(Data Dep (A = 1, B = 1): + (subscript 0: + access_fn_A: {1, +, 1}_1 + access_fn_B: {1, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {1, +, 1}_1 + access_fn_B: {1, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 1, B = 2): + (subscript 0: + access_fn_A: {1, +, 1}_1 + access_fn_B: 13 + iterations_that_access_an_element_twice_in_A: 12 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {1, +, 1}_1 + access_fn_B: 12 + iterations_that_access_an_element_twice_in_A: 11 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(-12 +) +(-11 +) + ) + (Direction Vector: +(-) +(-) + ) + +) +(Data Dep (A = 2, B = 0): + (subscript 0: + access_fn_A: 13 + access_fn_B: {1, +, 1}_1 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 12 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: 12 + access_fn_B: {2, +, 1}_1 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 10 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(12 +) +(10 +) + ) + (Direction Vector: +(+) +(+) + ) + +) +(Data Dep (A = 2, B = 1): + (subscript 0: + access_fn_A: 13 + access_fn_B: {1, +, 1}_1 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 12 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: 12 + access_fn_B: {1, +, 1}_1 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 11 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(12 +) +(11 +) + ) + (Direction Vector: +(+) +(+) + ) + +) +(Data Dep (A = 2, B = 2): + (subscript 0: + access_fn_A: 13 + access_fn_B: 13 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: 12 + access_fn_B: 12 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-37.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-37.c new file mode 100644 index 00000000000..43653454dfd --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-37.c @@ -0,0 +1,29 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main () +{ + int a; + int b = 2; + int c = 11; + + for (a = -123; a < 0; c += 12, b += 5) + { + a += b; + + /* The next stmt exercises the add_function_to_loop_evolution + (loop_num = 1, chrec_before = {-123, +, {2, +, 5}_1}_1, to_add = {11, +, 12}_1). + The result should be: {-123, +, {13, +, 17}_1}_1. */ + a += c; + } +} + +/* + b -> {2, +, 5}_1 + c -> {11, +, 12}_1 + a -> {-123, +, {13, +, 17}_1}_1 +*/ + + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-38.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-38.c new file mode 100644 index 00000000000..3108ec24851 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-38.c @@ -0,0 +1,48 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main () +{ + int a = 3; + int b = 2; + int c = 11; + int d = -5; + + while (a) + { + b += 5; + a += b; + + for (d = -5; d < 0; d++) + { + /* Exercises the build_polynomial_evolution_in_loop function in the following context: + (add_to_evolution + loop_num = 2 + chrec_before = {3, +, 7, +, 5}_1 + to_add = {11, +, 12}_1 + res = {{3, +, 7, +, 5}_1, +, {11, +, 12}_1}_2 + ) + + This also exercises the chrec_apply function in the following context: + (chrec_apply + var = 2 + chrec = {0, +, {11, +, 12}_1}_2 + x = 5 + res = {55, +, 60}_1 + ) + */ + a += c; + } + c += 12; + } +} + +/* + b -> {2, +, 5}_1 + c -> {11, +, 12}_1 + d -> {-5, +, 1}_2 + a -> {{3, +, 62, +, 65}_1, +, {11, +, 12}_1}_2 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-39.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-39.c new file mode 100644 index 00000000000..8e1857277c1 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-39.c @@ -0,0 +1,45 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int foo (int ParmN) +{ + int a = 3; + int b = 2; + int d = -5; + + while (a) + { + b += 25; + a += b; + + for (d = -5; d < 0; d++) + { + /* Exercises the build_polynomial_evolution_in_loop in the following context: + (add_to_evolution + loop_num = 2 + chrec_before = {3, +, {27, +, 25}_1}_1 + to_add = ParmN_15 + res = {{3, +, {27, +, 25}_1}_1, +, ParmN_15}_2 + ) + + Then it exercises the add_expr_to_loop_evolution in the following context: + (add_to_evolution + loop_num = 1 + chrec_before = {{3, +, {27, +, 25}_1}_1, +, ParmN_15}_2 + to_add = ParmN_15 * 5 + res = {{3, +, {ParmN_15 * 5 + 27, +, 25}_1}_1, +, ParmN_15}_2 + ) + */ + a += ParmN; + } + } +} + +/* + b -> {2, +, 25}_1 + d -> {-5, +, 1}_2 + a -> {{3, +, {ParmN * 5 + 27, +, 25}_1}_1, +, ParmN}_2 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-40.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-40.c new file mode 100644 index 00000000000..6603a960275 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-40.c @@ -0,0 +1,22 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main () +{ + int a = 1; + int b = 1; + + while (a) + { + a += b; + b *= 2; + } +} + +/* + b -> {1, *, 2}_1 + a -> {1, +, {1, *, 2}_1}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-41.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-41.c new file mode 100644 index 00000000000..f8c0cd0ca20 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-41.c @@ -0,0 +1,52 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main () +{ + int a = 2; + int b = 4; + int c = 2; + + while (a) + { + a *= 3; + for (c = -10; c < 0; c++) + { + /* Exercises the build_exponential_evolution_in_loop function in the following context: + (multiply_evolution + loop_num = 2 + chrec_before = {2, *, 3}_1 + to_mult = {4, *, 5}_1 + res = {{2, *, 3}_1, *, {4, *, 5}_1}_2 + ) + + Then it exerces the chrec_apply in the following context: + (chrec_apply + var = 2 + chrec = {0, +, {4, *, 5}_1}_2 + x = 10 + res = {40, *, 5}_1 + ) + + Finally it tests the + (add_to_evolution + loop_num = 1 + chrec_before = {{2, *, 3}_1, *, {4, *, 5}_1}_2 + to_add = {40, *, 5}_1 + res = {{2, *, {120, *, 5}_1}_1, *, {4, *, 5}_1}_2 + ) + */ + a *= b; + } + b *= 5; + } +} + +/* + c -> {-10, +, 1}_2 + b -> {4, *, 5}_1 + a -> {{2, *, {120, *, 5}_1}_1, *, {4, *, 5}_1}_2 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-42.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-42.c new file mode 100644 index 00000000000..7b62a712d9e --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-42.c @@ -0,0 +1,30 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main () +{ + int a = 1; + int b = 2; + int c = 0; + int d = 5; + + while (a) + { + a += b; + a += d; + + b += c; + c += 1; + d += 9; + } +} + +/* + c -> {0, +, 1}_1 + b -> {2, +, 0, +, 1}_1 + d -> {5, +, 9}_1 + a -> {1, +, 7, +, 9, +, 1}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-43.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-43.c new file mode 100644 index 00000000000..16ea96731b2 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-43.c @@ -0,0 +1,64 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + + +int main () +{ + int a = 1; + int b = 2; + int c = 0; + int d = 5; + int e; + + while (a) + { + /* The following statement produces the evolution function: + (add_to_evolution + loop_num = 1 + chrec_before = 1 + to_add = {{2, +, 0}_1, +, 10}_1 + res = {{{1, +, 2}_1, +, 0}_1, +, 10}_1 + ) + Note that the evolution of B in the inner loop_2 is not + relevant to the evolution of A in the loop_1. */ + a += b; + + /* And finally the following statement produces the expected scev: + (add_to_evolution + loop_num = 1 + chrec_before = {{{1, +, 2}_1, +, 0}_1, +, 10}_1 + to_add = {5, +, 9}_1 + res = {{{1, +, 7}_1, +, 9}_1, +, 10}_1 + ) + That ends this not so formal proof ("CQFD" in french ;-). */ + a += d; + + for (e = 0; e < 10; e++) + b += c; + /* After having analyzed this loop, the overall effect is added to the evolution of b. + This corresponds to the following operation: + (add_to_evolution + loop_num = 1 + chrec_before = {2, +, {0, +, 1}_1}_2 + to_add = {0, +, 10}_1 + res = {{{2, +, 0}_1, +, 10}_1, +, {0, +, 1}_1}_2 + ). + Note that the variable c has not yet been updated in the loop, and thus its value + at this version is "{0, +, 1}_1". Since the loop_2 runs exactly 10 times, the overall + effect of the loop is "10 * {0, +, 1}_1": that is the TO_ADD argument. + */ + + c += 1; + d += 9; + } +} + +/* + c -> {0, +, 1}_1 + e -> {0, +, 1}_2 + b -> {{2, +, 0, +, 10}_1, +, {0, +, 1}_1}_2 + d -> {5, +, 9}_1 + a -> {1, +, 7, +, 9, +, 10}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-44.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-44.c new file mode 100644 index 00000000000..1a3099a90a6 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-44.c @@ -0,0 +1,38 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +/* That's a reduced testcase of one of my favourite simulation programs. + This is also known under the name: "Newton's falling apple". + The general version is known under the name: "the N-body simulation problem". + + The physics terminology is the best to describe the scalar evolution algorithm: + - first determine the initial conditions of the system, + - then analyze its evolution. +*/ + +double Newton_s_apple () +{ + /* Initial conditions. */ + double g = -10.0; + double speed_z = 0; + double altitude = 3000; + double delta_t = 0.1; + double total_time = 0; + + /* Laws of evolution. */ + while (altitude > 0.0) + { + speed_z += g * delta_t; + altitude += speed_z * delta_t; + total_time += delta_t; + } + + return total_time; +} + +/* + speed_z -> {0.0, +, -1.0e+0}_1 + altitude -> {3.0e+3, +, {(0.0 + -1.0e+0) * 1.00000000000000005551115123125782702118158340454e-1, +, -1.0e+0 * 1.00000000000000005551115123125782702118158340454e-1}_1}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-45.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-45.c new file mode 100644 index 00000000000..5ece3403a42 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-45.c @@ -0,0 +1,44 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +/* That's a reduced testcase of one of my favourite simulation programs. + This is also known under the name: "Newton's falling apple". + The general version is known under the name: "the N-body simulation problem". + + The physics terminology is the best to describe the scalar evolution algorithm: + - first determine the initial conditions of the system, + - then analyze its evolution. +*/ + +double Newton_s_apple () +{ + /* Initial conditions. */ + double g = 10.0; + double speed_z = 0; + double altitude = 3000; + double delta_t = 0.1; + double total_time = 0; + + /* Laws of evolution. */ + while (altitude > 0.0) + { + speed_z += g * delta_t; + altitude -= speed_z * delta_t; + total_time += delta_t; + } + + return total_time; +} + +/* + speed_z -> {0.0, +, 1.0e+0}_1 + altitude -> {3.0e+3, +, {(0.0 + 1.0e+0) * 1.00000000000000005551115123125782702118158340454e-1 * -1, +, 1.0e+0 * 1.00000000000000005551115123125782702118158340454e-1 * -1}_1}_1 + + When computing evolutions in the "symbolic as long as possible" strategy, + the analyzer extracts only the following: + + altitude -> {3.0e+3, +, T.2_11 * -1}_1 + +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-46.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-46.c new file mode 100644 index 00000000000..6c21ae23d80 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-46.c @@ -0,0 +1,18 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +int +foo (int i, + int precision) +{ + i = precision - i - 1; + + /* At this point the analyzer is confused by the initialisation of "i". + It keeps the initial condition under a symbolic form: "i_1". */ + + while (--i); +} + +/* i -> {i_1, +, -1}_1 */ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-47.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-47.c new file mode 100644 index 00000000000..ea38c59df1b --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-47.c @@ -0,0 +1,35 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +int +foo (int unknown_parm, int a, int b) +{ + int p; + + if (unknown_parm) + { + p = a + 2; + } + else + { + p = b + 1; + } + + /* At this point the initial condition of "p" is unknown. + In this case, the analyzer has to keep the initial condition under a symbolic form. */ + + while (p) + p--; + +} + +/* + p -> {p_1, +, -1}_1 + + or, when the Value Range Propagation does its work: + + p -> {[MIN_EXPR <p_4, p_6>, MAX_EXPR <p_4, p_6>], +, -1}_1 + +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-48.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-48.c new file mode 100644 index 00000000000..400f08d7078 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-48.c @@ -0,0 +1,29 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +int +foo (int *c) +{ + int i; + int j = 10; + + for (i = 0; i < 5; i++) + { + for (j = 10;; j--) + { + if (j == 0) + break; + + *(c + j) = *(c + j) - 1; + } + } + + return j; +} + +/* + j -> {10, +, -1}_2 + i -> {0, +, 1}_1 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-49.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-49.c new file mode 100644 index 00000000000..6b911b692b7 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-49.c @@ -0,0 +1,25 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +int +foo (int *c) +{ + int i = 0; + int j = 10; + + while (1) + { + if (i == j) + break; + + i++; + j--; + } + + return j; +} + +/* i -> {0, +, 1}_1 */ +/* j -> {10, +, -1}_1 */ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-50.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-50.c new file mode 100644 index 00000000000..3da547ccd11 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-50.c @@ -0,0 +1,26 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +int +foo (int *c) +{ + int i = 0; + int j = 10; + + while (1) + { + /* This case exercises the number of iterations detector for + {0, +, 1}_1 == {10, +, -1}_1 + */ + if (i == j) + break; + + i++; + j--; + } + + return j; +} + +/* FIXME. */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-51.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-51.c new file mode 100644 index 00000000000..b2a92edc474 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-51.c @@ -0,0 +1,22 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +int +foo (int j) +{ + int i = 0; + int temp_var; + + while (i < 100) + { + /* This exercises the analyzer on strongly connected + components: here "i -> temp_var -> i". */ + temp_var = i + j; + i = temp_var + 2; + } + + return i; +} + +/* FIXME. */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-52.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-52.c new file mode 100644 index 00000000000..594a583b645 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-52.c @@ -0,0 +1,22 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details -fall-data-deps -fdump-tree-ddall" } */ + +int bar (int); + +int foo (void) +{ + int a; + int parm = 11; + int x; + int c[100]; + + for (a = parm; a < 50; a++) + { + /* Array access functions have to be analyzed. */ + x = a + 5; + c[x] = c[x+2] + c[x-1]; + } + bar (c[1]); +} + +/* { dg-final { diff-tree-dumps "ddall" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-52.c.ddall b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-52.c.ddall new file mode 100644 index 00000000000..4c1fc50d97d --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-52.c.ddall @@ -0,0 +1,203 @@ + +;; Function foo (foo) + + +(Data Dep (A = 0, B = 0): + (subscript 0: + access_fn_A: {18, +, 1}_1 + access_fn_B: {18, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) +(Data Dep (A = 0, B = 1): + (subscript 0: + access_fn_A: {18, +, 1}_1 + access_fn_B: {15, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {3, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(3 +) + ) + (Direction Vector: +(+) + ) + +) +(Data Dep (A = 0, B = 2): + (subscript 0: + access_fn_A: {18, +, 1}_1 + access_fn_B: {16, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {2, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(2 +) + ) + (Direction Vector: +(+) + ) + +) +(Data Dep (A = 0, B = 3): (no dependence) + +) +(Data Dep (A = 1, B = 0): + (subscript 0: + access_fn_A: {15, +, 1}_1 + access_fn_B: {18, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {3, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(-3 +) + ) + (Direction Vector: +(-) + ) + +) +(Data Dep (A = 1, B = 1): + (subscript 0: + access_fn_A: {15, +, 1}_1 + access_fn_B: {15, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) +(Data Dep (A = 1, B = 2): + (subscript 0: + access_fn_A: {15, +, 1}_1 + access_fn_B: {16, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {1, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(-1 +) + ) + (Direction Vector: +(-) + ) + +) +(Data Dep (A = 1, B = 3): (no dependence) + +) +(Data Dep (A = 2, B = 0): + (subscript 0: + access_fn_A: {16, +, 1}_1 + access_fn_B: {18, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {2, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(-2 +) + ) + (Direction Vector: +(-) + ) + +) +(Data Dep (A = 2, B = 1): + (subscript 0: + access_fn_A: {16, +, 1}_1 + access_fn_B: {15, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {1, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(1 +) + ) + (Direction Vector: +(+) + ) + +) +(Data Dep (A = 2, B = 2): + (subscript 0: + access_fn_A: {16, +, 1}_1 + access_fn_B: {16, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) +(Data Dep (A = 2, B = 3): (no dependence) + +) +(Data Dep (A = 3, B = 0): (no dependence) + +) +(Data Dep (A = 3, B = 1): (no dependence) + +) +(Data Dep (A = 3, B = 2): (no dependence) + +) +(Data Dep (A = 3, B = 3): + (subscript 0: + access_fn_A: 1 + access_fn_B: 1 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-53.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-53.c new file mode 100644 index 00000000000..9e36aecca52 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-53.c @@ -0,0 +1,128 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details -fall-data-deps -fdump-tree-ddall" } */ + +#define N 16 + +void fbar (float *); +void ibar (int *); +void sbar (short *); + +/* Should be vectorized */ + +foo (int n) +{ + float a[N+1]; + float b[N]; + float c[N]; + float d[N]; + int ia[N]; + int ib[N]; + int ic[N]; + double da[N]; + double db[N]; + short sa[N]; + short sb[N]; + short sc[N]; + int i,j; + int diff = 0; + char cb[N]; + char cc[N]; + char image[N][N]; + char block[N][N]; + + /* Not vetorizable yet (unknown loop bound). */ + for (i = 0; i < n; i++){ + a[i] = b[i]; + } + fbar (a); + + /* Vectorizable. */ + for (i = 0; i < N; i++){ + a[i] = b[i]; + } + fbar (a); + + /* Not Vectorizable (mode not supported). */ + for (i = 0; i < N; i++){ + da[i] = db[i]; + } + fbar (a); + + /* Not vetorizable yet (constant assignment). */ + for (i = 0; i < N; i++){ + a[i] = 5; + } + fbar (a); + + /* Vectorizable. */ + for (i = 0; i < N; i++){ + a[i] = b[i] + c[i] + d[i]; + } + fbar (a); + + /* Vectorizable. */ + for (i = 0; i < N; i++){ + a[i] = b[i] * c[i]; + } + fbar (a); + + /* Vectorizable. */ + for (i = 0; i < N/2; i++){ + a[i] = b[i+N/2] * c[i+N/2] - b[i] * c[i]; + d[i] = b[i] * c[i+N/2] + b[i+N/2] * c[i]; + } + fbar (a); + + /* Not vetorizable yet (too conservative dependence test). */ + for (i = 0; i < N/2; i++){ + a[i] = b[i+N/2] * c[i+N/2] - b[i] * c[i]; + a[i+N/2] = b[i] * c[i+N/2] + b[i+N/2] * c[i]; + } + fbar (a); + + /* Not vetorizable yet (access pattern). */ + for (i = 0; i < N/2; i++){ + a[i] = b[2*i+1] * c[2*i+1] - b[2*i] * c[2*i]; + d[i] = b[2*i] * c[2*i+1] + b[2*i+1] * c[2*i]; + } + fbar (a); + + /* Not vetorizable yet (too conservative dependence test; access pattern). */ + for (i = 0; i < N/2; i++){ + a[2*i] = b[2*i+1] * c[2*i+1] - b[2*i] * c[2*i]; + a[2*i+1] = b[2*i] * c[2*i+1] + b[2*i+1] * c[2*i]; + } + fbar (a); + + /* Not vetorizable yet (no support for integer mult). */ + for (i = 0; i < N; i++){ + ia[i] = ib[i] * ic[i]; + } + ibar (ia); + + /* Vectorizable. */ + for (i = 0; i < N; i++){ + a[i] = b[i] + c[i]; + d[i] = b[i] + c[i]; + ia[i] = ib[i] + ic[i]; + } + ibar (ia); + fbar (a); + fbar (d); + + /* Not vectorizable yet (two types with different nunits in vector). */ + for (i = 0; i < N; i++){ + ia[i] = ib[i] + ic[i]; + sa[i] = sb[i] + sc[i]; + } + ibar (ia); + sbar (sa); + + /* Not vetorizable yet (too conservative dependence test). */ + for (i = 0; i < N; i++){ + a[i] = b[i] + c[i]; + a[i+1] = b[i] + c[i]; + } + fbar (a); +} + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-54.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-54.c new file mode 100644 index 00000000000..9dfc15b642f --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-54.c @@ -0,0 +1,33 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +int main(void) +{ + int a = 5; + int b = 6; + int c = 20; + + while (a <= 100) + { + int i; + + a = b; + for (i = 0; i <= 12; i++) + { + a++; + } + b = b + c; + } +} + +/* This example has been distilled from Pattern1 that cannot be + handled: "Big steps, small steps" from the ICS'01 paper "Monotonic + Evolution" by Peng Wu. + + The analyzer has to detect the following evolution functions: + i -> {0, +, 1}_2 + b -> {6, +, 20}_1 + a -> {{6, +, 20}_1, +, 1}_2 +*/ + +/* FIXME. */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-55.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-55.c new file mode 100644 index 00000000000..796cceb4b50 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-55.c @@ -0,0 +1,16 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev-details" } */ + +int main(int argc) +{ + int I, J; + const int N = 30; + const int M = 40; + for (J = argc; J < N; J += 3) + { + for (I = J; I < M; I++) + { + printf ("%d %d\n", I, J); + } + } +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-56.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-56.c new file mode 100644 index 00000000000..ba2b69ca867 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-56.c @@ -0,0 +1,21 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -ftree-elim-checks -fdump-tree-elck-details -fdump-tree-optimized" } */ + +void remove_me (void); + +int main (void) +{ + int a = -100; + int b = 0; + int c = 3; + + for (a = 0; a < 100; a++) + { + b = b + 3; + if (b != c) + remove_me (); + c = c + 3; + } +} + +/* { dg-final { scan-tree-dump-times "remove_me" 0 "optimized"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-57.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-57.c new file mode 100644 index 00000000000..a873b9fc314 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-57.c @@ -0,0 +1,23 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -ftree-elim-checks -fdump-tree-elck-details -fdump-tree-optimized" } */ + +void remove_me (void); + +int main (void) +{ + int a = -100; + int b = 0; + int c = 3; + + for (a = 0; a < 100; a++) + { + if (b > c) + remove_me (); + b = b + 2; + c = c + 3; + } +} + + +/* { dg-final { scan-tree-dump-times "remove_me" 0 "optimized"} } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-58.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-58.c new file mode 100644 index 00000000000..b0ef757fbb3 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-58.c @@ -0,0 +1,22 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -ftree-elim-checks -fdump-tree-elck-details -fdump-tree-optimized" } */ + +void remove_me (void); + +int main (void) +{ + int a, b; + int N = 100; + + a = 0; + b = 0; + while (a < N) + { + if (b >= 5*N - 4) + remove_me (); + a++; + b+=5; + } +} + +/* { dg-final { scan-tree-dump-times "remove_me" 0 "optimized"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-59.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-59.c new file mode 100644 index 00000000000..9d19bdfb19a --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-59.c @@ -0,0 +1,18 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev -fall-data-deps -fdump-tree-ddall" } */ + +extern int foo (float A[100][200]); + +int bar () +{ + int i, j; + float A[100][200]; + + for (i=0; i<5; i++) + for (j=0; j<5; j++) + A[i][j] = A[i+1][j]; + foo (A); + return A[1][2]; +} + +/* { dg-final { diff-tree-dumps "ddall" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-59.c.ddall b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-59.c.ddall new file mode 100644 index 00000000000..44b70258d3d --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-59.c.ddall @@ -0,0 +1,275 @@ + +;; Function bar (bar) + + +(Data Dep (A = 0, B = 0): + (subscript 0: + access_fn_A: {0, +, 1}_2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {1, +, 1}_1 + access_fn_B: {1, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 0, B = 1): + (subscript 0: + access_fn_A: {0, +, 1}_2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {1, +, 1}_1 + access_fn_B: {0, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {1, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(1 +) + ) + (Direction Vector: +(=) +(+) + ) + +) +(Data Dep (A = 0, B = 2): + (subscript 0: + access_fn_A: {0, +, 1}_2 + access_fn_B: 2 + iterations_that_access_an_element_twice_in_A: 2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {1, +, 1}_1 + access_fn_B: 1 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(-2 +) +(0 +) + ) + (Direction Vector: +(-) +(=) + ) + +) +(Data Dep (A = 1, B = 0): + (subscript 0: + access_fn_A: {0, +, 1}_2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {0, +, 1}_1 + access_fn_B: {1, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {1, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(-1 +) + ) + (Direction Vector: +(=) +(-) + ) + +) +(Data Dep (A = 1, B = 1): + (subscript 0: + access_fn_A: {0, +, 1}_2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {0, +, 1}_1 + access_fn_B: {0, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) +(Data Dep (A = 1, B = 2): + (subscript 0: + access_fn_A: {0, +, 1}_2 + access_fn_B: 2 + iterations_that_access_an_element_twice_in_A: 2 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: {0, +, 1}_1 + access_fn_B: 1 + iterations_that_access_an_element_twice_in_A: 1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(-2 +) +(-1 +) + ) + (Direction Vector: +(-) +(-) + ) + +) +(Data Dep (A = 2, B = 0): + (subscript 0: + access_fn_A: 2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: 1 + access_fn_B: {1, +, 1}_1 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(2 +) +(0 +) + ) + (Direction Vector: +(+) +(=) + ) + +) +(Data Dep (A = 2, B = 1): + (subscript 0: + access_fn_A: 2 + access_fn_B: {0, +, 1}_2 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 2 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: 1 + access_fn_B: {0, +, 1}_1 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(2 +) +(1 +) + ) + (Direction Vector: +(+) +(+) + ) + +) +(Data Dep (A = 2, B = 2): + (subscript 0: + access_fn_A: 2 + access_fn_B: 2 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + + (subscript 1: + access_fn_A: 1 + access_fn_B: 1 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) +(0 +) + ) + (Direction Vector: +(=) +(=) + ) + +) + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-60.c b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-60.c new file mode 100644 index 00000000000..f71561252b0 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-60.c @@ -0,0 +1,21 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fscalar-evolutions -fdump-tree-scev -fall-data-deps -fdump-tree-ddall" } */ + +extern int foo (float A[100]); + +int bar () +{ + int i, j; + float A[100]; + + for (i=0; i<5; i++) + { + A[i * 3] = i + 3; + A[i + 7] = i; + } + + foo (A); + return A[1]; +} + +/* { dg-final { diff-tree-dumps "ddall" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-60.c.ddall b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-60.c.ddall new file mode 100644 index 00000000000..6310edfed42 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/ssa-chrec-60.c.ddall @@ -0,0 +1,107 @@ + +;; Function bar (bar) + + +(Data Dep (A = 0, B = 0): + (subscript 0: + access_fn_A: {0, +, 3}_1 + access_fn_B: {0, +, 3}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) +(Data Dep (A = 0, B = 1): + (subscript 0: + access_fn_A: {0, +, 3}_1 + access_fn_B: {7, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {3, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {2, +, 3}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +([-oo, +oo] +) + ) + (Direction Vector: +(*) + ) + +) +(Data Dep (A = 0, B = 2): (no dependence) + +) +(Data Dep (A = 1, B = 0): + (subscript 0: + access_fn_A: {7, +, 1}_1 + access_fn_B: {0, +, 3}_1 + iterations_that_access_an_element_twice_in_A: {2, +, 3}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {3, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +([-oo, +oo] +) + ) + (Direction Vector: +(*) + ) + +) +(Data Dep (A = 1, B = 1): + (subscript 0: + access_fn_A: {7, +, 1}_1 + access_fn_B: {7, +, 1}_1 + iterations_that_access_an_element_twice_in_A: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: {0, +, 1}_1 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) +(Data Dep (A = 1, B = 2): (no dependence) + +) +(Data Dep (A = 2, B = 0): (no dependence) + +) +(Data Dep (A = 2, B = 1): (no dependence) + +) +(Data Dep (A = 2, B = 2): + (subscript 0: + access_fn_A: 1 + access_fn_B: 1 + iterations_that_access_an_element_twice_in_A: 0 + last_iteration_that_access_an_element_twice_in_A: [-oo, +oo] + iterations_that_access_an_element_twice_in_B: 0 + last_iteration_that_access_an_element_twice_in_B: [-oo, +oo] + ) + (Distance Vector: +(0 +) + ) + (Direction Vector: +(=) + ) + +) + diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf2.exp b/gcc/testsuite/gcc.dg/tree-ssa-chrec/tree-ssa-scev.exp index 6e3621db3ce..ee8394880ba 100644 --- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf2.exp +++ b/gcc/testsuite/gcc.dg/tree-ssa-chrec/tree-ssa-scev.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2002 Free Software Foundation, Inc. +# Copyright (C) 1997 Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -22,21 +22,14 @@ load_lib gcc-dg.exp # If a testcase doesn't have special options, use these. global DEFAULT_CFLAGS if ![info exists DEFAULT_CFLAGS] then { - set DEFAULT_CFLAGS " -ansi -pedantic-errors -gdwarf-2" + set DEFAULT_CFLAGS " -ansi -pedantic-errors" } # Initialize `dg'. dg-init # Main loop. -set comp_output [gcc_target_compile \ - "$srcdir/$subdir/../trivial.c" "trivial.S" assembly \ - "additional_flags=-gdwarf-2"] -if { ! [string match "*: target system does not support the * debug format*" \ - $comp_output] } { - dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[cS\]]] \ - "" $DEFAULT_CFLAGS -} +dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[cS\]]] "" $DEFAULT_CFLAGS # All done. dg-finish diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-1.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-1.c new file mode 100644 index 00000000000..f1fae42e0ef --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-1.c @@ -0,0 +1,101 @@ +/* { dg-do compile { target powerpc*-*-* i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#define N 16 + +void fbar (float *); +void ibar (int *); +void sbar (short *); + +/* multiple loops */ + +foo (int n) +{ + float a[N+1]; + float b[N]; + float c[N]; + float d[N]; + int ia[N]; + int ib[N]; + int ic[N]; + short sa[N]; + short sb[N]; + short sc[N]; + int i,j; + int diff = 0; + char cb[N]; + char cc[N]; + char image[N][N]; + char block[N][N]; + + /* Not vetorizable yet (cross-iteration cycle). */ + diff = 0; + for (i = 0; i < N; i++) { + diff += (cb[i] - cc[i]); + } + ibar (&diff); + + + /* Not vetorizable yet (outer-loop: not attempted. + inner-loop: cross iteration cycle; multi-dimensional arrays). */ + diff = 0; + for (i = 0; i < N; i++) { + for (i = 0; i < N; i++) { + diff += (image[i][j] - block[i][j]); + } + } + ibar (&diff); + + + /* Vectorizable. */ + for (i = 0; i < N; i++){ + a[i] = b[i]; + } + fbar (a); + + + /* Vectorizable. */ + for (i = 0; i < N; i++){ + a[i] = b[i] + c[i] + d[i]; + } + fbar (a); + + + /* Not vetorizable yet (access pattern). */ + for (i = 0; i < N/2; i++){ + a[i] = b[2*i+1] * c[2*i+1] - b[2*i] * c[2*i]; + d[i] = b[2*i] * c[2*i+1] + b[2*i+1] * c[2*i]; + } + fbar (a); + + + /* Vectorizable. */ + for (i = 0; i < N; i++){ + a[i] = b[i] + c[i]; + d[i] = b[i] + c[i]; + ia[i] = ib[i] + ic[i]; + } + ibar (ia); + fbar (a); + fbar (d); + + + /* Not vectorizable yet (two types with different nunits in vector). */ + for (i = 0; i < N; i++){ + ia[i] = ib[i] + ic[i]; + sa[i] = sb[i] + sc[i]; + } + ibar (ia); + sbar (sa); + + + /* Not vetorizable yet (too conservative dependence test). */ + for (i = 0; i < N; i++){ + a[i] = b[i] + c[i]; + a[i+1] = b[i] + c[i]; + } + fbar (a); +} + +/* { dg-final { scan-tree-dump-times "vectorized 3 loops" 1 "vect"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-10.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-10.c new file mode 100644 index 00000000000..7cb6240aea3 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-10.c @@ -0,0 +1,27 @@ +/* { dg-do compile { target powerpc*-*-* i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#define N 16 + +short a[N]; +short d[N]; + +int foo () +{ + int i; + short b[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + short c[N] = {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15}; + + + /* Not vetorizable yet (strided access pattern). */ + for (i = 0; i < N/2; i++) + { + a[i] = b[2*i+1] * c[2*i+1] - b[2*i] * c[2*i]; + d[i] = b[2*i] * c[2*i+1] + b[2*i+1] * c[2*i]; + } + + return 0; +} + +/* { dg-final { scan-tree-dump-times "vectorized 0 loops" 1 "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-11.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-11.c new file mode 100644 index 00000000000..907f5b92dac --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-11.c @@ -0,0 +1,51 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 16 + +int main1 () +{ + int i; + int ia[N]; + int ic[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + int ib[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + + /* Not vetorizable yet (integer mult). */ + for (i = 0; i < N; i++) + { + ia[i] = ib[i] * ic[i]; + } + + /* check results: */ + for (i = 0; i < N; i++) + { + if (ia[i] != ib[i] * ic[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 0 "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-12.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-12.c new file mode 100644 index 00000000000..98db33915ea --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-12.c @@ -0,0 +1,55 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 16 + +int main1 () +{ + int i; + int ia[N]; + int ic[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + int ib[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + short sa[N]; + short sc[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + short sb[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + + /* Not vetorizable yet (multiple types with different nunits in vector). */ + for (i = 0; i < N; i++) + { + ia[i] = ib[i] + ic[i]; + sa[i] = sb[i] + sc[i]; + } + + /* check results: */ + for (i = 0; i < N; i++) + { + if (ia[i] != ib[i] + ic[i] || sa[i] != sb[i] + sc[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { xfail *-*-* } } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-13.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-13.c new file mode 100644 index 00000000000..f32451d4d02 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-13.c @@ -0,0 +1,25 @@ +/* { dg-do compile { target powerpc*-*-* i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + + +#define N 16 + +int a[N]; +int results[N] = {0,1,2,3,0,0,0,0,0,0,0,0,12,13,14,15}; + +int main () +{ + int i; + int b[N] = {0,1,2,3,-4,-5,-6,-7,-8,-9,-10,-11,12,13,14,15}; + + /* Not vectorizable yet (condition in loop). */ + for (i = 0; i < N; i++) + { + a[i] = (b[i] >= 0 ? b[i] : 0); + } + + return 0; +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { xfail *-*-* } } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-14.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-14.c new file mode 100644 index 00000000000..6aed7b99b57 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-14.c @@ -0,0 +1,49 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 16 + +int main1 () +{ + int i; + int ia[N]; + + + /* Not vetorizable yet (induction). */ + for ( i = 0; i < N; i++) { + ia[i] = i; + } + + /* check results: */ + for (i = 0; i < N; i++) + { + if (ia[i] != i) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { xfail *-*-* } } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-15.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-15.c new file mode 100644 index 00000000000..5f0ea5ead9a --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-15.c @@ -0,0 +1,50 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 16 + +int main1 () +{ + int i; + int a[N]; + int b[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + + /* Not vetorizable yet (reverse access and forward access). */ + for (i = N; i > 0; i--) + { + a[N-i] = b[i-1]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (a[i] != b[N-1-i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { xfail *-*-* } } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-16.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-16.c new file mode 100644 index 00000000000..9818dc4a09e --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-16.c @@ -0,0 +1,49 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 16 +#define DIFF 240 + +int main1 () +{ + int i; + float b[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + float c[N] = {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15}; + float diff; + + /* Not vetorizable yet (reduction). */ + diff = 0; + for (i = 0; i < N; i++) { + diff += (b[i] - c[i]); + } + + /* check results: */ + if (diff != DIFF) + abort (); + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { xfail *-*-* } } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-17.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-17.c new file mode 100644 index 00000000000..4799dd5a634 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-17.c @@ -0,0 +1,140 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 64 + +int +main1 () +{ + int i; + int ia[N]; + int ib[N]= + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + int ic[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char ca[N]; + char cb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char cc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sa[N]; + short sb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + /* Check ints. */ + + for (i = 0; i < N; i++) + { + ia[i] = ib[i] & ic[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ia[i] != ib[i] & ic[i]) + abort (); + } + + /* Check chars. */ + + for (i = 0; i < N; i++) + { + ca[i] = cb[i] & cc[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ca[i] != cb[i] & cc[i]) + abort (); + } + + /* Check shorts. */ + + for (i = 0; i < N; i++) + { + sa[i] = sb[i] & sc[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (sa[i] != sb[i] & sc[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 3 loops" 1 "vect"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-18.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-18.c new file mode 100644 index 00000000000..f66c3d4aca8 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-18.c @@ -0,0 +1,139 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 64 + +int +main1 () +{ + int i; + int ia[N]; + int ib[N]= + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + int ic[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char ca[N]; + char cb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char cc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sa[N]; + short sb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + /* Check ints. */ + + for (i = 0; i < N; i++) + { + ia[i] = (ib[i] | ic[i]); + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ia[i] != (ib[i] | ic[i])) + abort (); + } + + /* Check chars. */ + + for (i = 0; i < N; i++) + { + ca[i] = (cb[i] | cc[i]); + } + + /* check results: */ + for (i = 0; i < N; i++) + { + if (ca[i] != (cb[i] | cc[i])) + abort (); + } + + /* Check shorts. */ + + for (i = 0; i < N; i++) + { + sa[i] = (sb[i] | sc[i]); + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (sa[i] != (sb[i] | sc[i])) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 3 loops" 1 "vect"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-19.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-19.c new file mode 100644 index 00000000000..87f1bc41d07 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-19.c @@ -0,0 +1,139 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 64 + +int +main1 () +{ + int i; + int ia[N]; + int ib[N]= + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + int ic[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char ca[N]; + char cb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char cc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sa[N]; + short sb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + /* Check ints. */ + + for (i = 0; i < N; i++) + { + ia[i] = ib[i] ^ ic[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ia[i] != ib[i] ^ ic[i]) + abort (); + } + + /* Check chars. */ + + for (i = 0; i < N; i++) + { + ca[i] = cb[i] ^ cc[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ca[i] != cb[i] ^ cc[i]) + abort (); + } + + /* Check shorts. */ + + for (i = 0; i < N; i++) + { + sa[i] = sb[i] ^ sc[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (sa[i] != sb[i] ^ sc[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 3 loops" 1 "vect"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-2.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-2.c new file mode 100644 index 00000000000..397519f08a6 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-2.c @@ -0,0 +1,50 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 16 + +int main1 () +{ + char cb[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + char ca[N]; + int i; + + for (i = 0; i < N; i++) + { + ca[i] = cb[i]; + } + + /* check results: */ + for (i = 0; i < N; i++) + { + if (ca[i] != cb[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-20.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-20.c new file mode 100644 index 00000000000..10347d10150 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-20.c @@ -0,0 +1,139 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 64 + +int +main1 () +{ + int i; + int ia[N]; + int ib[N]= + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + int ic[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char ca[N]; + char cb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char cc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sa[N]; + short sb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + /* Check ints. */ + + for (i = 0; i < N; i++) + { + ia[i] = ~ib[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ia[i] != ~ib[i]) + abort (); + } + + /* Check chars. */ + + for (i = 0; i < N; i++) + { + ca[i] = ~cb[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ca[i] != ~cb[i]) + abort (); + } + + /* Check shorts. */ + + for (i = 0; i < N; i++) + { + sa[i] = ~sb[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (sa[i] != ~sb[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 3 loops" 1 "vect"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-21.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-21.c new file mode 100644 index 00000000000..feea2e5c5f9 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-21.c @@ -0,0 +1,140 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 64 + +int +main1 () +{ + int i; + int ia[N]; + int ib[N]= + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + int ic[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char ca[N]; + char cb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char cc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sa[N]; + short sb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + /* Check ints. */ + + for (i = 0; i < N; i++) + { + ia[i] = !ib[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ia[i] != !ib[i]) + abort (); + } + + /* Check chars. */ + + for (i = 0; i < N; i++) + { + ca[i] = !cb[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ca[i] != !cb[i]) + abort (); + } + + /* Check shorts. */ + + for (i = 0; i < N; i++) + { + sa[i] = !sb[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (sa[i] != !sb[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 3 loops" 1 "vect" { xfail *-*-* } } } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-22.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-22.c new file mode 100644 index 00000000000..064fbab2333 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-22.c @@ -0,0 +1,140 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 64 + +int +main1 () +{ + int i; + int ia[N]; + int ib[N]= + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + int ic[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char ca[N]; + char cb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char cc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sa[N]; + short sb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + /* Check ints. */ + + for (i = 0; i < N; i++) + { + ia[i] = -ib[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ia[i] != -ib[i]) + abort (); + } + + /* Check chars. */ + + for (i = 0; i < N; i++) + { + ca[i] = -cb[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ca[i] != -cb[i]) + abort (); + } + + /* Check shorts. */ + + for (i = 0; i < N; i++) + { + sa[i] = -sb[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (sa[i] != -sb[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 3 loops" 1 "vect" { xfail *-*-* } } } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-23.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-23.c new file mode 100644 index 00000000000..6781ad1caf5 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-23.c @@ -0,0 +1,140 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 64 + +int +main1 () +{ + int i; + int ia[N]; + int ib[N]= + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + int ic[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char ca[N]; + char cb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char cc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sa[N]; + short sb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + /* Check ints. */ + + for (i = 0; i < N; i++) + { + ia[i] = ib[i] && ic[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ia[i] != ib[i] && ic[i]) + abort (); + } + + /* Check chars. */ + + for (i = 0; i < N; i++) + { + ca[i] = cb[i] && cc[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ca[i] != cb[i] && cc[i]) + abort (); + } + + /* Check shorts. */ + + for (i = 0; i < N; i++) + { + sa[i] = sb[i] && sc[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (sa[i] != sb[i] && sc[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 3 loops" 1 "vect" { xfail *-*-* } } } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-24.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-24.c new file mode 100644 index 00000000000..08f0cff3d75 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-24.c @@ -0,0 +1,140 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 64 + +int +main1 () +{ + int i; + int ia[N]; + int ib[N]= + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + int ic[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char ca[N]; + char cb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + char cc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sa[N]; + short sb[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + short sc[N] = + {1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0, + 1,1,0,0,1,0,1,0}; + + /* Check ints. */ + + for (i = 0; i < N; i++) + { + ia[i] = (ib[i] || ic[i]); + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ia[i] != (ib[i] || ic[i])) + abort (); + } + + /* Check chars. */ + + for (i = 0; i < N; i++) + { + ca[i] = (cb[i] || cc[i]); + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (ca[i] != (cb[i] || cc[i])) + abort (); + } + + /* Check shorts. */ + + for (i = 0; i < N; i++) + { + sa[i] = (sb[i] || sc[i]); + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (sa[i] != (sb[i] || sc[i])) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 3 loops" 1 "vect" { xfail *-*-* } } } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-25.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-25.c new file mode 100644 index 00000000000..bdfc38367bb --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-25.c @@ -0,0 +1,66 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 128 + +int main1 (int n, int *p) +{ + int i; + int ib[N]; + int ia[N]; + int k; + + for (i = 0; i < N; i++) + { + ia[i] = n; + } + + /* check results: */ + for (i = 0; i < N; i++) + { + if (ia[i] != n) + abort (); + } + + k = *p; + for (i = 0; i < N; i++) + { + ib[i] = k; + } + + /* check results: */ + for (i = 0; i < N; i++) + { + if (ib[i] != k) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + int m = 8; + + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (m, &m); +} + +/* { dg-final { scan-tree-dump-times "vectorized 2 loops" 1 "vect"} } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-26.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-26.c new file mode 100644 index 00000000000..9afe6a27aaa --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-26.c @@ -0,0 +1,51 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 128 + +/* unaligned store. */ + +int main1 () +{ + int i; + int ia[N+1]; + + for (i = 1; i <= N; i++) + { + ia[i] = 5; + } + + /* check results: */ + for (i = 1; i <= N; i++) + { + if (ia[i] != 5) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { xfail *-*-* } } } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-27.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-27.c new file mode 100644 index 00000000000..42f55fdb6bc --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-27.c @@ -0,0 +1,57 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 128 + +/* unaligned load. */ + +int main1 () +{ + int i; + int ia[N]; + int ib[N+1]; + + for (i=0; i < N; i++) + { + ib[i] = i; + } + + for (i = 1; i <= N; i++) + { + ia[i-1] = ib[i]; + } + + /* check results: */ + for (i = 1; i <= N; i++) + { + if (ia[i-1] != ib[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { xfail *-*-* } } } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-28.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-28.c new file mode 100644 index 00000000000..2154aeb9f93 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-28.c @@ -0,0 +1,54 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 128 +#define OFF 3 + +/* unaligned store. */ + +int main1 (int off) +{ + int i; + int ia[N+OFF]; + + for (i = 0; i < N; i++) + { + ia[i+off] = 5; + } + + /* check results: */ + for (i = 0; i < N; i++) + { + if (ia[i+off] != 5) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + main1 (0); /* aligned */ + main1 (OFF); /* unaligned */ + return 0; +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { xfail *-*-* } } } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-29.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-29.c new file mode 100644 index 00000000000..98dfa585bb2 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-29.c @@ -0,0 +1,60 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 128 +#define OFF 3 + +/* unaligned load. */ + +int main1 (int off) +{ + int i; + int ia[N]; + int ib[N+OFF]; + + for (i = 0; i < N+OFF; i++) + { + ib[i] = i; + } + + for (i = 0; i < N; i++) + { + ia[i] = ib[i+off]; + } + + /* check results: */ + for (i = 0; i < N; i++) + { + if (ia[i] != ib[i+off]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + main1 (0); /* aligned */ + main1 (OFF); /* unaligned */ + return 0; +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { xfail *-*-* } } } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-3.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-3.c new file mode 100644 index 00000000000..0a0d8231d27 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-3.c @@ -0,0 +1,63 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 20 + +int +main1 () +{ + int i; + float a[N]; + float e[N]; + float b[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + float c[N] = {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15}; + float d[N] = {0,2,4,6,8,10,12,14,16,18,20,22,24,26,28,30}; + int ic[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + int ib[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + int ia[N]; + + for (i = 0; i < N; i++) + { + a[i] = b[i] + c[i] + d[i]; + e[i] = b[i] + c[i] + d[i]; + ia[i] = ib[i] + ic[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + float fres = b[i] + c[i] + d[i]; + int ires = ib[i] + ic[i]; + if (a[i] != fres || e[i] != fres || ia[i] != ires) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect"} } */ + + + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-4.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-4.c new file mode 100644 index 00000000000..698e8a1b3c1 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-4.c @@ -0,0 +1,51 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 20 + +int +main1 () +{ + int i; + float a[N]; + float b[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45,48,51,54,57}; + float c[N] = {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19}; + + for (i = 0; i < N; i++) + { + a[i] = b[i] * c[i]; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (a[i] != b[i] * c[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-5.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-5.c new file mode 100644 index 00000000000..d5445c8c119 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-5.c @@ -0,0 +1,69 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 16 + +int main1 () +{ + int i, j; + float a[N]; + float c[N] = {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15}; + float d[N] = {0,2,4,6,8,10,12,14,16,18,20,22,24,26,28,30}; + + i = 0; + j = 0; + while (i < 5*N) + { + a[j] = c[j]; + i += 5; + j++; + } + + /* check results: */ + for (i = 0; i <N; i++) + { + if (a[i] != c[i]) + abort (); + } + + + for (i = N; i > 0; i--) + { + a[N-i] = d[N-i]; + } + + /* check results: */ + for (i = 0; i < N; i++) + { + if (a[i] != d[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + + +/* { dg-final { scan-tree-dump-times "vectorized 2 loops" 1 "vect" } } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-6.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-6.c new file mode 100644 index 00000000000..3a40503e1ff --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-6.c @@ -0,0 +1,71 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 16 + +float results1[N] = {192.00,240.00,288.00,336.00,384.00,432.00,480.00,528.00,0.00}; +float results2[N] = {0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,54.00,120.00,198.00,288.00,390.00,504.00,630.00}; + +int main1 () +{ + int i; + float a[N] = {0}; + float e[N] = {0}; + float b[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + float c[N] = {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15}; + + for (i = 0; i < N/2; i++) + { + a[i] = b[i+N/2] * c[i+N/2] - b[i] * c[i]; + e[i+N/2] = b[i] * c[i+N/2] + b[i+N/2] * c[i]; + } + + for (i=0; i<N; i++) + { + if (a[i] != results1[i] || e[i] != results2[i]) + abort(); + } + + /* check results: */ + + for (i = 1; i <=N-4; i++) + { + a[i+3] = b[i-1]; + } + + /* check results: */ + for (i = 1; i <=N-4; i++) + { + if (a[i+3] != b[i-1]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + + +/* { dg-final { scan-tree-dump-times "vectorized 2 loops" 1 "vect" } } */ + + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-7.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-7.c new file mode 100644 index 00000000000..d54ef642d1d --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-7.c @@ -0,0 +1,64 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 128 + +int main1 () +{ + int i; + short sa[N]; + short sb[N]; + + for (i = 0; i < N; i++) + { + sb[i] = 5; + } + + /* check results: */ + for (i = 0; i < N; i++) + { + if (sb[i] != 5) + abort (); + } + + for (i = 0; i < N; i++) + { + sa[i] = sb[i] + 100; + } + + /* check results: */ + for (i = 0; i < N; i++) + { + if (sa[i] != 105) + abort (); + } + + return 0; +} + + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + + +/* { dg-final { scan-tree-dump-times "vectorized 2 loops" 1 "vect"} } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-8.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-8.c new file mode 100644 index 00000000000..e66718f77ef --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-8.c @@ -0,0 +1,50 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 16 + +float b[N] = {0,2,4,6,8,10,12,14,16,18,20,22,24,26,28,30}; +float a[N]; + +int main1 (int n) +{ + int i; + + /* Not vetorizable yet (unknown loop bound). */ + for (i = 0; i < n; i++){ + a[i] = b[i]; + } + + /* check results: */ + for (i = 0; i < n; i++) + { + if (a[i] != b[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (N); +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { xfail *-*-* } } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-9.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-9.c new file mode 100644 index 00000000000..939e265d539 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-9.c @@ -0,0 +1,50 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 16 + +int main1 () +{ + int i; + short sb[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + int ia[N]; + + /* Not vetorizable yet (type cast). */ + for (i = 0; i < N; i++) + { + ia[i] = (int) sb[i]; + } + + /* check results: */ + for (i = 0; i < N; i++) + { + if (ia[i] != (int) sb[i]) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { xfail *-*-* } } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-all.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-all.c new file mode 100644 index 00000000000..2c3fee0cf2a --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-all.c @@ -0,0 +1,228 @@ +/* { dg-do run { target powerpc*-*-* } } */ +/* { dg-do compile { target i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#include <stdarg.h> +#include <signal.h> + +#define N 16 + +int iadd_results[N] = {0,6,12,18,24,30,36,42,48,54,60,66,72,78,84,90}; +float fadd_results[N] = {0.0,6.0,12.0,18.0,24.0,30.0,36.0,42.0,48.0,54.0,60.0,66.0,72.0,78.0,84.0,90.0}; +float fmul_results[N] = {0.0,3.0,12.0,27.0,48.0,75.0,108.0,147.0,192.0,243.0,300.0,363.0,432.0,507.0,588.0,675.0}; +float fresults1[N] = {192.00,240.00,288.00,336.00,384.00,432.00,480.00,528.00,48.00,54.00,60.00,66.00,72.00,78.00,84.00,90.00}; +float fresults2[N] = {0.00,6.00,12.00,18.00,24.00,30.00,36.00,42.00,0.00,54.00,120.00,198.00,288.00,390.00,504.00,630.00}; + +/****************************************************/ +void icheck_results (int *a, int *results) +{ + int i; + for (i = 0; i < N; i++) + { + if (a[i] != results[i]) + abort (); + } +} + +void fcheck_results (float *a, float *results) +{ + int i; + for (i = 0; i < N; i++) + { + if (a[i] != results[i]) + abort (); + } +} + +void +fbar_mul (float *a) +{ + fcheck_results (a, fmul_results); +} + +void +fbar_add (float *a) +{ + fcheck_results (a, fadd_results); +} + +void +ibar_add (int *a) +{ + icheck_results (a, iadd_results); +} + +void +fbar1 (float *a) +{ + fcheck_results (a, fresults1); +} + +void +fbar2 (float *a) +{ + fcheck_results (a, fresults2); +} + + +/* All of the loops below are currently vectorizable. */ + +int +main1 () +{ + int i,j; + float a[N]; + float e[N]; + float b[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + float c[N] = {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15}; + float d[N] = {0,2,4,6,8,10,12,14,16,18,20,22,24,26,28,30}; + int ic[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + int ib[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + int ia[N]; + char cb[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + char ca[N]; + short sa[N]; + + /* Test 1: copy chars. */ + for (i = 0; i < N; i++) + { + ca[i] = cb[i]; + } + /* check results: */ + for (i = 0; i < N; i++) + { + if (ca[i] != cb[i]) + abort (); + } + + + /* Test 2: fp mult. */ + for (i = 0; i < N; i++) + { + a[i] = b[i] * c[i]; + } + fbar_mul (a); + + + /* Test 3: mixed types (int, fp), same nunits in vector. */ + for (i = 0; i < N; i++) + { + a[i] = b[i] + c[i] + d[i]; + e[i] = b[i] + c[i] + d[i]; + ia[i] = ib[i] + ic[i]; + } + ibar_add (ia); + fbar_add (a); + fbar_add (e); + + + /* Test 4: access with offset. */ + for (i = 0; i < N/2; i++) + { + a[i] = b[i+N/2] * c[i+N/2] - b[i] * c[i]; + e[i+N/2] = b[i] * c[i+N/2] + b[i+N/2] * c[i]; + } + fbar1 (a); + fbar2 (e); + + + /* Test 5: access with offset */ + for (i = 1; i <=N-4; i++) + { + a[i+3] = b[i-1]; + } + /* check results: */ + for (i = 1; i <=N-4; i++) + { + if (a[i+3] != b[i-1]) + abort (); + } + + + /* Test 6 - loop induction with stride != 1. */ + i = 0; + j = 0; + while (i < 5*N) + { + a[j] = c[j]; + i += 5; + j++; + } + /* check results: */ + for (i = 0; i <N; i++) + { + if (a[i] != c[i]) + abort (); + } + + + /* Test 7 - reverse access. */ + for (i = N; i > 0; i--) + { + a[N-i] = d[N-i]; + } + /* check results: */ + for (i = 0; i <N; i++) + { + if (a[i] != d[i]) + abort (); + } + + + /* Tests 8,9,10 - constants. */ + for (i = 0; i < N; i++) + { + a[i] = 5.0; + } + /* check results: */ + for (i = 0; i < N; i++) + { + if (a[i] != 5.0) + abort (); + } + + for (i = 0; i < N; i++) + { + sa[i] = 5; + } + /* check results: */ + for (i = 0; i < N; i++) + { + if (sa[i] != 5) + abort (); + } + + for (i = 0; i < N; i++) + { + ia[i] = ib[i] + 5; + } + /* check results: */ + for (i = 0; i < N; i++) + { + if (ia[i] != ib[i] + 5) + abort (); + } + + return 0; +} + +void +sig_ill_handler (int sig) +{ + exit(0); +} + +int main (void) +{ + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); +} + + +/* { dg-final { scan-tree-dump-times "vectorized 10 loops" 1 "vect"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-none.c b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-none.c new file mode 100644 index 00000000000..2d90a15b9b5 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect-none.c @@ -0,0 +1,190 @@ +/* { dg-do compile { target powerpc*-*-* i?86-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -maltivec" { target powerpc*-*-* } } */ +/* { dg-options "-O2 -ftree-vectorize -fdump-tree-vect-stats -msse2" { target i?86-*-* } } */ + +#define N 16 + +int iadd_results[N] = {0,6,12,18,24,30,36,42,48,54,60,66,72,78,84,90}; +float fadd_results[N] = {0.0,6.0,12.0,18.0,24.0,30.0,36.0,42.0,48.0,54.0,60.0,66.0,72.0,78.0,84.0,90.0}; +float fmul_results[N] = {0.0,3.0,12.0,27.0,48.0,75.0,108.0,147.0,192.0,243.0,300.0,363.0,432.0,507.0,588.0,675.0}; +float fresults1[N] = {192.00,240.00,288.00,336.00,384.00,432.00,480.00,528.00,48.00,54.00,60.00,66.00,72.00,78.00,84.00,90.00}; +float fresults2[N] = {0.00,6.00,12.00,18.00,24.00,30.00,36.00,42.00,0.00,54.00,120.00,198.00,288.00,390.00,504.00,630.00}; + +/****************************************************/ +void icheck_results (int *a, int *results) +{ + int i; + for (i = 0; i < N; i++) + { + if (a[i] != results[i]) + abort (); + } +} + +void fcheck_results (float *a, float *results) +{ + int i; + for (i = 0; i < N; i++) + { + if (a[i] != results[i]) + abort (); + } +} + +void +fbar_mul (float *a) +{ + fcheck_results (a, fmul_results); +} + +void +fbar_add (float *a) +{ + fcheck_results (a, fadd_results); +} + +void +ibar_add (int *a) +{ + icheck_results (a, iadd_results); +} + +void +fbar1 (float *a) +{ + fcheck_results (a, fresults1); +} + +void +fbar2 (float *a) +{ + fcheck_results (a, fresults2); +} + + +/* None of the loops below is currently vectorizable. The vectorizer will + be enhanced to vectorize most of these loops. */ + +int +foo (int n) +{ + int i,j; + float a[N]; + float e[N]; + float b[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + float c[N] = {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15}; + float d[N] = {0,2,4,6,8,10,12,14,16,18,20,22,24,26,28,30}; + short sc[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + short sb[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + short sa[N]; + int ic[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + int ib[N] = {0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,45}; + int ia[N]; + int diff = 0; + char cb[N]; + char cc[N]; + char image[N][N]; + char block[N][N]; + + + /* Test 1 - unknown loop bound. */ + for (i = 0; i < n; i++) + { + a[i] = b[i]; + } + fbar (a); + + + /* Test 2 - type cast. */ + for (i = 0; i < N; i++) + { + ia[i] = (int) sb[i]; + } + fbar (a); + + + /* Test 3 - strided access pattern. */ + for (i = 0; i < N/2; i++) + { + a[i] = b[2*i+1] * c[2*i+1] - b[2*i] * c[2*i]; + d[i] = b[2*i] * c[2*i+1] + b[2*i+1] * c[2*i]; + } + fbar (a); + + + /* Test 4 - no target support for integer mult. */ + for (i = 0; i < N; i++) + { + ia[i] = ib[i] * ic[i]; + } + ibar (ia); + + + /* Test 5 - two types with different nunits in vector. */ + for (i = 0; i < N; i++) + { + ia[i] = ib[i] + ic[i]; + sa[i] = sb[i] + sc[i]; + } + ibar (ia); + sbar (sa); + + + /* Test 6 - too conservative dependence test. */ + for (i = 0; i < N; i++){ + a[i] = b[i] + c[i]; + a[i+1] = b[i] + c[i]; + } + fbar (a); + + + /* Test 7 - condition in loop. */ + for (i = 0; i < N; i++){ + a[i] = (b[i] > 0 ? b[i] : 0); + } + fbar (a); + + + /* Test 8 - cross-iteration cycle. */ + diff = 0; + for (i = 0; i < N; i++) { + diff += (cb[i] - cc[i]); + } + ibar (&diff); + + + /* Test 9 - outer-loop not attempted; inner-loop has cross + iteration cycle and multi-dimensional arrays. */ + diff = 0; + for (i = 0; i < N; i++) { + for (i = 0; i < N; i++) { + diff += (image[i][j] - block[i][j]); + } + } + ibar (&diff); + + + /* Test 10 - induction. */ + for ( i = 0; i < N; i++) { + a[i] = i; + } + fbar (a); + + + /* Test 11 - reverse access and forward access. */ + for (i = N; i > 0; i--) + { + a[N-i] = b[i-1]; + } + /* check results: */ + for (i = 0; i <N; i++) + { + if (a[i] != b[N-1-i]) + abort (); + } + + return 0; +} + +/* { dg-final { scan-tree-dump-times "vectorized " 3 "vect"} } */ +/* { dg-final { scan-tree-dump-times "vectorized 0 loops" 3 "vect"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect.exp b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect.exp new file mode 100644 index 00000000000..ee8394880ba --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa-vect/tree-ssa-vect.exp @@ -0,0 +1,35 @@ +# Copyright (C) 1997 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gcc-dg.exp + +# If a testcase doesn't have special options, use these. +global DEFAULT_CFLAGS +if ![info exists DEFAULT_CFLAGS] then { + set DEFAULT_CFLAGS " -ansi -pedantic-errors" +} + +# Initialize `dg'. +dg-init + +# Main loop. +dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[cS\]]] "" $DEFAULT_CFLAGS + +# All done. +dg-finish diff --git a/gcc/testsuite/gcc.dg/tree-ssa/20030711-1.c b/gcc/testsuite/gcc.dg/tree-ssa/20030711-1.c index eba207a25e5..c51c4fe5925 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/20030711-1.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/20030711-1.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O1 -fdump-tree-dom3" } */ +/* { dg-options "-O1 -fdump-tree-dom3 -ftree-loop-optimize" } */ union tree_node; diff --git a/gcc/testsuite/gcc.dg/tree-ssa/20030714-2.c b/gcc/testsuite/gcc.dg/tree-ssa/20030714-2.c index 6a43360b07f..76f7b62d469 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/20030714-2.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/20030714-2.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O1 -fdump-tree-dom3" } */ +/* { dg-options "-O1 -fdump-tree-dom3 -ftree-loop-optimize" } */ union tree_node; diff --git a/gcc/testsuite/gcc.dg/tree-ssa/20040308-1.c b/gcc/testsuite/gcc.dg/tree-ssa/20040308-1.c new file mode 100644 index 00000000000..59397d8cbb1 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/20040308-1.c @@ -0,0 +1,18 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fdump-tree-phiopt1-details" } */ + +int t( int i) +{ + int j; + if(i ==0) + j = 1; + else + j = 0; + + + return j; +} + +/* We should convert one COND_EXPRs into straightline code. */ +/* { dg-final { scan-tree-dump-times "straightline" 1 "phiopt1" {xfail *-*-* } } } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa/20040308-2.c b/gcc/testsuite/gcc.dg/tree-ssa/20040308-2.c new file mode 100644 index 00000000000..3d2daae6f47 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/20040308-2.c @@ -0,0 +1,18 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-phiopt1-details -fdump-tree-tailc-details" } */ + + +int f(int i) +{ + int result; + result = t(i); + if (result) + return result; + return 0; +} + +/* We should convert one COND_EXPRs into straightline code. */ +/* { dg-final { scan-tree-dump-times "straightline" 1 "phiopt1" } } */ +/* Also we should have found that the call to t is tail called. */ +/* { dg-final { scan-tree-dump-times "Found tail call" 1 "tailc" } } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa/20040308-3.c b/gcc/testsuite/gcc.dg/tree-ssa/20040308-3.c new file mode 100644 index 00000000000..86f003f127a --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/20040308-3.c @@ -0,0 +1,17 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fdump-tree-phiopt1-details" } */ + +int t( int i) +{ + int j; + if(i>=0) + j = i; + else + j = -i; + return j; +} + +/* We should convert one COND_EXPRs into straightline code with ABS. */ +/* { dg-final { scan-tree-dump-times "straightline" 1 "phiopt1"} } */ +/* { dg-final { scan-tree-dump-times "ABS_EXPR" 1 "phiopt1"} } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa/20040308-4.c b/gcc/testsuite/gcc.dg/tree-ssa/20040308-4.c new file mode 100644 index 00000000000..ac85077551f --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/20040308-4.c @@ -0,0 +1,17 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fdump-tree-phiopt1-details" } */ + +int t( int i, int k) +{ + int j; + if(i!=k) + j = i; + else + j = k; + + return j; +} + +/* We should convert one COND_EXPRs into straightline code. */ +/* { dg-final { scan-tree-dump-times "straightline" 1 "phiopt1"} } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa/copy-headers.c b/gcc/testsuite/gcc.dg/tree-ssa/copy-headers.c index efe831beab5..eb03840e770 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/copy-headers.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/copy-headers.c @@ -1,15 +1,18 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fdump-tree-ch-details" } */ +/* { dg-options "-O2 -fdump-tree-dom1 -ftree-loop-optimize" } */ -extern int foo (int); +extern void link_error (void); void bla (void) { - int i, n = foo (0); + int i, j = 1; - for (i = 0; i < n; i++) - foo (i); + for (i = 0; i < 100; i++) + j = 0; + + if (j) + link_error (); } -/* There should be a header scheduled for duplication. */ -/* { dg-final { scan-tree-dump-times "Scheduled" 1 "ch"} } */ +/* There should be no link_error call in the dom1 dump. */ +/* { dg-final { scan-tree-dump-times "link_error" 0 "dom1"} } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ivcanon-1.c b/gcc/testsuite/gcc.dg/tree-ssa/ivcanon-1.c new file mode 100644 index 00000000000..430a9514ca5 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ivcanon-1.c @@ -0,0 +1,37 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -ftree-loop-optimize -fscalar-evolutions -funroll-loops -fdump-tree-optimized" } */ + +void foo(void) +{ + int n = 16875; + + while (n) + { + if (n&1) + bar (n); + n >>= 1; + } +} + +static inline int power (long x, unsigned int n) +{ + long y = n % 2 ? x : 1; + + while (n >>= 1) + { + x = x * x; + if (n % 2) + y = y * x; + } + + return y; +} + +void test(long x) +{ + bar (power (x, 10)); + bar (power (x, 27)); +} + +/* All loops should be completely unrolled, so there should be no labels. */ +/* { dg-final { scan-tree-dump-times "<L" 0 "optimized"} } */ diff --git a/gcc/testsuite/gcc.dg/typespec-1.c b/gcc/testsuite/gcc.dg/typespec-1.c index 1acaaf73676..a0e0c1a9992 100644 --- a/gcc/testsuite/gcc.dg/typespec-1.c +++ b/gcc/testsuite/gcc.dg/typespec-1.c @@ -11,7 +11,8 @@ not requiring -pedantic. */ /* Origin: Joseph Myers <jsm28@cam.ac.uk> */ /* { dg-do compile } */ -/* { dg-options "-std=gnu99" } */ +/* APPLE LOCAL -Wlong-double */ +/* { dg-options "-std=gnu99 -Wno-long-double" } */ typedef char type; void *x0; diff --git a/gcc/testsuite/gcc.dg/va-arg-2.c b/gcc/testsuite/gcc.dg/va-arg-2.c index 2e2849c1528..5140545f121 100644 --- a/gcc/testsuite/gcc.dg/va-arg-2.c +++ b/gcc/testsuite/gcc.dg/va-arg-2.c @@ -6,7 +6,10 @@ #include <varargs.h> /* { dg-bogus "varargs.h" "missing file" } */ /* { dg-error "" "In file included from" { target *-*-* } 6 } */ -/* { dg-error "no longer implements" "#error 1" { target *-*-* } 4 } */ -/* { dg-error "Revise your code" "#error 2" { target *-*-* } 5 } */ + +/* APPLE LOCAL BEGIN - varargs.h changes to line numbers hartoog@apple.com */ +/* { dg-error "no longer implements" "#error 1" { target *-*-* } 10 } */ +/* { dg-error "Revise your code" "#error 2" { target *-*-* } 11 } */ +/* APPLE LOCAL END - varargs.h changes to line numbers hartoog@apple.com */ int x; /* prevent empty-source-file warning */ diff --git a/gcc/testsuite/gcc.dg/verbose-asm-2.c b/gcc/testsuite/gcc.dg/verbose-asm-2.c new file mode 100644 index 00000000000..4a8b1b45972 --- /dev/null +++ b/gcc/testsuite/gcc.dg/verbose-asm-2.c @@ -0,0 +1,13 @@ +/* APPLE LOCAL entire file */ +/* Test whether -fverbose-asm emits option values. */ +/* Contibuted by Devang Patel <dpatel@apple.com>. */ + +/* { dg-do compile } */ +/* { dg-options "-fverbose-asm" } */ +/* { dg-final { scan-assembler "fpeephole=0" } } */ + +int +main (int argc, char *argv []) +{ + return 0; +} diff --git a/gcc/testsuite/gcc.dg/wtr-conversion-1.c b/gcc/testsuite/gcc.dg/wtr-conversion-1.c index 18d26165f2a..b133ff1e8c4 100644 --- a/gcc/testsuite/gcc.dg/wtr-conversion-1.c +++ b/gcc/testsuite/gcc.dg/wtr-conversion-1.c @@ -2,7 +2,8 @@ Note, gcc should omit these warnings in system header files. By Kaveh R. Ghazi <ghazi@caip.rutgers.edu> 4/09/2001. */ /* { dg-do compile } */ -/* { dg-options "-Wtraditional" } */ +/* APPLE LOCAL -Wlong-double */ +/* { dg-options "-Wtraditional -Wno-long-double" } */ extern void foo_i (int); extern void foo_f (float); diff --git a/gcc/testsuite/lib/g++.exp b/gcc/testsuite/lib/g++.exp index 518e836020c..48226db72a9 100644 --- a/gcc/testsuite/lib/g++.exp +++ b/gcc/testsuite/lib/g++.exp @@ -299,12 +299,20 @@ proc g++_target_compile { source dest type options } { } lappend options "additional_flags=[libio_include_flags]" + # APPLE LOCAL begin testsuite multiply defined + if [ istarget *-*-darwin* ] { + lappend options "ldflags=-Wl,-multiply_defined,suppress" + } + # APPLE LOCAL end testsuite multiply defined lappend options "compiler=$GXX_UNDER_TEST"; set options [concat $gpp_compile_options $options] set options [concat "$ALWAYS_CXXFLAGS" $options]; + # APPLE LOCAL long double warning + lappend options "additional_flags=-Wno-long-double" + if { [regexp "(^| )-frepo( |$)" $options] && \ [regexp "\.o(|bj)$" $dest] } then { regsub "\.o(|bj)$" $dest ".rpo" rponame diff --git a/gcc/testsuite/lib/gcc.exp b/gcc/testsuite/lib/gcc.exp index ac4dc35e8e9..a27b3583d90 100644 --- a/gcc/testsuite/lib/gcc.exp +++ b/gcc/testsuite/lib/gcc.exp @@ -143,7 +143,7 @@ proc gcc_target_compile { source dest type options } { if [target_info exists gcc,no_trampolines] { lappend options "additional_flags=-DNO_TRAMPOLINES" } - if [target_info exists gcc,no_label_values] { + if { 1 } { lappend options "additional_flags=-DNO_LABEL_VALUES" } # TOOL_OPTIONS must come first, so that it doesn't override testcase @@ -154,6 +154,11 @@ proc gcc_target_compile { source dest type options } { if [target_info exists gcc,timeout] { lappend options "timeout=[target_info gcc,timeout]" } + # APPLE LOCAL begin testsuite multiply defined + if [ istarget *-*-darwin* ] { + lappend options "ldflags=-Wl,-multiply_defined,suppress" + } + # APPLE LOCAL end testsuite multiply defined lappend options "compiler=$GCC_UNDER_TEST" set options [dg-additional-files-options $options $source] return [target_compile $source $dest $type $options] diff --git a/gcc/testsuite/lib/obj-c++-dg.exp b/gcc/testsuite/lib/obj-c++-dg.exp new file mode 100644 index 00000000000..90e4a37a940 --- /dev/null +++ b/gcc/testsuite/lib/obj-c++-dg.exp @@ -0,0 +1,165 @@ +# APPLE LOCAL file Objective-C++ +# Copyright (C) 2002 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +load_lib dg.exp +load_lib file-format.exp +load_lib target-supports.exp +load_lib scanasm.exp + +# For prune_gcc_output. +load_lib gcc.exp + +if ![info exists TORTURE_OPTIONS] { + # It is theoretically beneficial to group all of the O2/O3 options together, + # as in many cases the compiler will generate identical executables for + # all of them--and the c-torture testsuite will skip testing identical + # executables multiple times. + # Also note that -finline-functions is explicitly included in one of the + # items below, even though -O3 is also specified, because some ports may + # choose to disable inlining functions by default, even when optimizing. + set TORTURE_OPTIONS [list \ + { -O0 } \ + { -O1 } \ + { -O2 } \ + { -O3 -fomit-frame-pointer } \ + { -O3 -fomit-frame-pointer -funroll-loops } \ + { -O3 -fomit-frame-pointer -funroll-all-loops -finline-functions } \ + { -O3 -g } \ + { -Os } ] +} + + +# Split TORTURE_OPTIONS into two choices: one for testcases with loops and +# one for testcases without loops. + +set torture_with_loops $TORTURE_OPTIONS +set torture_without_loops "" +foreach option $TORTURE_OPTIONS { + if ![string match "*loop*" $option] { + lappend torture_without_loops $option + } +} + +# Define gcc callbacks for dg.exp. + +proc obj-c++-dg-test { prog do_what extra_tool_flags } { + # Set up the compiler flags, based on what we're going to do. + + switch $do_what { + "preprocess" { + set compile_type "preprocess" + set output_file "[file rootname [file tail $prog]].i" + } + "compile" { + set compile_type "assembly" + set output_file "[file rootname [file tail $prog]].s" + } + "assemble" { + set compile_type "object" + set output_file "[file rootname [file tail $prog]].o" + } + "link" { + set compile_type "executable" + set output_file "[file rootname [file tail $prog]].exe" + # The following line is needed for targets like the i960 where + # the default output file is b.out. Sigh. + } + "run" { + set compile_type "executable" + # FIXME: "./" is to cope with "." not being in $PATH. + # Should this be handled elsewhere? + # YES. + set output_file "./[file rootname [file tail $prog]].exe" + # This is the only place where we care if an executable was + # created or not. If it was, dg.exp will try to run it. + remote_file build delete $output_file; + } + default { + perror "$do_what: not a valid dg-do keyword" + return "" + } + } + set options "" + if { $extra_tool_flags != "" } { + lappend options "additional_flags=$extra_tool_flags" + } + + set comp_output [obj-c++_target_compile "$prog" "$output_file" "$compile_type" $options]; + + return [list $comp_output $output_file] +} + +proc obj-c++-dg-prune { system text } { + set text [prune_gcc_output $text] + + # If we see "region xxx is full" then the testcase is too big for ram. + # This is tricky to deal with in a large testsuite like c-torture so + # deal with it here. Just mark the testcase as unsupported. + if [regexp "(^|\n)\[^\n\]*: region \[^\n\]* is full" $text] { + # The format here is important. See dg.exp. + return "::unsupported::memory full" + } + + return $text +} + +# Utility routines. + +# +# search_for -- looks for a string match in a file +# +proc search_for { file pattern } { + set fd [open $file r] + while { [gets $fd cur_line]>=0 } { + if [string match "*$pattern*" $cur_line] then { + close $fd + return 1 + } + } + close $fd + return 0 +} + +# Modified dg-runtest that can cycle through a list of optimization options +# as c-torture does. +proc obj-c++-dg-runtest { testcases default-extra-flags } { + global runtests + + foreach test $testcases { + # If we're only testing specific files and this isn't one of + # them, skip it. + if ![runtest_file_p $runtests $test] { + continue + } + + # Look for a loop within the source code - if we don't find one, + # don't pass -funroll[-all]-loops. + global torture_with_loops torture_without_loops + if [expr [search_for $test "for*("]+[search_for $test "while*("]] { + set option_list $torture_with_loops + } else { + set option_list $torture_without_loops + } + + set nshort [file tail [file dirname $test]]/[file tail $test] + + foreach flags $option_list { + verbose "Testing $nshort, $flags" 1 + dg-test $test $flags ${default-extra-flags} + } + } +} diff --git a/gcc/testsuite/lib/obj-c++.exp b/gcc/testsuite/lib/obj-c++.exp new file mode 100644 index 00000000000..05a84268758 --- /dev/null +++ b/gcc/testsuite/lib/obj-c++.exp @@ -0,0 +1,311 @@ +# APPLE LOCAL file Objective-C++ +# Copyright (C) 2002 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# This file was written by Rob Savoye (rob@cygnus.com) +# Currently maintained by Doug Evans (dje@cygnus.com) + +# This file is loaded by the tool init file (eg: unix.exp). It provides +# default definitions for objc_start, etc. and other supporting cast members. + +# These globals are used by objc_start if no compiler arguments are provided. +# They are also used by the various testsuites to define the environment: +# where to find stdio.h, libc.a, etc. + +load_lib libgloss.exp +load_lib prune.exp +load_lib gcc-defs.exp + +# We want to sponge off many G++ goodies. +load_lib g++.exp + +# +# OBJCXX_UNDER_TEST is the compiler under test. +# + +# +# default_obj-c++_version -- extract and print the version number of the compiler +# + +proc default_obj-c++_version { } { + global OBJCXX_UNDER_TEST + + obj-c++_init; + + # ignore any arguments after the command + set compiler [lindex $OBJCXX_UNDER_TEST 0] + + if ![is_remote host] { + set compiler_name [which $compiler]; + } else { + set compiler_name $compiler; + } + + # verify that the compiler exists + if { $compiler_name != 0 } then { + set tmp [remote_exec host "$compiler -v"] + set status [lindex $tmp 0]; + set output [lindex $tmp 1]; + regexp "version.*$" $output version + if { $status == 0 && [info exists version] } then { + clone_output "$compiler_name $version\n" + } else { + clone_output "Couldn't determine version of $compiler_name: $output\n" + } + } else { + # compiler does not exist (this should have already been detected) + warning "$compiler does not exist" + } +} + +# +# Call obj-c++_version. We do it this way so we can override it if needed. +# +proc obj-c++_version { } { + default_obj-c++_version; +} + +# +# obj-c++_init -- called at the start of each .exp script. +# +# There currently isn't much to do, but always using it allows us to +# make some enhancements without having to go back and rewrite the scripts. +# + +set objcxx_initialized 0 + +proc obj-c++_init { args } { + global subdir + global objcxx_initialized + global base_dir + global tmpdir + global libdir + global gluefile wrap_flags + global ALWAYS_CXXFLAGS + global GXX_UNDER_TEST + global OBJCXX_UNDER_TEST + global TOOL_EXECUTABLE + global TESTING_IN_BUILD_TREE + + if { $objcxx_initialized == 1 } { return; } + + if ![info exists GXX_UNDER_TEST] then { + if [info exists TOOL_EXECUTABLE] { + set GXX_UNDER_TEST $TOOL_EXECUTABLE; + } else { + if { [is_remote host] || ! [info exists TESTING_IN_BUILD_TREE] } { + set GXX_UNDER_TEST [transform c++] + } else { + set GXX_UNDER_TEST [findfile $base_dir/../g++ "$base_dir/../g++ -B$base_dir/../" [findfile $base_dir/g++ "$base_dir/g++ -B$base_dir/" [transform c++]]] + } + } + } + + set OBJCXX_UNDER_TEST "$GXX_UNDER_TEST -x objective-c++" + + if ![info exists tmpdir] then { + set tmpdir /tmp + } + if { [target_info needs_status_wrapper]!="" && ![info exists gluefile] } { + set gluefile ${tmpdir}/testglue.o; + set result [build_wrapper $gluefile]; + if { $result != "" } { + set gluefile [lindex $result 0]; + set wrap_flags [lindex $result 1]; + } else { + unset gluefile + } + } + + set ALWAYS_CXXFLAGS "" + + if ![is_remote host] { + if [info exists TOOL_OPTIONS] { + lappend ALWAYS_CXXFLAGS "additional_flags=[g++_include_flags [get_multilibs ${TOOL_OPTIONS}] ]"; + lappend ALWAYS_CXXFLAGS "ldflags=[g++_link_flags [get_multilibs ${TOOL_OPTIONS}] ]"; + } else { + lappend ALWAYS_CXXFLAGS "additional_flags=[g++_include_flags [get_multilibs] ]"; + lappend ALWAYS_CXXFLAGS "ldflags=[g++_link_flags [get_multilibs] ]"; + } + } + + if [info exists TOOL_OPTIONS] { + lappend ALWAYS_CXXFLAGS "additional_flags=$TOOL_OPTIONS"; + } + + # Make sure that lines are not wrapped. That can confuse the + # error-message parsing machinery. + lappend ALWAYS_CXXFLAGS "additional_flags=-fmessage-length=0" + + verbose -log "ALWAYS_CXXFLAGS set to $ALWAYS_CXXFLAGS" + + verbose "obj-c++ is initialized" 3 +} + +proc obj-c++_target_compile { source dest type options } { + global rootme; + global tmpdir; + global gluefile wrap_flags; + global ALWAYS_CXXFLAGS + global OBJCXX_UNDER_TEST + global TOOL_OPTIONS + global ld_library_path + + lappend options "compiler=$OBJCXX_UNDER_TEST" + + #set ld_library_path ".:${rootme}" + lappend options "libs=-lstdc++" + + if { [target_info needs_status_wrapper]!="" && [info exists gluefile] } { + lappend options "libs=${gluefile}" + lappend options "ldflags=$wrap_flags" + } + + if [target_info exists obj-c++,stack_size] { + lappend options "additional_flags=-DSTACK_SIZE=[target_info obj-c++,stack_size]" + } + if [target_info exists obj-c++,no_trampolines] { + lappend options "additional_flags=-DNO_TRAMPOLINES" + } + if [target_info exists obj-c++,no_label_values] { + lappend options "additional_flags=-DNO_LABEL_VALUES" + } + if [info exists TOOL_OPTIONS] { + lappend options "additional_flags=$TOOL_OPTIONS" + } + + set options [concat "$ALWAYS_CXXFLAGS" $options]; + + return [target_compile $source $dest $type $options] +} + +# +# obj-c++_pass -- utility to record a testcase passed +# + +proc obj-c++_pass { testcase cflags } { + if { "$cflags" == "" } { + pass "$testcase" + } else { + pass "$testcase, $cflags" + } +} + +# +# obj-c++_fail -- utility to record a testcase failed +# + +proc obj-c++_fail { testcase cflags } { + if { "$cflags" == "" } { + fail "$testcase" + } else { + fail "$testcase, $cflags" + } +} + +# +# obj-c++_finish -- called at the end of every .exp script that calls obj-c++_init +# +# The purpose of this proc is to hide all quirks of the testing environment +# from the testsuites. It also exists to undo anything that obj-c++_init did +# (that needs undoing). +# + +proc obj-c++_finish { } { + # The testing harness apparently requires this. + global errorInfo; + + if [info exists errorInfo] then { + unset errorInfo + } + + # Might as well reset these (keeps our caller from wondering whether + # s/he has to or not). + global prms_id bug_id + set prms_id 0 + set bug_id 0 +} + +proc obj-c++_exit { } { + global gluefile; + + if [info exists gluefile] { + file_on_build delete $gluefile; + unset gluefile; + } +} + +# If this is an older version of dejagnu (without runtest_file_p), +# provide one and assume the old syntax: foo1.exp bar1.c foo2.exp bar2.c. +# This can be deleted after next dejagnu release. + +if { [info procs runtest_file_p] == "" } then { + proc runtest_file_p { runtests testcase } { + if { $runtests != "" && [regexp "\[.\]\[cC\]" $runtests] } then { + if { [lsearch $runtests [file tail $testcase]] >= 0 } then { + return 1 + } else { + return 0 + } + } + return 1 + } +} + +# Provide a definition of this if missing (delete after next dejagnu release). + +if { [info procs prune_warnings] == "" } then { + proc prune_warnings { text } { + return $text + } +} + +# Utility used by mike-gcc.exp and c-torture.exp. +# Check the compiler(/assembler/linker) output for text indicating that +# the testcase should be marked as "unsupported". +# +# When dealing with a large number of tests, it's difficult to weed out the +# ones that are too big for a particular cpu (eg: 16 bit with a small amount +# of memory). There are various ways to deal with this. Here's one. +# Fortunately, all of the cases where this is likely to happen will be using +# gld so we can tell what the error text will look like. + +proc ${tool}_check_unsupported_p { output } { + if [regexp "(^|\n)\[^\n\]*: region \[^\n\]* is full" $output] { + return "memory full" + } + return "" +} + +# Prune messages from obj-c++ that aren't useful. + +proc prune_obj-c++_output { text } { + #send_user "Before:$text\n" + regsub -all "(^|\n)\[^\n\]*: In (function|method) \[^\n\]*" $text "" text + regsub -all "(^|\n)\[^\n\]*: At top level:\[^\n\]*" $text "" text + + # It would be nice to avoid passing anything to obj-c++ that would cause it to + # issue these messages (since ignoring them seems like a hack on our part), + # but that's too difficult in the general case. For example, sometimes + # you need to use -B to point obj-c++ at crt0.o, but there are some targets + # that don't have crt0.o. + regsub -all "(^|\n)\[^\n\]*file path prefix \[^\n\]* never used" $text "" text + regsub -all "(^|\n)\[^\n\]*linker input file unused since linking not done" $text "" text + + #send_user "After:$text\n" + + return $text +} diff --git a/gcc/testsuite/lib/scanasm.exp b/gcc/testsuite/lib/scanasm.exp index 79d93cbf089..527813139f6 100644 --- a/gcc/testsuite/lib/scanasm.exp +++ b/gcc/testsuite/lib/scanasm.exp @@ -156,12 +156,13 @@ proc scan-assembler-dem { args } { } # Find c++filt like we find g++ in g++.exp. + # APPLE LOCAL - c++filt3 if ![info exists cxxfilt] { set cxxfilt [findfile $base_dir/../../binutils/cxxfilt \ $base_dir/../../binutils/cxxfilt \ [findfile $base_dir/../c++filt $base_dir/../c++filt \ [findfile $base_dir/c++filt $base_dir/c++filt \ - [transform c++filt]]]] + [transform c++filt3]]]] verbose -log "c++filt is $cxxfilt" } @@ -202,12 +203,13 @@ proc scan-assembler-dem-not { args } { } # Find c++filt like we find g++ in g++.exp. + # APPLE LOCAL - c++filt3 if ![info exists cxxfilt] { set cxxfilt [findfile $base_dir/../../binutils/cxxfilt \ $base_dir/../../binutils/cxxfilt \ [findfile $base_dir/../c++filt $base_dir/../c++filt \ [findfile $base_dir/c++filt $base_dir/c++filt \ - [transform c++filt]]]] + [transform c++filt3]]]] verbose -log "c++filt is $cxxfilt" } diff --git a/gcc/testsuite/lib/scantree.exp b/gcc/testsuite/lib/scantree.exp index 76d1a59fb60..b53c1ba235f 100644 --- a/gcc/testsuite/lib/scantree.exp +++ b/gcc/testsuite/lib/scantree.exp @@ -19,6 +19,51 @@ # # This is largely borrowed from scanasm.exp. +# Utility for diffing compiler result against an expected output file. +# Invoked via dg-final. Call pass if there are no differences between +# the output of the compiler and the expected output file, otherwise +# fail. The expected output file has the same name as the output +# file, and is stored in the same directory as the testcase. +# +# Argument 0 is the suffix for the tree dump file +# Argument 1 handles expected failures and the like +proc diff-tree-dumps { args } { + if { [llength $args] < 1 } { + error "diff-tree-dumps: too few arguments" + return + } + if { [llength $args] > 2 } { + error "diff-tree-dumps:: too many arguments" + return + } + if { [llength $args] >= 2 } { + switch [dg-process-target [lindex $args 1]] { + "S" { } + "N" { return } + "F" { setup_xfail "*-*-*" } + "P" { } + } + } + + # This assumes that we are two frames down from dg-test, and that + # it still stores the filename of the testcase in a local variable "name". + # A cleaner solution would require a new dejagnu release. + upvar 2 prog testcase + + # This must match the rule in gcc-dg.exp. + set new_file "[glob [file tail $testcase].t??.[lindex $args 0]]" + set reference_file "[glob $testcase.[lindex $args 0]]" + + set test_result [diff $reference_file $new_file] + + if { $test_result == 1 } { + pass "$testcase diff-tree-dumps [lindex $args 0]" + } else { + fail "$testcase diff-tree-dumps [lindex $args 0]" + local_exec (diff $reference_file $new_file 0); + } +} + # Utility for scanning compiler result, invoked via dg-final. # Call pass if pattern is present, otherwise fail. # diff --git a/gcc/testsuite/obj-c++.dg/basic.mm b/gcc/testsuite/obj-c++.dg/basic.mm new file mode 100644 index 00000000000..6a0de713825 --- /dev/null +++ b/gcc/testsuite/obj-c++.dg/basic.mm @@ -0,0 +1,24 @@ +// APPLE LOCAL file Objective-C++ +// A basic sanity check for Objective-C++. +// { dg-do run } + +#include <objc/objc.h> +#include <objc/Object.h> + +#include <iostream> + +@interface Greeter : Object +- (void) greet; +@end + +@implementation Greeter +- (void) greet { printf ("Hello from Objective-C\n"); } +@end + +int +main () +{ + std::cout << "Hello from C++\n"; + Greeter *obj = [Greeter new]; + [obj greet]; +} diff --git a/gcc/testsuite/obj-c++.dg/dg.exp b/gcc/testsuite/obj-c++.dg/dg.exp new file mode 100644 index 00000000000..52109d30131 --- /dev/null +++ b/gcc/testsuite/obj-c++.dg/dg.exp @@ -0,0 +1,40 @@ +# APPLE LOCAL file Objective-C++ +# GCC Objective-C++ testsuite that uses the `dg.exp' driver. +# Copyright (C) 2002 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# Load support procs. +load_lib obj-c++-dg.exp + +# If a testcase doesn't have special options, use these. +global DEFAULT_CXXFLAGS +if ![info exists DEFAULT_CXXFLAGS] then { + set DEFAULT_CXXFLAGS "" +} + +# Initialize `dg'. +dg-init + +# Gather a list of all tests. +set all [lsort [find $srcdir/$subdir *.mm]] + +# Main loop. +# (The -lobjc is a cheap hack, should be fixed to account for both +# installed and uninstalled objc libs) +dg-runtest $all "" "$DEFAULT_CXXFLAGS -lobjc" + +# All done. +dg-finish diff --git a/gcc/testsuite/obj-c++.dg/method-1.mm b/gcc/testsuite/obj-c++.dg/method-1.mm new file mode 100644 index 00000000000..7b6f9364140 --- /dev/null +++ b/gcc/testsuite/obj-c++.dg/method-1.mm @@ -0,0 +1,30 @@ +/* APPLE LOCAL file Objective-C++ */ +/* Test whether casting 'id' to a specific class removes method lookup + ambiguity. */ +/* Author: Ziemowit Laski <zlaski@apple.com>. */ +/* { dg-do compile } */ + +#import <objc/objc.h> + +@class Int1, Int2; + +@interface Int1 ++ (Int1 *)classMethod1; ++ (id)classMethod2; +- (Int1 *)instanceMethod:(Int2 *)arg; /* { dg-bogus "using" } */ +@end + +@interface Int2: Int1 ++ (Int1 *)classMethod1; ++ (id)classMethod2; +- (id)int2Method; +- (int)instanceMethod:(int)arg; /* { dg-bogus "also found" } */ +@end + +int main(void) { + id i = [(Int2 *)[Int1 classMethod1] int2Method]; /* { dg-bogus "does not respond to" } */ + int j = [(Int2 *)[Int2 classMethod2] instanceMethod: 45]; /* { dg-bogus "multiple declarations" } */ + /* { dg-bogus "invalid conversion" "" { target *-*-* } 26 } */ + /* { dg-bogus "invalid conversion" "" { target *-*-* } 26 } */ + return j; +} diff --git a/gcc/testsuite/obj-c++.dg/super-class-1.mm b/gcc/testsuite/obj-c++.dg/super-class-1.mm new file mode 100644 index 00000000000..5b1bd6c0236 --- /dev/null +++ b/gcc/testsuite/obj-c++.dg/super-class-1.mm @@ -0,0 +1,30 @@ +/* APPLE LOCAL file call super */ +/* Test calling super from within a category method. */ +/* { dg-do compile } */ +#import <objc/objc.h> + +@interface NSObject +@end +@interface NSMenuItem: NSObject +@end + +@interface NSObject (Test) ++ (int) test_func; +@end + +@implementation NSObject (Test) ++ (int) test_func +{} +@end + +@interface NSMenuItem (Test) ++ (int) test_func; +@end + +@implementation NSMenuItem (Test) ++ (int) test_func +{ + return [super test_func]; /* { dg-bogus "invalid use of undefined type" } */ +} /* { dg-bogus "forward declaration of" "" { target *-*-* } 27 } */ +@end + diff --git a/gcc/testsuite/obj-c++/redo-dg.exp b/gcc/testsuite/obj-c++/redo-dg.exp new file mode 100644 index 00000000000..be5eebd632d --- /dev/null +++ b/gcc/testsuite/obj-c++/redo-dg.exp @@ -0,0 +1,38 @@ +# APPLE LOCAL file Objective-C++ +# GCC Objective-C++ testsuite that uses the `dg.exp' driver. +# Copyright (C) 2002 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# Load support procs. +load_lib obj-c++-dg.exp + +# If a testcase doesn't have special options, use these. +global DEFAULT_CXXFLAGS +if ![info exists DEFAULT_CXXFLAGS] then { + set DEFAULT_CXXFLAGS "" +} + +# Initialize `dg'. +dg-init + +# Gather a list of all tests. +set all [lsort [find $srcdir/g++.dg *.C]] + +# Main loop. +dg-runtest $all "" "$DEFAULT_CXXFLAGS" + +# All done. +dg-finish diff --git a/gcc/testsuite/obj-c++/redo-old-deja.exp b/gcc/testsuite/obj-c++/redo-old-deja.exp new file mode 100644 index 00000000000..1e06c55460e --- /dev/null +++ b/gcc/testsuite/obj-c++/redo-old-deja.exp @@ -0,0 +1,63 @@ +# APPLE LOCAL file Objective-C++ +# Copyright (C) 2002 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# This file was written by Rob Savoye. (rob@cygnus.com) + +# +# these tests come from the original DejaGnu test suite +# developed at Cygnus Support. If this isn't deja gnu, I +# don't know what is... +# + +# load support procs +load_lib old-dejagnu.exp +load_lib obj-c++.exp + + +# When a testcase doesn't have any special options, use these. +if ![info exists DEFAULT_CXXFLAGS] { + set DEFAULT_CXXFLAGS "-ansi -pedantic-errors -Wno-long-long" + +} + +old-dejagnu-init +global OBJCXX_UNDER_TEST + +# +# main test loop +# + +set dirlen [expr [string length "$srcdir/$subdir"] + 1]; +foreach file [lsort [find $srcdir/g++.old-deja *.C]] { + # If we're only testing specific files and this isn't one of them, skip it. + set tfile [string range $file $dirlen end]; + if ![runtest_file_p $runtests $tfile] then { + continue + } + verbose "Testing $file" + + # We don't want old-dejagnu.exp to have to know about all the global + # variables we use. For now we tell it about CXXFLAGS and LIBS and + # leave LDFLAGS alone. + old-dejagnu $OBJCXX_UNDER_TEST "$file" "$tfile" "" "$DEFAULT_CXXFLAGS" "-lstdc++" +} + +# The framework doesn't like to see any error remnants, +# so remove them. +if [info exists errorInfo] then { + unset errorInfo +} diff --git a/gcc/testsuite/objc.dg/call-super-1.m b/gcc/testsuite/objc.dg/call-super-1.m index 19e0d4900dd..b33af776f49 100644 --- a/gcc/testsuite/objc.dg/call-super-1.m +++ b/gcc/testsuite/objc.dg/call-super-1.m @@ -1,7 +1,8 @@ +/* APPLE LOCAL file msg send super */ /* Check if objc_super stack variables are created correctly (and not clobbered by other values). */ /* Contributed by Ziemowit Laski <zlaski@apple.com>. */ -/* { dg-options "-std=c99 -lobjc" } */ +/* { dg-options "-std=c99" } */ /* { dg-do run } */ #include <objc/objc.h> diff --git a/gcc/testsuite/objc.dg/category-1.m b/gcc/testsuite/objc.dg/category-1.m index 1d29e374aea..251b125a617 100644 --- a/gcc/testsuite/objc.dg/category-1.m +++ b/gcc/testsuite/objc.dg/category-1.m @@ -1,16 +1,10 @@ +/* APPLE LOCAL file objc test suite */ /* Test class methods inside categories. */ /* Author: Ziemowit Laski <zlaski@apple.com>. */ /* { dg-options "-lobjc" } */ /* { dg-do run } */ #include <objc/Object.h> - -#ifdef __NEXT_RUNTIME__ -#define SUPERCLASS superclass -#else -#define SUPERCLASS superClass -#endif - extern int strcmp(const char *s1, const char *s2); extern void abort(void); #define CHECK_IF(expr) if(!(expr)) abort() @@ -20,7 +14,7 @@ extern void abort(void); @end @implementation MyObject -+ (Class)whatever1 { return [super SUPERCLASS]; } ++ (Class)whatever1 { return [super superclass]; } @end @interface MyObject (ThisWontCompile) @@ -28,7 +22,7 @@ extern void abort(void); @end @implementation MyObject (ThisWontCompile) -+(Class)whatever2 { return [super SUPERCLASS]; } ++(Class)whatever2 { return [super superclass]; } @end int main (int argc, const char * argv[]) diff --git a/gcc/testsuite/objc.dg/const-cfstring-1.m b/gcc/testsuite/objc.dg/const-cfstring-1.m new file mode 100644 index 00000000000..d409209daed --- /dev/null +++ b/gcc/testsuite/objc.dg/const-cfstring-1.m @@ -0,0 +1,56 @@ +/* APPLE LOCAL file constant cfstrings */ +/* Test the -fconstant-cfstrings option for constructing + compile-time immutable CFStrings, and their interoperation + with both Cocoa and CoreFoundation. This will only work + on MacOS X 10.1.2 and later. */ +/* Developed by Ziemowit Laski <zlaski@apple.com>. */ + +/* { dg-do run { target *-*-darwin* } } */ +/* { dg-options "-fconstant-cfstrings -framework Cocoa" } */ + +#import <Foundation/NSString.h> +#import <CoreFoundation/CFString.h> + +void printOut(NSString *str) { + NSLog(@"The value of str is: %@", str); +} + +CFStringRef s0a = CFSTR("Compile-time string literal"); +CFStringRef s0b = CFSTR("Compile-time string literal"); + +void checkNSRange(NSRange r) { + if (r.location != 6 || r.length != 5) { + printOut(@"Range check failed"); + abort(); + } +} + +void checkCFRange(CFRange r) { + if (r.location != 6 || r.length != 5) { + printOut(@"Range check failed"); + abort(); + } +} + +int main(void) { + const NSString *s1 = @"Compile-time string literal"; + CFStringRef s2 = CFSTR("Compile-time string literal"); + + checkNSRange([@"Hello World" rangeOfString:@"World"]); + checkNSRange([(id)CFSTR("Hello World") rangeOfString:@"World"]); + checkNSRange([@"Hello World" rangeOfString:(id)CFSTR("World")]); + checkNSRange([(id)CFSTR("Hello World") rangeOfString:(id)CFSTR("World")]); + + checkCFRange(CFStringFind((CFStringRef)@"Hello World", (CFStringRef)@"World", 0)); + checkCFRange(CFStringFind(CFSTR("Hello World"), (CFStringRef)@"World", 0)); + checkCFRange(CFStringFind((CFStringRef)@"Hello World", CFSTR("World"), 0)); + checkCFRange(CFStringFind(CFSTR("Hello World"), CFSTR("World"), 0)); + + /* Check for string uniquing. */ + if (s0a != s0b || s0a != s2 || s1 != (id)s2) { + NSLog(@"String uniquing failed"); + abort (); + } + + return 0; +} diff --git a/gcc/testsuite/objc.dg/const-cfstring-2.m b/gcc/testsuite/objc.dg/const-cfstring-2.m new file mode 100644 index 00000000000..57b8d95a7d4 --- /dev/null +++ b/gcc/testsuite/objc.dg/const-cfstring-2.m @@ -0,0 +1,26 @@ +/* APPLE LOCAL file constant CFStrings */ +/* Test the -Wnonportable-cfstrings option, which should give + warnings if non-ASCII characters are embedded in constant + CFStrings. This will only work on MacOS X 10.2 and later. */ +/* Developed by Ziemowit Laski <zlaski@apple.com>. */ + +/* { dg-do compile { target *-*-darwin* } } */ +/* { dg-options "-fconstant-cfstrings -Wnonportable-cfstrings" } */ + +#import <Foundation/NSString.h> +#import <CoreFoundation/CFString.h> + +#ifndef __CONSTANT_CFSTRINGS__ +#error The -fconstant-cfstrings option is not functioning properly +#endif + +void foo(void) { + NSString *s1 = @"Compile-time string literal"; + CFStringRef s2 = CFSTR("Compile-time string literal"); + NSString *s3 = @"Non-ASCII literal - \222"; /* { dg-warning "non-ASCII character in CFString literal" } */ + CFStringRef s4 = CFSTR("\222 - Non-ASCII literal"); /* { dg-warning "non-ASCII character in CFString literal" } */ + CFStringRef s5 = CFSTR("Non-ASCII (\222) literal"); /* { dg-warning "non-ASCII character in CFString literal" } */ + NSString *s6 = @"\0Embedded NUL"; /* { dg-warning "embedded NUL in CFString literal" } */ + CFStringRef s7 = CFSTR("Embedded \0NUL"); /* { dg-warning "embedded NUL in CFString literal" } */ + CFStringRef s8 = CFSTR("Embedded NUL\0"); /* { dg-warning "embedded NUL in CFString literal" } */ +} diff --git a/gcc/testsuite/objc.dg/const-str-3.m b/gcc/testsuite/objc.dg/const-str-3.m index edc03ff62c7..9fe508b525c 100644 --- a/gcc/testsuite/objc.dg/const-str-3.m +++ b/gcc/testsuite/objc.dg/const-str-3.m @@ -1,9 +1,10 @@ +/* APPLE LOCAL file constant strings */ /* Test the -fconstant-string-class=Foo option under the NeXT runtime. */ /* Developed by Markus Hitter <mah@jump-ing.de>. */ /* { dg-options "-fnext-runtime -fconstant-string-class=Foo -lobjc" } */ -/* { dg-do run { target *-*-darwin* } } */ +/* { dg-do run } */ #include <stdio.h> #include <objc/objc.h> @@ -26,11 +27,6 @@ struct objc_class _FooClassReference; int main () { Foo *string = @"bla"; - Foo *string2 = @"bla"; - - if(string != string2) - abort(); - printf("Strings are being uniqued properly\n"); /* This memcpy has to be done before the first message is sent to a constant string object. Can't be moved to +initialize since _that_ diff --git a/gcc/testsuite/objc.dg/dg.exp b/gcc/testsuite/objc.dg/dg.exp index ebf952967c7..7b3eba41d98 100644 --- a/gcc/testsuite/objc.dg/dg.exp +++ b/gcc/testsuite/objc.dg/dg.exp @@ -28,7 +28,8 @@ if ![info exists DEFAULT_CFLAGS] then { dg-init # Main loop. -dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[m\]]] \ +# APPLE LOCAL -ObjC +dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[mc\]]] \ "" $DEFAULT_CFLAGS # All done. diff --git a/gcc/testsuite/objc.dg/encode-1.m b/gcc/testsuite/objc.dg/encode-1.m index 868c3254753..126e5d010f4 100644 --- a/gcc/testsuite/objc.dg/encode-1.m +++ b/gcc/testsuite/objc.dg/encode-1.m @@ -1,9 +1,9 @@ +/* APPLE LOCAL file bool encoding */ /* Test if the Objective-C @encode machinery distinguishes between - 'BOOL *' (which should be encoded as a pointer to BOOL) and 'char *' (which - should be encoded as '*'). This is somewhat tricky wrt the NeXT runtime, - where we have 'typedef char BOOL'. */ + 'BOOL *' (which should be encoded as '^c') and 'char *' (which + should be encoded as '*'). */ /* Contributed by Ziemowit Laski <zlaski@apple.com>. */ -/* { dg-options "-fnext-runtime -lobjc" } */ +/* { dg-options "-lobjc" } */ /* { dg-do run } */ #include <string.h> @@ -12,10 +12,9 @@ int main(void) { const char *BOOL_ptr = @encode(BOOL *); - const char *BOOL_ = @encode(BOOL); const char *char_ptr = @encode(char *); - - if(*BOOL_ptr != '^' || strcmp(BOOL_ptr + 1, BOOL_)) + + if(strcmp(BOOL_ptr, "^c")) abort(); if(strcmp(char_ptr, "*")) diff --git a/gcc/testsuite/objc.dg/nested-func-1.m b/gcc/testsuite/objc.dg/nested-func-1.m index 7a182bd938e..ae45fee8621 100644 --- a/gcc/testsuite/objc.dg/nested-func-1.m +++ b/gcc/testsuite/objc.dg/nested-func-1.m @@ -1,3 +1,4 @@ +/* APPLE LOCAL file nested functions */ /* Test basic nested C function functionality within ObjC methods. */ /* Contributed by Ziemowit Laski <zlaski@apple.com>. */ diff --git a/gcc/testsuite/objc.dg/objc.c b/gcc/testsuite/objc.dg/objc.c new file mode 100644 index 00000000000..748111c26eb --- /dev/null +++ b/gcc/testsuite/objc.dg/objc.c @@ -0,0 +1,6 @@ +/* APPLE LOCAL file -ObjC */ + +/* { dg-do compile } */ +/* { dg-options "-ObjC" } */ + +@class foo; |